-(defun package-print-package (package version key desc)
- (let ((face
- (cond ((string= key "built-in") 'font-lock-builtin-face)
- ((string= key "available") 'default)
- ((string= key "held") 'font-lock-constant-face)
- ((string= key "disabled") 'font-lock-warning-face)
- ((string= key "installed") 'font-lock-comment-face)
- (t ; obsolete, but also the default.
- 'font-lock-warning-face))))
- (insert (propertize " " 'font-lock-face face))
- (insert-text-button (symbol-name package)
- 'face 'link
- 'follow-link t
- 'package-symbol package
- 'action (lambda (button)
- (describe-package
- (button-get button 'package-symbol))))
- (indent-to 20 1)
- (insert (propertize (package-version-join version) 'font-lock-face face))
- (indent-to 32 1)
- (insert (propertize key 'font-lock-face face))
- ;; FIXME: this 'when' is bogus...
- (when desc
- (indent-to 43 1)
- (let ((opoint (point)))
- (insert (propertize desc 'font-lock-face face))
- (upcase-region opoint (min (point) (1+ opoint)))))
- (insert "\n")))
-
-(defun package-list-maybe-add (package version status description result)
- (unless (assoc (cons package version) result)
- (push (list (cons package version) status description) result))
- result)
-
-(defvar package-menu-package-list nil
- "List of packages to display in the Package Menu buffer.
-A value of nil means to display all packages.")
-
-(defvar package-menu-sort-key nil
- "Sort key for the current Package Menu buffer.")
-
-(defun package--generate-package-list ()
- "Populate the current Package Menu buffer."
- (let ((inhibit-read-only t)
- info-list name desc hold builtin)
- (erase-buffer)
- ;; List installed packages
- (dolist (elt package-alist)
- (setq name (car elt))
- (when (or (null package-menu-package-list)
- (memq name package-menu-package-list))
- (setq desc (cdr elt)
- hold (cadr (assq name package-load-list)))
- (setq info-list
- (package-list-maybe-add
- name (package-desc-vers desc)
- ;; FIXME: it turns out to be tricky to see if this
- ;; package is presently activated.
- (if (stringp hold) "held" "installed")
- (package-desc-doc desc)
- info-list))))
-
- ;; List built-in packages
- (dolist (elt package--builtins)
- (setq name (car elt))
- (when (and (not (eq name 'emacs)) ; Hide the `emacs' package.
- (or (null package-menu-package-list)
- (memq name package-menu-package-list)))
- (setq desc (cdr elt))
- (setq info-list
- (package-list-maybe-add
- name (package-desc-vers desc)
- "built-in"
- (package-desc-doc desc)
- info-list))))
-
- ;; List available and disabled packages
- (dolist (elt package-archive-contents)
- (setq name (car elt)
- desc (cdr elt)
- hold (assq name package-load-list))
- (when (or (null package-menu-package-list)
- (memq name package-menu-package-list))
- (setq info-list
- (package-list-maybe-add name
- (package-desc-vers desc)
- (if (and hold (null (cadr hold)))
- "disabled"
- "available")
- (package-desc-doc (cdr elt))
- info-list))))
- ;; List obsolete packages
- (mapc (lambda (elt)
- (mapc (lambda (inner-elt)
- (setq info-list
- (package-list-maybe-add (car elt)
- (package-desc-vers
- (cdr inner-elt))
- "obsolete"
- (package-desc-doc
- (cdr inner-elt))
- info-list)))
- (cdr elt)))
- package-obsolete-alist)
-
- (setq info-list
- (sort info-list
- (cond ((string= package-menu-sort-key "Package")
- 'package-menu--name-predicate)
- ((string= package-menu-sort-key "Version")
- 'package-menu--version-predicate)
- ((string= package-menu-sort-key "Description")
- 'package-menu--description-predicate)
- (t ; By default, sort by package status
- 'package-menu--status-predicate))))
-
- (dolist (elt info-list)
- (package-print-package (car (car elt))
- (cdr (car elt))
- (car (cdr elt))
- (car (cdr (cdr elt)))))
- (goto-char (point-min))
- (set-buffer-modified-p nil)
- (current-buffer)))
-
-(defun package-menu--version-predicate (left right)
- (let ((vleft (or (cdr (car left)) '(0)))
- (vright (or (cdr (car right)) '(0))))
- (if (version-list-= vleft vright)
- (package-menu--name-predicate left right)
- (version-list-< vleft vright))))
-
-(defun package-menu--status-predicate (left right)
- (let ((sleft (cadr left))
- (sright (cadr right)))
- (cond ((string= sleft sright)
- (package-menu--name-predicate left right))
- ((string= sleft "available") t)
- ((string= sright "available") nil)
- ((string= sleft "installed") t)
- ((string= sright "installed") nil)
- ((string= sleft "held") t)
- ((string= sright "held") nil)
- ((string= sleft "built-in") t)
- ((string= sright "built-in") nil)
- ((string= sleft "obsolete") t)
- ((string= sright "obsolete") nil)
- (t (string< sleft sright)))))
-
-(defun package-menu--description-predicate (left right)
- (let ((sleft (car (cddr left)))
- (sright (car (cddr right))))
- (if (string= sleft sright)
- (package-menu--name-predicate left right)
- (string< sleft sright))))
-
-(defun package-menu--name-predicate (left right)
- (string< (symbol-name (caar left))
- (symbol-name (caar right))))
-
-(defun package-menu-sort-by-column (&optional e)
- "Sort the package menu by the column of the mouse click E."
- (interactive "e")
- (let* ((pos (event-start e))
- (obj (posn-object pos))
- (col (if obj
- (get-text-property (cdr obj) 'column-name (car obj))
- (get-text-property (posn-point pos) 'column-name)))
- (buf (window-buffer (posn-window (event-start e)))))
- (with-current-buffer buf
- (when (eq major-mode 'package-menu-mode)
- (setq package-menu-sort-key col)
- (package--generate-package-list)))))
-
-(defun package--list-packages (&optional packages)
- "Generate and pop to the *Packages* buffer.
-Optional PACKAGES is a list of names of packages (symbols) to
-list; the default is to display everything in `package-alist'."
- (require 'finder-inf nil t)
- (let ((buf (get-buffer-create "*Packages*")))
- (with-current-buffer buf
- (package-menu-mode)
- (set (make-local-variable 'package-menu-package-list) packages)
- (set (make-local-variable 'package-menu-sort-key) nil)
- (package--generate-package-list))
- ;; The package menu buffer has keybindings. If the user types
- ;; `M-x list-packages', that suggests it should become current.
- (switch-to-buffer buf)))
+(defun package-menu--version-predicate (A B)
+ (let ((vA (or (aref (cadr A) 1) '(0)))
+ (vB (or (aref (cadr B) 1) '(0))))
+ (if (version-list-= vA vB)
+ (package-menu--name-predicate A B)
+ (version-list-< vA vB))))
+
+(defun package-menu--status-predicate (A B)
+ (let ((sA (aref (cadr A) 2))
+ (sB (aref (cadr B) 2)))
+ (cond ((string= sA sB)
+ (package-menu--name-predicate A B))
+ ((string= sA "available") t)
+ ((string= sB "available") nil)
+ ((string= sA "installed") t)
+ ((string= sB "installed") nil)
+ ((string= sA "held") t)
+ ((string= sB "held") nil)
+ ((string= sA "built-in") t)
+ ((string= sB "built-in") nil)
+ ((string= sA "obsolete") t)
+ ((string= sB "obsolete") nil)
+ (t (string< sA sB)))))
+
+(defun package-menu--description-predicate (A B)
+ (let ((dA (aref (cadr A) 3))
+ (dB (aref (cadr B) 3)))
+ (if (string= dA dB)
+ (package-menu--name-predicate A B)
+ (string< dA dB))))
+
+(defun package-menu--name-predicate (A B)
+ (string< (symbol-name (caar A))
+ (symbol-name (caar B))))