X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=lisp%2Fpackage-ui.el;h=f8ed19a36877a28e5e802b52f46a603f66231b1b;hp=1c5bc1353a4dbf09914502c6241ab1a169ca6598;hb=414b512c0774e67ba8e160b605447d862d3be166;hpb=571a24e2bfea15d37c3503414674f59e89ec9652 diff --git a/lisp/package-ui.el b/lisp/package-ui.el index 1c5bc13..f8ed19a 100644 --- a/lisp/package-ui.el +++ b/lisp/package-ui.el @@ -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) @@ -311,8 +296,7 @@ and whether or not it is up-to-date." (cons pkg-sym pui-deleted-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,25 +318,23 @@ 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 @@ -362,8 +343,7 @@ and whether or not it is up-to-date." #'string<) :activate-callback nil :help-string "Packages selected for removal:\n" - :completion-string t - )) + :completion-string t)) (setq tmpbuf (get-buffer-create tmpbuf)) (display-buffer tmpbuf) (setq do-delete (yes-or-no-p "Remove these packages? ")) @@ -372,11 +352,12 @@ and whether or not it is up-to-date." (message "Deleting selected packages ...") (sit-for 0) (mapcar (lambda (pkg) (package-admin-delete-binary-package - pkg (package-admin-get-install-dir pkg nil))) - pui-deleted-packages) + 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 @@ -390,43 +371,36 @@ and whether or not it is up-to-date." (sort (mapcar #'symbol-name pui-selected-packages) #'string<) :activate-callback nil :help-string "Packages selected for installation:\n" - :completion-string t - )) + :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) - )) + (package-net-update-installed-db))) (defun pui-add-required-packages () "Select packages required by those already selected for installation." @@ -482,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. @@ -520,8 +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!")))))) + +(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" @@ -564,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) @@ -582,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) @@ -604,11 +607,11 @@ 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)) @@ -628,28 +631,22 @@ Warning: No download sites specified. Package index may be out of date. (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)) ) - ) + ((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" + (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 "\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" + current-vers desc))) + (insert (format "%s %-20s %-5s %s\n" (car disp) pkg-sym version desc))) (save-excursion @@ -666,8 +663,7 @@ Warning: No download sites specified. Package index may be out of date. (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) - )) + (set-extent-property extent 'keymap pui-package-keymap))) (sort (copy-sequence package-get-base) #'(lambda (a b) (string< (symbol-name (car a)) @@ -685,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)