X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fpackage-ui.el;h=f8ed19a36877a28e5e802b52f46a603f66231b1b;hb=89dd1955617972a104d64b0343cf81a54331656b;hp=7eb73bd3daab46f52e2e0c6fbb60fc0c3c32e640;hpb=cb9f6f4eadc44f1becb32cbbd1db26449e347755;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/package-ui.el b/lisp/package-ui.el index 7eb73bd..f8ed19a 100644 --- a/lisp/package-ui.el +++ b/lisp/package-ui.el @@ -31,7 +31,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgroup pui nil - "Conventient interface to the package system." + "Convenient interface to the package system." :group 'package-tools :tag "Package User interface" :prefix "pui-") @@ -80,11 +80,10 @@ Set this to `nil' to use the `default' face." :group 'pui :type 'face) - - - -(defvar pui-info-buffer "*Packages*" - "Buffer to use for displaying package information.") +(defcustom pui-info-buffer "*Packages*" + "*Buffer to use for displaying package information." + :group 'pui + :type 'string) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; End of user-changeable variables. @@ -105,6 +104,7 @@ Set this to `nil' to use the `default' face." (define-key m "q" 'pui-quit) (define-key m "g" 'pui-list-packages) (define-key m "i" 'pui-display-info) + (define-key m "m" 'pui-display-maintainer) (define-key m "?" 'describe-mode) (define-key m "v" 'pui-toggle-verbosity-redisplay) (define-key m "d" 'pui-toggle-package-delete-key) @@ -137,46 +137,11 @@ Set this to `nil' to use the `default' face." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Configuration routines -(defun pui-directory-exists (dir) - "Check to see if DIR exists in `package-get-remote'." - (let (found) - (mapcar '(lambda (item) - (if (and (null (car item)) - (string-equal (file-name-as-directory (car (cdr item))) - (file-name-as-directory dir))) - (setq found t)) - ) package-get-remote) - found - )) - -(defun pui-package-dir-list (buffer) - "In BUFFER, format the list of package binary paths." - (let ( (count 1) paths sys dir) - (set-buffer buffer) - (buffer-disable-undo buffer) - (erase-buffer buffer) - (insert "Existing package binary paths:\n\n") - (setq paths package-get-remote) - (while paths - (setq sys (car (car paths)) - dir (car (cdr (car paths)))) - (insert (format "%2s. " count)) - (if (null sys) - (insert dir) - (insert sys ":" dir)) - (insert "\n") - (setq count (1+ count)) - (setq paths (cdr paths)) - ) - (insert "\nThese are the places that will be searched for package binaries.\n") - (goto-char (point-min)) - )) - ;;;###autoload (defun package-ui-add-site (site) "Add site to package-get-remote and possibly offer to update package list." (let ((had-none (null package-get-remote))) - (push site package-get-remote) + (setq package-get-remote site) (when (and had-none package-get-was-current (y-or-n-p "Update Package list?")) (setq package-get-was-current nil) @@ -185,39 +150,64 @@ Set this to `nil' to use the `default' face." (save-window-excursion (pui-list-packages)))) (set-menubar-dirty-flag))) - ;;;###autoload -(defun pui-add-install-directory (dir) - "Add a new package binary directory to the head of `package-get-remote'. +(defun package-ui-download-menu () + "Build the `Add Download Site' menu." + (mapcar (lambda (site) + (vector (car site) + `(if (equal package-get-remote (quote ,(cdr site))) + (setq package-get-remote nil) + (package-ui-add-site (quote ,(cdr site)))) + ;; I've used radio buttons so that only a single + ;; site can be selected, but they are in fact + ;; toggles. SY. + :style 'radio + :selected `(equal package-get-remote (quote ,(cdr site))))) + package-get-download-sites)) + +;;;###autoload +(defun package-ui-pre-release-download-menu () + "Build the 'Pre-Release Download Sites' menu." + (mapcar (lambda (site) + (vector (car site) + `(if (equal package-get-remote (quote ,(cdr site))) + (setq package-get-remote nil) + (package-ui-add-site (quote ,(cdr site)))) + ;; I've used radio buttons so that only a single + ;; site can be selected, but they are in fact + ;; toggles. SY. + :style 'radio + :selected `(equal package-get-remote (quote ,(cdr site))))) + package-get-pre-release-download-sites)) + +;;;###autoload +(defun package-ui-site-release-download-menu () + "Build the 'Site Release Download Sites' menu." + (mapcar (lambda (site) + (vector (car site) + `(if (equal package-get-remote (quote ,(cdr site))) + (setq package-get-remote nil) + (package-ui-add-site (quote ,(cdr site)))) + ;; I've used radio buttons so that only a single + ;; site can be selected, but they are in fact + ;; toggles. SY. + :style 'radio + :selected `(equal package-get-remote (quote ,(cdr site))))) + package-get-site-release-download-sites)) + +;;;###autoload +(defun pui-set-local-package-get-directory () + "Set a new package binary directory in `package-get-remote'. Note that no provision is made for saving any changes made by this function. It exists mainly as a convenience for one-time package installations from disk." - (interactive (let ( (tmpbuf (get-buffer-create - "*Existing Package Binary Paths*")) - dir) - (save-window-excursion - (save-excursion - (unwind-protect - (progn - (pui-package-dir-list tmpbuf) - (display-buffer tmpbuf) - (setq dir (read-directory-name - "New package binary directory to add? " - nil nil t)) - ) - (kill-buffer tmpbuf) - ))) - (list dir) - )) - (progn - (if (not (pui-directory-exists dir)) - (progn - (setq package-get-remote (cons (list nil dir) package-get-remote)) - (message "Package directory \"%s\" added." dir) - ) - (message "Directory \"%s\" already exists in `package-get-remote'." dir)) - )) + (interactive) + (let ((dir (read-directory-name + "New package binary directory to add? " + nil nil t))) + (setq package-get-remote (list nil dir)) + (message "Package directory \"%s\" added." dir))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Package list/installer routines @@ -238,8 +228,7 @@ disk." version)) (list " " pui-up-to-date-package-face) (list "*" pui-outdated-package-face))) - (list "-" pui-uninstalled-package-face)) - )) + (list "-" pui-uninstalled-package-face)))) (defun pui-update-package-display (extent &optional pkg-sym version) "Update the package status for EXTENT. @@ -272,9 +261,7 @@ and whether or not it is up-to-date." (goto-char (extent-start-position extent)) (delete-char 1) (insert sym-char) - (set-buffer-modified-p nil) - ) - )) + (set-buffer-modified-p nil)))) (defun pui-toggle-package (extent) (let (pkg-sym) @@ -286,8 +273,7 @@ and whether or not it is up-to-date." (cons pkg-sym pui-selected-packages)) (setq pui-deleted-packages (delete pkg-sym pui-deleted-packages))) - (pui-update-package-display extent pkg-sym) - )) + (pui-update-package-display extent pkg-sym))) (defun pui-toggle-package-key () "Select/unselect package for installation, using the keyboard." @@ -296,10 +282,9 @@ and whether or not it is up-to-date." (if (setq extent (extent-at (point) (current-buffer) 'pui)) (progn (pui-toggle-package extent) - (forward-line 1) - ) - (error "No package under cursor!")) - )) + (forward-line 1)) + (error 'invalid-operation + "No package under cursor!")))) (defun pui-toggle-package-delete (extent) (let (pkg-sym) @@ -309,10 +294,9 @@ and whether or not it is up-to-date." (delete pkg-sym pui-deleted-packages)) (setq pui-deleted-packages (cons pkg-sym pui-deleted-packages)) - (setq pui-seleted-packages + (setq pui-selected-packages (delete pkg-sym pui-selected-packages))) - (pui-update-package-display extent pkg-sym) - )) + (pui-update-package-display extent pkg-sym))) (defun pui-toggle-package-delete-key () @@ -322,10 +306,9 @@ and whether or not it is up-to-date." (if (setq extent (extent-at (point) (current-buffer) 'pui)) (progn (pui-toggle-package-delete extent) - (forward-line 1) - ) - (error "No package under cursor!")) - )) + (forward-line 1)) + (error 'invalid-operation + "No package under cursor!")))) (defun pui-current-package () (let ((extent (extent-at (point) (current-buffer) 'pui))) @@ -335,56 +318,46 @@ and whether or not it is up-to-date." (defun pui-toggle-package-event (event) "Select/unselect package for installation, using the mouse." (interactive "e") - (let* ( (ep (event-point event)) - (buffer (window-buffer (event-window event))) - (extent (extent-at ep buffer 'pui-package)) - ) - (pui-toggle-package extent) - )) + (let* ((ep (event-point event)) + (buffer (window-buffer (event-window event))) + (extent (extent-at ep buffer 'pui-package))) + (pui-toggle-package extent))) (defun pui-toggle-verbosity-redisplay () "Toggle verbose package info." (interactive) (progn (setq pui-list-verbose (not pui-list-verbose)) - (pui-list-packages) - )) + (pui-list-packages))) (defun pui-install-selected-packages () "Install selected packages." (interactive) - (let ( (tmpbuf "*Packages-To-Remove*") do-delete) + (let ((tmpbuf "*Packages-To-Remove*") + do-delete) (when pui-deleted-packages (save-window-excursion (with-output-to-temp-buffer tmpbuf (display-completion-list (sort - (mapcar '(lambda (pkg) - (symbol-name pkg) - ) - pui-deleted-packages) - 'string<) - :activate-callback nil - :help-string "Packages selected for removal:\n" - :completion-string t - )) - (setq tmpbuf (get-buffer-create tmpbuf)) - (display-buffer tmpbuf) - (setq do-delete (yes-or-no-p "Remove these packages? ")) - (kill-buffer tmpbuf)) + (mapcar #'symbol-name pui-deleted-packages) + #'string<) + :activate-callback nil + :help-string "Packages selected for removal:\n" + :completion-string t)) + (setq tmpbuf (get-buffer-create tmpbuf)) + (display-buffer tmpbuf) + (setq do-delete (yes-or-no-p "Remove these packages? ")) + (kill-buffer tmpbuf)) (when do-delete (message "Deleting selected packages ...") (sit-for 0) - (when (catch 'done - (mapcar (lambda (pkg) - (if (not - (package-admin-delete-binary-package - pkg (package-admin-get-install-dir pkg nil))) - (throw 'done nil))) - pui-deleted-packages) - t) - (message "Packages deleted") - )))) + (mapcar (lambda (pkg) + (package-admin-delete-binary-package + pkg (package-admin-get-install-dir pkg))) + (nreverse pui-deleted-packages)) + (message "Packages deleted")))) - (let ( (tmpbuf "*Packages-To-Install*") do-install) + (let ((tmpbuf "*Packages-To-Install*") + do-install) (if pui-selected-packages (progn ;; Don't change window config when asking the user if he really @@ -394,49 +367,40 @@ and whether or not it is up-to-date." ;; errors occur, which would normally be caused by display-buffer). (save-window-excursion (with-output-to-temp-buffer tmpbuf - (display-completion-list (sort - (mapcar '(lambda (pkg) - (symbol-name pkg) - ) - pui-selected-packages) - 'string<) - :activate-callback nil - :help-string "Packages selected for installation:\n" - :completion-string t - )) + (display-completion-list + (sort (mapcar #'symbol-name pui-selected-packages) #'string<) + :activate-callback nil + :help-string "Packages selected for installation:\n" + :completion-string t)) (setq tmpbuf (get-buffer-create tmpbuf)) (display-buffer tmpbuf) (setq do-install (y-or-n-p "Install these packages? ")) - (kill-buffer tmpbuf) - ) + (kill-buffer tmpbuf)) (if do-install (progn (save-excursion ;; Clear old temp buffer history (set-buffer (get-buffer-create package-admin-temp-buffer)) (buffer-disable-undo package-admin-temp-buffer) - (erase-buffer package-admin-temp-buffer) - ) + (erase-buffer package-admin-temp-buffer)) (message "Installing selected packages ...") (sit-for 0) (if (catch 'done (mapcar (lambda (pkg) (if (not (package-get pkg nil nil pui-package-install-dest-dir)) (throw 'done nil))) - pui-selected-packages) + (nreverse pui-selected-packages)) t) (progn (pui-list-packages) - (message "Packages installed") - )) - ) - (clear-message) - ) - ) + (message "Packages installed")))) + (clear-message))) (if pui-deleted-packages (pui-list-packages) - (error "No packages have been selected!"))) - )) + (error 'invalid-operation + "No packages have been selected!"))) + ;; sync with windows type systems + (package-net-update-installed-db))) (defun pui-add-required-packages () "Select packages required by those already selected for installation." @@ -454,12 +418,13 @@ and whether or not it is up-to-date." (package-get-info-find-package package-get-base pkg) nil) 'version))) - (if (< (if (stringp installed) + (if (or (null installed) + (< (if (stringp installed) (string-to-number installed) installed) (if (stringp current) (string-to-number current) - current)) + current))) pkg nil))) (package-get-dependencies pui-selected-packages))))) @@ -491,32 +456,41 @@ and whether or not it is up-to-date." nil nil nil nil nil 'pui) (message "added dependencies")) (clear-message))) - (error "No packages have been selected!")))) + (error 'invalid-operation + "No packages have been selected!")))) (defun pui-help-echo (extent &optional force-update) "Display additional package info in the modeline. EXTENT determines the package to display (the package information is attached to the extent as properties)." - (let (pkg-sym info inst-ver auth-ver date maintainer) + (let (pkg-sym info inst-ver inst-auth-ver auth-ver date maintainer balloon req) (if (or force-update (not (current-message)) - (string-match ".*: .*: " (current-message)) - ) + (string-match ".*: .*: " (current-message))) (progn (setq pkg-sym (extent-property extent 'pui-package) info (extent-property extent 'pui-info) inst-ver (package-get-key pkg-sym :version) + inst-auth-ver (package-get-key pkg-sym :author-version) auth-ver (package-get-info-prop info 'author-version) date (package-get-info-prop info 'date) - maintainer (package-get-info-prop info 'maintainer)) + maintainer (package-get-info-prop info 'maintainer) + req (package-get-info-prop info 'requires)) (if (not inst-ver) - (setq inst-ver "")) - (if pui-list-verbose - (format "Author version: %-8s %11s: %s" - auth-ver date maintainer) - (format "%-6s: %-8s %11s: %s" - inst-ver auth-ver date maintainer)) - )) - )) + (setq inst-ver 0)) + (if (featurep 'balloon-help) + (progn + (setq balloon (format " +Package Information: [For package: \"%s\"]\n================ +Installed Upstream Ver: %s Available Upstream Ver: %s +Maintainer : %s +Released : %s +Required Packages : %s\n\n" + pkg-sym inst-auth-ver auth-ver maintainer + date req)) + (set-extent-property extent 'balloon-help balloon))) + (format + "Installed upstream ver: %s Available upstream ver: %s" + inst-auth-ver auth-ver))))) (defun pui-display-info (&optional no-error event) "Display additional package info in the modeline. @@ -529,19 +503,26 @@ Designed to be called interactively (from a keypress)." (message (pui-help-echo extent t)) (if no-error (clear-message nil) - (error "No package under cursor!"))) - ))) + (error 'invalid-operation + "No package under cursor!")))))) -;;; "Why is there no standard function to do this?" -(defun pui-popup-context-sensitive (event) - (interactive "e") - (save-excursion - (set-buffer (event-buffer event)) - (goto-char (event-point event)) - (popup-menu pui-menu event) - ;; I agreee with dired.el this is seriously bogus. - (while (popup-menu-up-p) - (dispatch-event (next-event))))) +(defun pui-display-maintainer (&optional no-error event) + "Display a package's maintainer in the minibuffer." + (interactive) + (let (extent ;pkg-sym + info maintainer) + (save-excursion + (beginning-of-line) + (if (setq extent (extent-at (point) (current-buffer) 'pui)) + (progn + (setq ;pkg-sym (extent-property extent 'pui-package) + info (extent-property extent 'pui-info) + maintainer (package-get-info-prop info 'maintainer)) + (message (format "Maintainer: %s" maintainer))) + (if no-error + (clear-message nil) + (error 'invalid-operation + "No package under cursor!")))))) (defvar pui-menu '("Packages" @@ -558,6 +539,16 @@ Designed to be called interactively (from a keypress)." ["Help" pui-help t] ["Quit" pui-quit t])) +;;; "Why is there no standard function to do this?" +(defun pui-popup-context-sensitive (event) + (interactive "e") + (save-excursion + (set-buffer (event-buffer event)) + (goto-char (event-point event)) + (popup-menu pui-menu event) + ;; I agree with dired.el - this is seriously bogus. + (while (popup-up-p) + (dispatch-event (next-event))))) (defun list-packages-mode () "Symbols in the leftmost column: @@ -574,12 +565,14 @@ Useful keys: `\\[pui-toggle-package-delete-key]' to select/unselect the current package for removal. `\\[pui-add-required-packages]' to add any packages required by those selected. `\\[pui-install-selected-packages]' to install/delete selected packages. - `\\[pui-display-info]' to display additional information about the package in the modeline. + `\\[pui-display-info]' to display additional information about the package in the minibuffer. + `\\[pui-display-maintainer]' to display the package's maintainer in the minibuffer `\\[pui-list-packages]' to refresh the package list. `\\[pui-toggle-verbosity-redisplay]' to toggle between a verbose and non-verbose display. `\\[pui-quit]' to kill this buffer. " - (error "You cannot enter this mode directly. Use `pui-list-packages'")) + (error 'invalid-operation + "You cannot enter this mode directly. Use `pui-list-packages'")) (put 'list-packages-mode 'mode-class 'special) @@ -592,9 +585,9 @@ which are out-of-date (a newer version is available). The user can then select packages for installation via the keyboard or mouse." (interactive) (package-get-require-base t) - (let ( (outbuf (get-buffer-create pui-info-buffer)) - (sep-string "===============================================================================\n") - start ) + (let ((outbuf (get-buffer-create pui-info-buffer)) + (sep-string "===============================================================================\n") + start) (message "Creating package list ...") (sit-for 0) (set-buffer outbuf) (setq buffer-read-only nil) @@ -614,75 +607,67 @@ Warning: No download sites specified. Package index may be out of date. ")) (if pui-list-verbose - (insert " Latest Installed - Package name Vers. Vers. Description + (insert " Latest Installed + Package name Vers. Vers. Description ") - (insert " Latest - Package name Vers. Description + (insert " Latest + Package name Vers. Description ")) (insert sep-string) (setq start (point)) - (mapcar '(lambda (pkg) - (let (pkg-sym info version desc - b e extent current-vers disp) - (setq pkg-sym (car pkg) - info (package-get-info-version (cdr pkg) nil)) - (setq version (package-get-info-prop info 'version) - desc (package-get-info-prop info 'description)) - - (setq disp (pui-package-symbol-char pkg-sym - version)) - (setq b (point)) - (if pui-list-verbose - (progn - (setq current-vers (package-get-key pkg-sym :version)) - (cond - ( (not current-vers) - (setq current-vers "-----") ) - ( (stringp current-vers) - (setq current-vers - (format "%.2f" - (string-to-number current-vers))) ) - ( (numberp current-vers) - (setq current-vers (format "%.2f" current-vers)) ) - ) - (insert - (format "%s %-15s %-5.2f %-5s %s\n" - (car disp) pkg-sym - (if (stringp version) - (string-to-number version) - version) - current-vers desc)) -;; (insert -;; (format "\t\t %-12s %s\n" -;; (package-get-info-prop info 'author-version) -;; (package-get-info-prop info 'date) -;; )) - ) - (insert (format "%s %-15s %-5s %s\n" - (car disp) - pkg-sym version desc))) - (save-excursion - (setq e (progn - (forward-line -1) - (end-of-line) - (point))) - ) - (setq extent (make-extent b e)) - (if (car (cdr disp)) - (set-extent-face extent (get-face (car (cdr disp)))) - (set-extent-face extent (get-face 'default))) - (set-extent-property extent 'highlight t) - (set-extent-property extent 'pui t) - (set-extent-property extent 'pui-package pkg-sym) - (set-extent-property extent 'pui-info info) - (set-extent-property extent 'help-echo 'pui-help-echo) - (set-extent-property extent 'keymap pui-package-keymap) - )) (sort (copy-sequence package-get-base) - '(lambda (a b) - (string< (symbol-name (car a)) - (symbol-name (car b))) - ))) + (mapcar + #'(lambda (pkg) + (let (pkg-sym info version desc + b e extent current-vers disp) + (setq pkg-sym (car pkg) + info (package-get-info-version (cdr pkg) nil)) + (setq version (package-get-info-prop info 'version) + desc (package-get-info-prop info 'description)) + + (setq disp (pui-package-symbol-char pkg-sym + version)) + (setq b (point)) + (if pui-list-verbose + (progn + (setq current-vers (package-get-key pkg-sym :version)) + (cond + ((not current-vers) + (setq current-vers "-----")) + ((stringp current-vers) + (setq current-vers + (format "%.2f" + (string-to-number current-vers)))) + ((numberp current-vers) + (setq current-vers (format "%.2f" current-vers)))) + (insert + (format "%s %-20s %-5.2f %-5s %s\n" + (car disp) pkg-sym + (if (stringp version) + (string-to-number version) + version) + current-vers desc))) + (insert (format "%s %-20s %-5s %s\n" + (car disp) + pkg-sym version desc))) + (save-excursion + (setq e (progn + (forward-line -1) + (end-of-line) + (point)))) + (setq extent (make-extent b e)) + (if (car (cdr disp)) + (set-extent-face extent (get-face (car (cdr disp)))) + (set-extent-face extent (get-face 'default))) + (set-extent-property extent 'highlight t) + (set-extent-property extent 'pui t) + (set-extent-property extent 'pui-package pkg-sym) + (set-extent-property extent 'pui-info info) + (set-extent-property extent 'help-echo 'pui-help-echo) + (set-extent-property extent 'keymap pui-package-keymap))) + (sort (copy-sequence package-get-base) + #'(lambda (a b) + (string< (symbol-name (car a)) + (symbol-name (car b)))))) (insert sep-string) (insert (documentation 'list-packages-mode)) (set-buffer-modified-p nil) @@ -696,9 +681,7 @@ Warning: No download sites specified. Package index may be out of date. (set-buffer-menubar current-menubar) (add-submenu '() pui-menu) (setq mode-popup-menu pui-menu)) - (clear-message) -; (message (substitute-command-keys "Press `\\[pui-help]' for help.")) - )) + (clear-message))) ;;;###autoload (defalias 'list-packages 'pui-list-packages)