(in-package :pkgmgr-pkgdb)

(defparameter *default-db-dir*         "/var/db/pkg/")
(defparameter *default-conf*           "/etc/pkgmanager/pkgdb")
(defparameter *default-want-priority*  1.0)
;; Core wants is a list of packages required for the operation
;; of pkgmanager itself.
(defparameter *core-wants*             (list "pkgtools/pkg_install,1000.0"
					     "pkgtools/pkg_tarup,900.0"
					     "pkgtools/digest,900.0"
					     "wip/pkgmanager,500.0"))
;; The current 'revision' of the pkgdb code. The revision is bumped whenever
;; there is need for a conversion or addition of new information. Thus, for
;; a revision <n> there is one or more configuration upgrade functions available
;; to perform an upgrade from revision <n - 1>.
(defparameter *pkgdb-config-revision*       3)
(defparameter *pkgdb-config-upgraders*     (list 1 'upgrade-configuration-1
						 2 'upgrade-configuration-2
						 3 'upgrade-configuration-3))

(define-condition db-error (extended-error)
  ((message :initarg :message :reader db-error-message)))

(define-condition user-correctable-db-error (db-error)
  ())

(define-condition summary-parse-error (db-error)
  ())

(define-condition circular-dependency-error (db-error)
  ())

(define-condition unsupported-config-error (db-error)
  ())

(define-condition want-item-does-not-exit-error (user-correctable-db-error)
  ())

(define-condition invalid-want-specification (user-correctable-db-error)
  ())

(defclass db ()
  ((confpath :initarg :confpath
	     :accessor db-confpath
	     :initform *default-conf*
	     :documentation "Path to configuration file")
   (conf :initarg :conf
	 :accessor db-conf
	 :initform nil
	 :documentation "Parsed version of configuration")
   (summary-cache :initarg :summary-cache
		  :accessor db-summary-cache
		  :initform nil
		  :documentation "Summary cache for this database")
   (pkgs :initarg :pkgs
	 :accessor db-pkgs
	 :initform (make-hash-table :test 'equal)
	 :documentation "Hash table of all packages, with key = origin path")
   (is :initarg :is
       :accessor db-is
       :initform (make-hash-table :test 'equal)
       :documentation "Hash table of all installations, with key = installation name")))

(defclass pkg ()
  ((dir :initarg :dir :accessor pkg-dir :initform nil)
   (name :initarg :name :accessor pkg-name :initform nil)
   (deps :initarg :deps :accessor pkg-deps :initform nil)
   (missing :initarg :missing :accessor pkg-missing :initform nil)
   (needed :initarg :needed :accessor pkg-needed :initform nil)
   (wanted :initarg :wanted :accessor pkg-wanted :initform nil)
   (failed :initarg :failed :accessor pkg-failed :initform nil)
   (installation :initarg :installation :accessor pkg-installation :initform nil)
   (priority :initarg :priority :accessor pkg-priority :initform 0.0)))

(defclass installation ()
  ((name :initarg :name :accessor installation-name :initform nil)
   (pkg :initarg :pkg :accessor installation-pkg :initform nil)
   (itime :initarg :itime :accessor installation-itime :initform nil)))

(defclass summary ()
  ((path :initarg :path
	 :accessor summary-path
	 :initform nil
	 :documentation "The package path this summary describes")
   (name :initarg :name
	 :accessor summary-name
	 :initform nil
	 :documentation "The name of a would-be installation")
   (deps :initarg :deps
	 :accessor summary-deps
	 :initform nil
	 :documentation "List of dependencies (path strings)")
   (modtime :initarg :modtime
	    :accessor summary-modtime
	    :initform nil
	    :documentation "Modtime of directory when summary was cached")))

(defclass summary-cache ()
  ((summaries :initarg :summaries
	      :accessor summary-cache-summaries
	      :initform (make-hash-table :test 'equal)
	      :documentation "Hash table (key = origin path) of summary information")))

(defun env-default (var def)
  (let ((val (ext:getenv var)))
    (if val
	val
	def)))
(defun env-make ()
  (env-default "PKGMANAGER_MAKE" "make"))
(defun env-pkg-info ()
  (env-default "PKGMANAGER_PKGINFO" "pkg_info"))
(defun env-pkg-delete ()
  (env-default "PKGMANAGER_PKGDELETE" "pkg_delete"))
(defun env-dbdir ()
  (let ((db-dir (ext:getenv "PKGMANAGER_DBDIR")))
    (if db-dir
	(format nil "~a/" db-dir)
	*default-db-dir*)))
(defun env-prefix ()
  (env-default "PKGMANAGER_PREFIX" "/usr/pkg"))

(defmethod print-object ((i installation) s)
  (if *print-readably*
      (format s "#<installation ~a (~a)>" (installation-name i) (installation-pkg i))
      (format s "~a" (installation-name i))))
(defmethod print-object ((p pkg) s)
  (if *print-readably*
      (format s "#<pkg ~a>" (pkg-dir p))
      (format s "~a" (pkg-dir p))))

(defmethod summary-cache-summary ((sc summary-cache) (path string))
  (let* ((cached-entry (gethash path (summary-cache-summaries sc)))
	 (summary (if cached-entry
		      (refresh-summary cached-entry)
		      (let ((new-summary (refresh-summary (make-instance 'summary :path path))))
			(setf (gethash path (summary-cache-summaries sc)) new-summary)
			new-summary))))
    summary))

(defmethod invalidate-summary-cache ((sc summary-cache))
  (clrhash (summary-cache-summaries sc)))

(defmethod persist-summary-cache ((sc summary-cache))
  (let ((slist (list)))
    (maphash #'(lambda (k v)
		 (declare (ignore k))
		 (setf slist
		       (cons (list (summary-path v)
				   (summary-name v)
				   (summary-deps v)
				   (summary-modtime v))
			     slist)))
	     (summary-cache-summaries sc))
    slist))

(defmethod depersist-summary-cache ((sc summary-cache) (persisted-cache list))
  (mapc #'(lambda (slist)
	    (let ((s (make-instance 'summary
				    :path (nth 0 slist)
				    :name (nth 1 slist)
				    :deps (nth 2 slist)
				    :modtime (nth 3 slist))))
	      (setf (gethash (summary-path s) (summary-cache-summaries sc)) s)))
	persisted-cache))

(defun ends-with (str ending)
  (and (>= (length str) (length ending))
       (string= ending (subseq str (- (length str) (length ending)) (length str)))))

(defun get-rec-modtime (dir)
  (let ((subs (mapcar #'(lambda (p) (format nil "~a" p)) (directory (format nil "~a/*" dir))))
	(mtime 0))
    (mapcar #'(lambda (p)
		(when (not (ends-with p "work"))
		  (setf mtime (max mtime (stat-mtime p)))
		  (get-rec-modtime (format nil "~a/*" p))))
	    subs)
    mtime))

(defmethod refresh-summary ((s summary) &key (force nil))
  "Refresh this summary if needed. If force is t, always refresh"
  (let ((modtime (get-rec-modtime (format nil "/usr/pkgsrc/~a" (summary-path s)))))
    (if (or force
	    (not (summary-modtime s))
	    (not (= (summary-modtime s) modtime)))
	(progn
	  (print-notice "Refreshing summary information for ~a" (summary-path s))
	  (setf (summary-modtime s) modtime)
	  (let ((summary (slurp-shell-input (format nil
						    "'cd /usr/pkgsrc/~a && ~a print-summary-data'"
						    (summary-path s)
						    (env-make)))))
	    (let ((name-scanner (create-scanner (format nil "^index ~a (.*)$" (regexp-escape (summary-path s))) :multi-line-mode t))
		  (depline-scanner (create-scanner (format nil "^(depends|build_depends) ~a (.*)$" (regexp-escape (summary-path s))) :multi-line-mode t)))
	      (multiple-value-bind (m matches) (scan-to-strings name-scanner summary)
		(if m
		    (setf (summary-name s) (elt matches 0))
		    (error 'summary-parse-error :message (format nil "Could not find index entry for package ~a" (summary-path s)))))
	      (do-register-groups (deptype deplist) (depline-scanner summary)
				  (declare (ignore deptype))
				  (do-register-groups (deppath) (":([^ ]+)\ ?" deplist)
						      (setf (summary-deps s) (cons (path-merge (summary-path s) deppath) (summary-deps s))))))))
	(print-debug "Summary for ~a does not need updating" (summary-path s))))
  s)

(defmethod refresh-summary-cache ((sc summary-cache) &key (force nil))
  "Refresh this summary cache as needed. If force is t, all summaries
   will be refreshed no matter what. Returns the summary cache."
  (print-notice "Refreshing summary cache...")
  (maphash #'(lambda (k v)
	       (declare (ignore k))
	       (refresh-summary v :force force))
	   (summary-cache-summaries sc))
  sc)

(defmethod pkg-map-recursive-deps ((pkg pkg) (fn function))
  "Recursively map over the dependencies of the given package. Each
   unique dependency is only mapped over o nce."
  (labels ((map-rec (p seen)
	     (setf (gethash (pkg-dir p) seen) t)
	     (funcall fn p)
	     (mapc #'(lambda (dep)
		       (when (not (gethash (pkg-dir dep) seen))
			 (map-rec dep seen)))
		   (pkg-deps p))))
    (let ((seen (make-hash-table :test 'equal)))
      (mapc #'(lambda (p)
		(map-rec p seen))
	    (pkg-deps pkg)))))

;; Return a flat list of all dependencies (recursively resolved)
;; of the given package. The list is NOT guaranteed to be in any
;; particular order.
(defmethod pkg-recursive-deps ((pkg pkg))
  (let ((lst nil))
    (pkg-map-recursive-deps pkg
			    #'(lambda (p)
				(setf lst (cons p lst))))
    lst))


(defmethod pkg-depends-on-p ((pkg pkg) (dep pkg))
  (find dep (pkg-recursive-deps pkg)))
(defmethod pkg-depends-on-p ((pkg pkg) (dep list))
  (mapc #'(lambda (p)
	    (if (pkg-depends-on-p pkg p)
		(return-from pkg-depends-on-p t)))
	dep)
  nil)

;; A package is outdated if the version in pkgsrc is newer than
;; installed version
(defmethod pkg-outdated-p ((pkg pkg))
  (and (pkg-installation pkg)
       (not (equal (pkg-name pkg) (installation-name (pkg-installation pkg))))))

(defmethod pkg-outdated-dependency-p ((pkg pkg))
  (let ((rec-deps (pkg-recursive-deps pkg)))
    (mapc #'(lambda (p)
	      (when (pkg-outdated-p p)
		(return-from pkg-outdated-dependency-p t)))
	  rec-deps)
    nil))

;; A package is 'dirty' if it depends on packages that have been installed
;; after the installation of the package in question (regardless of package
;; versions).
(defmethod pkg-dirty-p ((pkg pkg))
  (and (pkg-installation pkg)
       (let ((deps (pkg-recursive-deps pkg)))
	 (find-if #'(lambda (p)
		      (and (pkg-installation p)
			   (>= (installation-itime (pkg-installation p))
			       (installation-itime (pkg-installation pkg)))))
		  deps))))

(defmethod pkg-dirty-dependency-p ((pkg pkg))
  (let ((deps (pkg-deps pkg)))
    (mapc #'(lambda (p)
	      (when (pkg-dirty-p p)
		(return-from pkg-dirty-dependency-p t)))
	  deps)
    nil))

(defmethod pkg-missing-p ((pkg pkg))
  (not (pkg-installation pkg)))

(defmethod pkg-missing-dependency-p ((pkg pkg))
  (let ((deps (pkg-deps pkg)))
    (mapc #'(lambda (p)
	      (when (pkg-missing-p p)
		(return-from pkg-missing-dependency-p t)))
	  deps)
    nil))

(defmethod pkg-failed-dependency-p ((pkg pkg))
  (let ((rec-deps (pkg-recursive-deps pkg)))
    (mapc #'(lambda (p)
	      (when (pkg-failed p)
		(return-from pkg-failed-dependency-p t)))
	  rec-deps)
    nil))

;; Returns whether the package is 'ready' to be built. A package is ready to
;; be built if none of its dependencies are outdated,dirty or missing and the package
;; itself is either outdated, dirty or missing.
(defmethod pkg-ready-p ((pkg pkg))
  (and (or (pkg-missing-p pkg)
	   (pkg-outdated-p pkg)
	   (pkg-dirty-p pkg))
       (not (or (pkg-missing-dependency-p pkg)
		(pkg-outdated-dependency-p pkg)
		(pkg-dirty-dependency-p pkg)
		(pkg-failed pkg)
		(pkg-failed-dependency-p pkg)))))

(defmethod installation-orphaned-p ((i installation))
  (pkg-missing (installation-pkg i)))

(defmethod db-map-packages ((db db) (fn function))
  (maphash #'(lambda (k v)
	       (declare (ignore k))
	       (funcall fn v))
	   (db-pkgs db)))

(defmethod db-collect-packages ((db db) (predicate function))
  (let ((l ()))
    (maphash #'(lambda (k v)
		 (declare (ignore k))
		 (when (funcall predicate v)
		   (setf l (cons v l))))
	     (db-pkgs db))
    l))
(defmethod db-collect-installations ((db db) (predicate function))
  (let ((l ()))
    (maphash #'(lambda (name i)
		 (declare (ignore name))
		 (when (funcall predicate i)
		   (setf l (cons i l))))
	     (db-is db))
    l))

(defmethod db-next-ready-package ((db db))
  (let* ((ready-pkgs (db-collect-packages db #'(lambda (p) (pkg-ready-p p))))
	 (sorted-pkgs (sort ready-pkgs
			    #'(lambda (a b) (> (pkg-priority a) (pkg-priority b))))))
    (print-info "Ready list sorted by priority:  ~a"
		(mapcar #'(lambda (p) (format nil "~a (~a)" (pkg-dir p) (pkg-priority p))) sorted-pkgs))
    (if (not (null sorted-pkgs))
	(car sorted-pkgs)
	nil)))

;; Returns the "absolute" (still relative to pkgsrc) path that is
;; the result of applying the given relative path to the given base
;; path. It will break if given paths with trailing slashes for
;; example.
(defun path-merge (base rel)
  (labels ((merge-rec (b r)
	     (if (null r)
		 b
		 (if (equal (car r) "..")
		     (merge-rec (cdr b) (cdr r))
		     (if (equal (car r) ".")
			 (merge-rec b (cdr r))
			 (merge-rec (cons (car r) b) (cdr r))))))
	   (assemble (lst)
	     (format nil "~{~a~#[~:;/~]~}" lst)))
    (let* ((base-parts (split-regexp base "/"))
	   (rel-parts (split-regexp rel "/")))
      (assemble (nreverse (merge-rec (nreverse base-parts) rel-parts))))))

(defun pkg-delete (name)
  (print-notice "Removing package ~a" name)
  (shell-run (format nil "~a -f ~a" (env-pkg-delete) name)))
(defun pkg-upgrade (name)
  (print-notice "Upgrading package ~a" name)
  ;; During pre-clean we clean recursively just in case - there is a potential for screw-ups otherwise.
  ;; During post-clean which is not as important, we only clean the top-level package because it is much faster.
  (shell-run (format nil "cd /usr/pkgsrc/~a && ~a CLEANDEPENDS=1 clean && ~a replace && ~a clean"
		     name
		     (env-make)
		     (env-make)
		     (env-make))))
(defun pkg-install (name)
  (print-notice "Installing package ~a" name)
  (shell-run (format nil "cd /usr/pkgsrc/~a && ~a CLEANDEPENDS=1 clean && ~a install && ~a clean"
		     name
		     (env-make)
		     (env-make)
		     (env-make))))
(defun make-fetch (name)
  (print-notice "Fetching for ~a" name)
  (shell-run (format nil "cd /usr/pkgsrc/~a && ~a clean && ~a fetch"
		     name
		     (env-make)
		     (env-make))))

(defun pkg-stat-itime (name)
  ;; stat +SIZE_PKG because we dont believe it will
  ;; change other than upon package installation. the directory
  ;; is not usable though because +REQUIRED_BY is changed by
  ;; the installation of other packages. we used to stat
  ;; +BUILD_VERSION, but that blow up when pkgtools/digest got installed
  ;; weirdly by the bootstrap and did not create the file.
  (stat-mtime (format nil "~a~a/+SIZE_PKG" (env-dbdir) name)))

(defmethod package-exists-p ((dir string))
  (probe-file (format nil "/usr/pkgsrc/~a/Makefile" dir)))

;; If needed, create and examine new package. In either case,
;; return the package
(defmethod db-register-package ((db db) (dir string))
  (let ((pkg (gethash dir (db-pkgs db))))
    (when (not pkg)
      (setf pkg (make-instance 'pkg :dir dir))
      (setf (gethash dir (db-pkgs db)) pkg)
      (db-pkg-examine-origin db pkg))
    pkg))

(defmethod db-register-dependency ((db db) (p pkg) (dep string))
  (print-info "Registering dependency on ~a from ~a" dep (pkg-dir p))
  (let ((deppkg (gethash dep (db-pkgs db))))
    (when (not deppkg)
      (progn
	(print-notice "~a depends on non-installed package ~a (new dependency?)" (pkg-dir p) dep)
	(setf deppkg (make-instance 'pkg :dir dep))
	(setf (gethash dep (db-pkgs db)) deppkg)
	(db-pkg-examine-origin db deppkg)))
    (setf (pkg-deps p) (cons deppkg (pkg-deps p)))))

(defmethod db-pkg-examine-origin ((db db) (p pkg))
  (if (db-valid-origin-p db (pkg-dir p))
      (let ((s (summary-cache-summary (db-summary-cache db) (pkg-dir p))))
	(setf (pkg-name p) (summary-name s))
	(mapcar #'(lambda (dep)
		    (db-register-dependency db p dep))
		(summary-deps s)))
      (progn
	(print-warn "WARNING: package ~a is missing from pkgsrc" (pkg-dir p))
	(setf (pkg-missing p) t))))

;; Register an installation of the given name from the given origin with the given
;; database. If examine-new is true, newly discovered packages will be examined for
;; summary information using db-pkg-examine-origin.
(defmethod db-register-installation ((db db) name origin &key (examine-new nil))
  (let* ((existing-pkg (gethash origin (db-pkgs db)))
	 (p (if existing-pkg
		existing-pkg
	      (let ((new-pkg (make-instance 'pkg :dir origin)))
		(when examine-new
		  (db-pkg-examine-origin db new-pkg))
		new-pkg)))
	 (itime (pkg-stat-itime name))
	 (i (make-instance 'installation :name name :pkg p :itime itime)))
    (print-debug "Registering installation ~a with origin ~a" name origin)
    (setf (pkg-installation p) i)
    (setf (gethash (installation-name i) (db-is db)) i)
    (setf (gethash (pkg-dir p) (db-pkgs db)) p)))

;; Uses pkg_info -a -B to obtain a list of all installed packages and their
;; directory of origin in pkgsrc
(defmethod db-scan-installations ((db db) &key (examine-new nil))
  (print-notice "Examining installed packages...")
  (let ((pkginfo (slurp-input (env-pkg-info) "-a" "-B")))
    (with-input-from-string (s pkginfo)
      (let ((is (db-is db))
	    (name nil)
	    (pkgname-scanner (create-scanner "^Information for ([^:]+):$"))
	    (pkgpath-scanner (create-scanner "^PKGPATH=(.+)$"))
	    (digest-scanner (create-scanner "^digest-\\d+$")))
	(loop as line = (chomp (read-line s nil nil))
	      while line
	      do (when (not (string= line "")) ; work around a bug triggered by clisp+cl-ppcre combo
		   (progn
		     (multiple-value-bind (nm nmatches) (scan-to-strings pkgname-scanner line)
		       (if nm
			   (progn
			     (setf name (elt nmatches 0))
			     ;; On at least one FreeBSD machine, the pkgsrc bootstrap installed pkgtools/digest
			     ;; in such a way that pkg_info -a -B does not list any of its information. Handle this
			     ;; presumably special case here.
			     (when (scan-to-strings digest-scanner name)
			       (print-notice "digest package installed without necessary meta-data, forcing pkgtools/digest origin")
			       (db-register-installation db name "pkgtools/digest" :examine-new examine-new)))
			   (multiple-value-bind (pm pmatches) (scan-to-strings pkgpath-scanner line)
			     (when pm (progn
					(when (not name) (die "CRITICAL: Found PKGPATH but no preceedingpackage name"))
					(db-register-installation db name (elt pmatches 0) :examine-new examine-new)
					(setf name nil)))))))))
	(print-notice "~a packages installed" (hash-table-count is))
	(print-notice "~a installations have missing origins (are orphans)" (length (db-collect-installations db #'installation-orphaned-p)))
	db))))

(defmethod db-examine-origins ((db db))
  (print-notice "Examining origins...")
  ;; Note that package examination may modify the pkg hashtable, so:
  (let ((pkgs (list)))
    (maphash #'(lambda (dir pkg)
		 (declare (ignore dir))
		 (setf pkgs (cons pkg pkgs))) (db-pkgs db))
    (mapc #'(lambda (pkg)
	      (db-pkg-examine-origin db pkg)
	      (print-debug "~a depends on ~a" (pkg-dir pkg) (pkg-deps pkg)))
	  pkgs)))

(defmethod db-fetch-pkg ((db db) (pkg pkg))
  (make-fetch (pkg-dir pkg)))

(defmethod db-upgrade-pkg ((db db) (pkg pkg))
  (handler-case (if (pkg-missing-p pkg)
		    (progn
		      (print-notice "Installation of ~a pending: ~a"
				    (pkg-dir pkg)
				    (pkg-name pkg))
		      (pkg-install (pkg-dir pkg)))
		    (progn
		      (print-notice "Upgrade of ~a pending: ~a -> ~a"
				    (pkg-dir pkg)
				    (installation-name (pkg-installation pkg))
				    (pkg-name pkg))
		      (pkg-upgrade (pkg-dir pkg))))
    (command-failed-error (e) (progn
				(print-warn "Package ~a failed to upgrade/install (~a) - marking as FAILED"
					    (pkg-dir pkg)
					    (extended-condition-message e))
				(setf (pkg-failed pkg) t)))))

(defmethod db-remove-orphans ((db db))
  (let ((orphans (db-collect-installations db #'installation-orphaned-p)))
    (mapc #'(lambda (i)
	      (pkg-delete (installation-name i))
	      (remhash (installation-name i) (db-is db))
	      (remhash (pkg-dir (installation-pkg i)) (db-pkgs db)))
	  orphans)))

(defmethod db-remove-unneeded ((db db))
  (let ((pkgs (db-collect-packages db (bnot #'pkg-needed))))
    (mapc #'(lambda (p)
	      (let ((i (pkg-installation p)))
		(when i
		  (pkg-delete (installation-name i))
		  (remhash (installation-name i) (db-is db)))
		(remhash (pkg-dir p) (db-pkgs db))))
	  pkgs)))

(defmethod db-check-sanity ((db db))
  (labels ((check-circ-dep (dir pkg)
	     (declare (ignore dir))
	     (check-circ-dep-rec pkg nil nil))
	   (check-circ-dep-rec (pkg seen checked)
	     (if (find (pkg-dir pkg) checked :test 'equal)
		 checked
		 (progn
		   (setf checked (cons (pkg-dir pkg) checked))
		   (when (member (pkg-dir pkg) seen :test 'equal)
		     (error 'circular-dependency-error :message (format nil "Package: ~a, Dep list: ~a" (pkg-dir pkg) seen)))
		   (let ((new-seen (cons (pkg-dir pkg) seen)))
		     (mapc #'(lambda (p)
			       (setf checked (check-circ-dep-rec p new-seen checked)))
			   (pkg-deps pkg)))
		   checked))))
    (print-notice "Checking for circular dependencies...")
    (maphash #'check-circ-dep (db-pkgs db))))

(defmethod db-process-wants ((db db) (wants list))
  "Process the given wantlist, recursively registering needed packages. Also applies
relative priorities according to each individual want. wants must be a list of want
instances."
  (print-notice "Calculating needed packages based on wanted list...")
  (labels ((recursively-mark-needed (pkg prio)
	     (setf (pkg-needed pkg) t)
	     (setf (pkg-priority pkg) (max (pkg-priority pkg) prio))
	     (pkg-map-recursive-deps pkg
				     #'(lambda (dep)
					 (setf (pkg-needed dep) t)
					 (setf (pkg-priority dep) (max (pkg-priority dep) prio))))))
    (mapc #'(lambda (want)
	      (when (not (package-exists-p (car want)))
		(error 'want-item-does-not-exit-error :message (format nil "The package '~a' is on the want list but does not exist in pkgsrc. pkgmanager cannot function properly when the want list is incorrect. Please correct the issue." (car want))))
	      (let ((pkg (db-register-package db (car want))))
		(recursively-mark-needed pkg (cdr want))))
	  wants)))

(defmethod upgrade-configuration-3 ((db db))
  "Upgrades pkgdb confir from revision 2 to 3. This bump entails ensuring
core wants are registered with appropriate priorities."
  (print-notice "   ... ensuring core wants are properly prioritized")
  (let ((core-wants (mapcar #'(lambda (w) (parse-want w)) *core-wants*)))
    (setf (getf (db-conf db) :wants)
	  (mapcar #'(lambda (w)
		      (let ((match (find (car w) core-wants :key #'car :test 'equal)))
			(if match
			    (progn
			      (print-notice "Setting ~a priority to ~a" (car match) (cdr match))
			      match)
			    w)))
		(getf (db-conf db) :wants)))))

(defmethod upgrade-configuration-2 ((db db))
  "Upgrades pkgdb config from revision 1 to 2. This bump entails converting
the want list from a list of strings to a list of cons pairs containing whose
car is the package directory and whose cdr is the priority (defaulting to 1.0)."
  (print-notice "   ... converting to priorities want list")
  (let ((wants (getf (db-conf db) :wants)))
    (setf (getf (db-conf db) :wants)
	  (mapcar #'(lambda (w) 
		      (if (not (consp w))
			  (cons w *default-want-priority*)
			  w))
		  wants))))

(defmethod upgrade-configuration-1 ((db db))
  "Upgrades pkgdb configuration from revision nil (effectively 0) to :1.
   For this revision bump, we ensure the core wants are on the want list."
  (print-notice "   ... ensuring core wants are on want list")
  (mapc #'(lambda (w) (db-register-want db w)) *core-wants*))

(defmethod upgrade-configuration ((db db) frev trev)
  "Upgrade configuration from revision frev to revision trev. Revisions
   are named 0, 1, 2, and so on."
  (when (> trev frev)
    (loop for rev from (+ frev 1) to trev
	  do (progn (print-notice "Upgrading configuration from revision ~a to revision ~a..."
				  (- rev 1)
				  rev)
		    (funcall (symbol-function (getf *pkgdb-config-upgraders* rev)) db)
		    (setf (getf (db-conf db) :config-revision) rev)
		    (write-configuration db)))))

(defmethod read-configuration ((db db))
  (when (probe-file (format nil "~a.tmp" (db-confpath db)))
    (if (probe-file (db-confpath db))
	(shell-run (format nil "rm -f ~a.tmp" (db-confpath db)))
	(shell-run (format nil "mv -f ~a.tmp ~a" (db-confpath db) (db-confpath db)))))
  (let ((conf (if (probe-file (db-confpath db))
		  (with-open-file (f (db-confpath db))
		    (read f))
		  (list))))
    (setf (db-conf db) conf)
    (setf (db-summary-cache db) (make-instance 'summary-cache))
    (depersist-summary-cache (db-summary-cache db) (getf conf :summary-cache))
    (if (not (db-conf db))
	(upgrade-configuration db 0 *pkgdb-config-revision*)
	(let ((oldrev (or (getf (db-conf db) :config-revision)
			  0)))
	  (if (> oldrev *pkgdb-config-revision*)
	      (when (not (confirm (format nil "The configuration format revision on disk is ~a, while this version of pkgmanager supports up to ~a. If you continue, things might break (or they might not). Are you sure you want to continue?" oldrev *pkgdb-config-revision*) nil))
		(error 'unsupported-config-error :message (format nil "Configuration format ~a not supported - use a newer version of pkgmanager" oldrev)))
	      (upgrade-configuration db oldrev *pkgdb-config-revision*))))
    db))
  

(defmethod write-configuration ((db db))
  (setf (getf (db-conf db) :summary-cache)
	(persist-summary-cache (db-summary-cache db)))
  (let ((temp-file (format nil "~a.tmp" (db-confpath db)))
	(real-file (db-confpath db)))
    (with-open-file (f temp-file :direction :output :if-exists :supersede)
      (print (db-conf db) f))
    (shell-run (format nil "mv -f ~a ~a" temp-file real-file))))

(defmethod db-wanted-packages ((db db))
  (getf (db-conf db) :wants))

(defmethod db-init ((db db) &key (check-mk-conf t))
  "Initializes database. db-prepare must further be called
   prior to package manipulation."
  (read-configuration db)
  (let ((stored-mk-conf (getf (db-conf db) :mk-conf))
	(actual-mk-conf (format nil
				"~a~a"
				(slurp-file "/etc/mk.conf")
				(slurp-file (format nil "~a/etc/mk.conf" (env-prefix))))))
    (when (and check-mk-conf
	       stored-mk-conf
	       (not (equal stored-mk-conf actual-mk-conf)))
      (when (confirm (format nil "/etc/mk.conf and/or ~a/etc/mk.conf has changed since last time pkgmanager was run. If your changes has caused a change in package dependencies, pkgmanager will not know about it unless you invalidate the summary cache. Doing so will mean that pkgmanager will have to refresh the summary information for all installed package, which will take some time. Invalidate summary cache?" (env-prefix)))
	(db-invalidate-summary-cache db)))
    (when (or (not stored-mk-conf)
	      (not (equal stored-mk-conf actual-mk-conf)))
      (setf (getf (db-conf db) :mk-conf) actual-mk-conf)
      (write-configuration db)))
  db)
	

(defmethod db-prepare ((db db))
  "Prepares database for packaging operations."
  (db-scan-installations db)
  (db-examine-origins db)
  (db-check-sanity db)
  (db-process-wants db (getf (db-conf db) :wants))
  (write-configuration db)
  db)

(define-condition number-format-error (db-error)
  ((number :initarg :number :accessor number-format-error-number :initform nil)))

(defun sane-parse-integer (str)
  "Wrap around parse-integer, signalling a USEFUL freaking condition if
parsing fails."
  (when (not str) (error 'number-format-error :message "String was nil"))
  (handler-case (parse-integer str)
    (error () (error 'number-format-error :number str :message (format nil "Invalid integer: ~a" str)))))
  

(defun parse-decimal (str)
  (if (find #\. str)
      (multiple-value-bind (m matches) (scan-to-strings "(\\d+)?\.(\\d+)?" str)
	(if m
	    (let ((leftstr (or (elt matches 0) "0"))
		  (rightstr (or (elt matches 1) "0")))
	      (let ((left (sane-parse-integer leftstr))
		    (right (sane-parse-integer rightstr)))
		(+ left (/ right (expt 10 (length rightstr))))))
	    (error 'number-format-error :number str :message (format nil "Internal parsing error: ~a" str))))
      (sane-parse-integer str)))


(defun parse-want (want-string)
  (multiple-value-bind (m matches) (scan-to-strings "([^,]+)(,(.*))?$" want-string)
    (if (not m)
	(error 'invalid-want-specification
	       :message (format nil "Want spec ~a invalid, expected pkg/path[,prio]" want-string))
	(handler-case (cons (elt matches 0)
			    (or (and (elt matches 2) (parse-decimal (elt matches 2)))
				*default-want-priority*))
	  (number-format-error (e) (error 'invalid-want-specification
					  :message (format nil "~a is not a valid number" (number-format-error-number e))))))))

(defmethod db-register-want ((db db) (want-string string))
  (let ((want (parse-want want-string)))
    (if (not (db-valid-origin-p db (car want)))
	(print-warn "Package ~a does not exist in pkgsrc - ignored" (car want))
	(let ((conf (db-conf db)))
	  (let ((item (find (car want) (getf conf :wants) :key #'(lambda (w) (car w)) :test 'equal)))
	  (if (not item)
	      (progn
		(setf (getf conf :wants) (cons want (getf conf :wants)))
		(setf (db-conf db) conf) ; required for first addition
		(write-configuration db))
	      (if (not (= (cdr want) (cdr item)))
		  (progn
		    (print-notice "Changing priority of package ~a from ~a to ~a" (car want) (cdr item) (cdr want))
		    (setf (cdr item) (cdr want))
		    (write-configuration db))
		  (print-notice "Package ~a is already on want list with priority ~a" (car want) (cdr want)))))))))

(defmethod db-deregister-want ((db db) (want-string string))
  (let ((want (parse-want want-string))
	(conf (db-conf db))
	(core-wants (mapcar #'parse-want *core-wants*)))
    (if (find (car want) (getf conf :wants) :key #'car :test 'equal)
	(when (or (not (find (car want) core-wants :key #'car :test 'equal))
		  (confirm (format nil
				   "Package ~a is needed for pkgmanager to operate; are you sure you wish to proceed?"
				   (car want)) nil))
	  (progn
	    (setf (getf conf :wants)
		  (remove (car want) (getf conf :wants) :key #'(lambda (w) (car w)) :test 'equal))
	    (write-configuration db)))
	(print-notice "Package ~a is not wanted - ignoring" (car want)))))

(defmethod db-invalidate-summary-cache ((db db))
  (invalidate-summary-cache (db-summary-cache db))
  (write-configuration db))

(defmethod db-valid-origin-p ((db db) (path string))
  (port:probe-directory (format nil "/usr/pkgsrc/~a" path)))