git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/package-ui.el

   1 ;;; package-ui.el ---
   2
   3 ;; Copyright (C) 1998 by Darryl Okahata
   4
   5 ;; Author: Darryl Okahata <darrylo@sr.hp.com>
   6 ;; Keywords: internal
   7
   8 ;; This file is part of XEmacs.
   9
  10 ;; XEmacs is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; XEmacs is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23 ;; 02111-1307, USA.
  24
  25 ;;; Synched up with: Not in FSF
  26
  27 (require 'package-get)          ;; which, in turn, requires 'package-admin
  28
  29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30 ;; User-changeable variables:
  31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32
  33 (defgroup pui nil
  34   "Conventient interface to the package system."
  35   :group 'package-tools
  36   :tag "Package User interface"
  37   :prefix "pui-")
  38
  39 (defcustom pui-package-install-dest-dir nil
  40   "*If non-nil (Automatic) path to package tree to install packages in.
  41 Otherwise, use old path for installed packages and make a guess for
  42 new ones."
  43   :group 'pui
  44   :tag "Install Location"
  45   :type '(choice (const :tag "Automatic" nil)
  46                  (directory)))
  47
  48 (defcustom pui-list-verbose t
  49   "*If non-nil, display verbose info in the package list buffer."
  50   :group 'pui
  51   :tag "Verbose Listing"
  52   :type 'boolean)
  53
  54 (defcustom pui-up-to-date-package-face nil
  55   "*The face to use for packages that are up-to-date."
  56   :group 'pui
  57   :type 'face)
  58
  59 (defcustom pui-selected-package-face 'bold
  60   "*The face to use for selected packages.
  61 Set this to `nil' to use the `default' face."
  62   :group 'pui
  63   :type 'face)
  64
  65 (defcustom pui-outdated-package-face 'red
  66   "*The face to use for outdated packages.
  67 Set this to `nil' to use the `default' face."
  68   :group 'pui
  69   :type 'face)
  70
  71 (defcustom pui-uninstalled-package-face 'italic
  72   "*The face to use for uninstalled packages.
  73 Set this to `nil' to use the `default' face."
  74    :group 'pui
  75    :type 'face)
  76
  77
  78
  79
  80 (defvar pui-info-buffer "*Packages*"
  81   "Buffer to use for displaying package information.")
  82
  83 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84 ;; End of user-changeable variables.
  85 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86
  87 (defvar pui-selected-packages nil
  88   "The list of user-selected packages to install.")
  89
  90 (defvar pui-display-keymap
  91   (let ((m (make-keymap)))
  92     (suppress-keymap m)
  93     (set-keymap-name m 'pui-display-keymap)
  94     (define-key m "q" 'pui-quit)
  95     (define-key m "g" 'pui-list-packages)
  96     (define-key m " " 'pui-display-info)
  97     (define-key m "?" 'pui-help)
  98     (define-key m "v" 'pui-toggle-verbosity-redisplay)
  99     (define-key m "d" 'pui-toggle-verbosity-redisplay)
 100     (define-key m [return] 'pui-toggle-package-key)
 101     (define-key m "x" 'pui-install-selected-packages)
 102     (define-key m "I" 'pui-install-selected-packages)
 103     (define-key m "r" 'pui-add-required-packages)
 104     (define-key m "n" 'next-line)
 105     (define-key m "+" 'next-line)
 106     (define-key m "p" 'previous-line)
 107     (define-key m "-" 'previous-line)
 108     m)
 109   "Keymap to use in the `pui-info-buffer' buffer")
 110
 111 (defvar pui-package-keymap
 112   (let ((m (make-sparse-keymap)))
 113     (set-keymap-name m 'pui-package-keymap)
 114     (define-key m 'button2 'pui-toggle-package-event)
 115 ;; We use a popup menu
 116 ;;    (define-key m 'button3 'pui-toggle-package-event)
 117     m)
 118   "Keymap to use over package names/descriptions.")
 119
 120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 121 ;; End of variables
 122
 123
 124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 125 ;; Configuration routines
 126
 127 (defun pui-directory-exists (dir)
 128   "Check to see if DIR exists in `package-get-remote'."
 129   (let (found)
 130     (mapcar '(lambda (item)
 131                (if (and (null (car item))
 132                         (string-equal (file-name-as-directory (car (cdr item)))
 133                                       (file-name-as-directory dir)))
 134                    (setq found t))
 135                ) package-get-remote)
 136     found
 137     ))
 138
 139 (defun pui-package-dir-list (buffer)
 140   "In BUFFER, format the list of package binary paths."
 141   (let ( (count 1) paths sys dir)
 142     (set-buffer buffer)
 143     (buffer-disable-undo buffer)
 144     (erase-buffer buffer)
 145     (insert "Existing package binary paths:\n\n")
 146     (setq paths package-get-remote)
 147     (while paths
 148       (setq sys (car (car paths))
 149             dir (car (cdr (car paths))))
 150       (insert (format "%2s. " count))
 151       (if (null sys)
 152           (insert dir)
 153         (insert sys ":" dir))
 154       (insert "\n")
 155       (setq count (1+ count))
 156       (setq paths (cdr paths))
 157       )
 158     (insert "\nThese are the places that will be searched for package binaries.\n")
 159     (goto-char (point-min))
 160     ))
 161
 162 ;;;###autoload
 163 (defun pui-add-install-directory (dir)
 164   "Add a new package binary directory to the head of `package-get-remote'.
 165 Note that no provision is made for saving any changes made by this function.
 166 It exists mainly as a convenience for one-time package installations from
 167 disk."
 168   (interactive (let ( (tmpbuf (get-buffer-create
 169                                "*Existing Package Binary Paths*"))
 170                       dir)
 171                  (save-window-excursion
 172                    (save-excursion
 173                      (unwind-protect
 174                          (progn
 175                            (pui-package-dir-list tmpbuf)
 176                            (display-buffer tmpbuf)
 177                            (setq dir (read-directory-name
 178                                       "New package binary directory to add? "
 179                                       nil nil t))
 180                            )
 181                        (kill-buffer tmpbuf)
 182                        )))
 183                  (list dir)
 184                  ))
 185   (progn
 186     (if (not (pui-directory-exists dir))
 187         (progn
 188           (setq package-get-remote (cons (list nil dir) package-get-remote))
 189           (message "Package directory \"%s\" added." dir)
 190           )
 191       (message "Directory \"%s\" already exists in `package-get-remote'." dir))
 192     ))
 193
 194 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 195 ;; Package list/installer routines
 196
 197 (defun pui-quit ()
 198   (interactive)
 199   (kill-buffer nil))
 200
 201 (defun pui-help ()
 202   (interactive)
 203   (let ( (help-buffer (get-buffer-create "*Help*")) )
 204     (display-buffer help-buffer t)
 205     (save-window-excursion
 206       (set-buffer help-buffer)
 207       (buffer-disable-undo help-buffer)
 208       (erase-buffer help-buffer)
 209       (insert (pui-help-string))
 210       )
 211     ))
 212
 213 (defun pui-package-symbol-char (pkg-sym version)
 214   (progn
 215     (if (package-get-info-find-package packages-package-list pkg-sym)
 216         (if (package-get-installedp pkg-sym version)
 217             (list " " pui-up-to-date-package-face)
 218           (list "*" pui-outdated-package-face))
 219       (list "-" pui-uninstalled-package-face))
 220     ))
 221
 222 (defun pui-update-package-display (extent &optional pkg-sym version)
 223   "Update the package status for EXTENT.
 224 If PKG-SYM or VERSION are not given, they are read from the extent.
 225 These are used to determine whether or not the package is installed,
 226 and whether or not it is up-to-date."
 227   (let (buffer-read-only disp sym-char)
 228     (if (not pkg-sym)
 229         (setq pkg-sym (extent-property extent 'pui-package)))
 230     (if (not version)
 231         (setq version (package-get-info-prop (extent-property extent 'pui-info)
 232                                              'version)))
 233     (if (member pkg-sym pui-selected-packages)
 234         (progn
 235           (if pui-selected-package-face
 236               (set-extent-face extent (get-face pui-selected-package-face))
 237             (set-extent-face extent (get-face 'default)))
 238           (setq sym-char "+")
 239           )
 240       (progn
 241         (setq disp (pui-package-symbol-char pkg-sym version))
 242         (setq sym-char (car disp))
 243         (if (car (cdr disp))
 244             (set-extent-face extent (get-face (car (cdr disp))))
 245           (set-extent-face extent (get-face 'default)))
 246         ))
 247     (save-excursion
 248       (goto-char (extent-start-position extent))
 249       (delete-char 1)
 250       (insert sym-char)
 251       (set-buffer-modified-p nil)
 252       )
 253     ))
 254
 255 (defun pui-toggle-package (extent)
 256   (let (pkg-sym)
 257     (setq pkg-sym (extent-property extent 'pui-package))
 258     (if (member pkg-sym pui-selected-packages)
 259         (setq pui-selected-packages
 260               (delete pkg-sym pui-selected-packages))
 261       (setq pui-selected-packages
 262             (cons pkg-sym pui-selected-packages)))
 263     (pui-update-package-display extent pkg-sym)
 264     ))
 265
 266 (defun pui-toggle-package-key ()
 267   "Select/unselect package for installation, using the keyboard."
 268   (interactive)
 269   (let (extent)
 270     (if (setq extent (extent-at (point) (current-buffer) 'pui))
 271         (progn
 272           (pui-toggle-package extent)
 273           (forward-line 1)
 274           )
 275       (error "No package under cursor!"))
 276     ))
 277
 278 (defun pui-toggle-package-event (event)
 279   "Select/unselect package for installation, using the mouse."
 280   (interactive "e")
 281   (let* ( (ep (event-point event))
 282           (buffer (window-buffer (event-window event)))
 283           (extent (extent-at ep buffer 'pui-package))
 284           )
 285     (pui-toggle-package extent)
 286     ))
 287
 288 (defun pui-toggle-verbosity-redisplay ()
 289   "Toggle verbose package info."
 290   (interactive)
 291   (progn
 292     (setq pui-list-verbose (not pui-list-verbose))
 293     (pui-list-packages)
 294     ))
 295
 296 (defun pui-install-selected-packages ()
 297   "Install selected packages."
 298   (interactive)
 299   (let ( (tmpbuf "*Packages-To-Install*") do-install)
 300     (if pui-selected-packages
 301         (progn
 302           ;; Don't change window config when asking the user if he really
 303           ;; wants to install the packages.  We do this to avoid messing up
 304           ;; the window configuration if errors occur (we don't want to
 305           ;; display random buffers in addition to the error buffer, if
 306           ;; errors occur, which would normally be caused by display-buffer).
 307           (save-window-excursion
 308             (with-output-to-temp-buffer tmpbuf
 309               (display-completion-list (sort
 310                                         (mapcar '(lambda (pkg)
 311                                                    (symbol-name pkg)
 312                                                    )
 313                                                 pui-selected-packages)
 314                                         'string<)
 315                                        :activate-callback nil
 316                                        :help-string "Packages selected for installation:\n"
 317                                        :completion-string t
 318                                        ))
 319             (setq tmpbuf (get-buffer-create tmpbuf))
 320             (display-buffer tmpbuf)
 321             (setq do-install (y-or-n-p "Install these packages? "))
 322             (kill-buffer tmpbuf)
 323             )
 324           (if do-install
 325               (progn
 326                 (save-excursion
 327                   ;; Clear old temp buffer history
 328                   (set-buffer (get-buffer-create package-admin-temp-buffer))
 329                   (buffer-disable-undo package-admin-temp-buffer)
 330                   (erase-buffer package-admin-temp-buffer)
 331                   )
 332                 (message "Installing selected packages ...") (sit-for 0)
 333                 (if (catch 'done
 334                       (mapcar (lambda (pkg)
 335                                 (if (not (package-get pkg
 336                                         pui-package-install-dest-dir))
 337                                     (throw 'done nil)))
 338                               pui-selected-packages)
 339                       t)
 340                     (progn
 341                       (pui-list-packages)
 342                       (message "Packages installed")
 343                       ))
 344                 )
 345               (clear-message)
 346               )
 347           )
 348       (error "No packages have been selected!"))
 349     ))
 350
 351 (defun pui-add-required-packages ()
 352   "Select packages required by those already selected for installation."
 353   (interactive)
 354   (let ((tmpbuf "*Required-Packages*") do-select)
 355     (if pui-selected-packages
 356         (let ((dependencies (package-get-dependencies pui-selected-packages)))
 357           ;; Don't change window config when asking the user if he really
 358           ;; wants to add the packages.  We do this to avoid messing up
 359           ;; the window configuration if errors occur (we don't want to
 360           ;; display random buffers in addition to the error buffer, if
 361           ;; errors occur, which would normally be caused by display-buffer).
 362           (save-window-excursion
 363             (with-output-to-temp-buffer tmpbuf
 364               (display-completion-list (sort
 365                                         (mapcar #'(lambda (pkg)
 366                                                     (symbol-name pkg))
 367                                                 dependencies)
 368                                         'string<)
 369                                        :activate-callback nil
 370                                        :help-string "Required packages:\n"
 371                                        :completion-string t))
 372             (setq tmpbuf (get-buffer-create tmpbuf))
 373             (display-buffer tmpbuf)
 374             (setq do-select (y-or-n-p "Select these packages? "))
 375             (kill-buffer tmpbuf))
 376           (if do-select
 377               (progn
 378                 (setq pui-selected-packages
 379                       (union pui-selected-packages dependencies))
 380                 (map-extents #'(lambda (extent maparg)
 381                                  (pui-update-package-display extent))
 382                              nil nil nil nil nil 'pui)
 383                 (message "added dependencies"))
 384               (clear-message)))
 385       (error "No packages have been selected!"))))
 386
 387 (defun pui-help-echo (extent &optional force-update)
 388   "Display additional package info in the modeline.
 389 EXTENT determines the package to display (the package information is
 390 attached to the extent as properties)."
 391   (let (pkg-sym info inst-ver auth-ver date maintainer)
 392     (if (or force-update (not (current-message))
 393             (string-match ".*: .*: " (current-message))
 394             )
 395         (progn
 396           (setq pkg-sym (extent-property extent 'pui-package)
 397                 info (extent-property extent 'pui-info)
 398                 inst-ver (package-get-key pkg-sym :version)
 399                 auth-ver (package-get-info-prop info 'author-version)
 400                 date (package-get-info-prop info 'date)
 401                 maintainer (package-get-info-prop info 'maintainer))
 402           (if (not inst-ver)
 403               (setq inst-ver ""))
 404           (if pui-list-verbose
 405               (format "Author version: %-8s %11s: %s"
 406                       auth-ver date maintainer)
 407             (format "%-6s: %-8s %11s: %s"
 408                     inst-ver auth-ver date maintainer))
 409           ))
 410     ))
 411
 412 (defun pui-display-info (&optional no-error)
 413   "Display additional package info in the modeline.
 414 Designed to be called interactively (from a keypress)."
 415   (interactive)
 416   (let (extent)
 417     (save-excursion
 418       (beginning-of-line)
 419       (if (setq extent (extent-at (point) (current-buffer) 'pui))
 420           (message (pui-help-echo extent t))
 421         (if no-error
 422             (clear-message nil)
 423           (error "No package under cursor!")))
 424       )))
 425
 426 (defun pui-help-string ()
 427   "Return the help string for the package-info buffer.
 428 This is not a defconst because of the call to substitute-command-keys."
 429   (save-excursion
 430     (set-buffer (get-buffer pui-info-buffer))
 431     (substitute-command-keys
 432 "Symbols in the leftmost column:
 433
 434   +     The package is marked for installation.
 435   -     The package has not been installed.
 436   *     The currently installed package is old, and a newer version is
 437         available.
 438
 439 Useful keys:
 440
 441   `\\[pui-toggle-package-key]' to select/unselect the current package for installation.
 442   `\\[pui-add-required-packages]' to add any packages required by those selected.
 443   `\\[pui-install-selected-packages]' to install selected packages.
 444   `\\[pui-display-info]' to display additional information about the package in the modeline.
 445   `\\[pui-list-packages]' to refresh the package list.
 446   `\\[pui-toggle-verbosity-redisplay]' to toggle between a verbose and non-verbose display.
 447   `\\[pui-quit]' to kill this buffer.
 448 ")
 449     ))
 450
 451 (defvar pui-menu
 452   '("Packages"
 453     ["Select" pui-toggle-package-key t]
 454     ["Info" pui-display-info t]
 455     "---"
 456     ["Add Required" pui-add-required-packages t]
 457     ["Install Selected" pui-install-selected-packages t]
 458     "---"
 459     ["Verbose" pui-toggle-verbosity-redisplay
 460      :active t :style toggle :selected pui-list-verbose]
 461     ["Refresh" pui-list-packages t]
 462     ["Help" pui-help t]
 463     ["Quit" pui-quit t]))
 464
 465
 466 ;;;###autoload
 467 (defun pui-list-packages ()
 468   "List all packages and package information.
 469 The package name, version, and description are displayed.  From the displayed
 470 buffer, the user can see which packages are installed, which are not, and
 471 which are out-of-date (a newer version is available).  The user can then
 472 select packages for installation via the keyboard or mouse."
 473   (interactive)
 474   (package-get-require-base)
 475   (let ( (outbuf (get-buffer-create pui-info-buffer))
 476          (sep-string "===============================================================================\n")
 477          start )
 478     (message "Creating package list ...") (sit-for 0)
 479     (set-buffer outbuf)
 480     (setq buffer-read-only nil)
 481     (buffer-disable-undo outbuf)
 482     (erase-buffer outbuf)
 483     (use-local-map pui-display-keymap)
 484     (if pui-list-verbose
 485         (insert "                 Latest Installed
 486   Package name   Vers.  Vers.   Description
 487 ")
 488       (insert "                 Latest
 489   Package name   Vers.  Description
 490 "))
 491     (insert sep-string)
 492     (setq start (point))
 493     (mapcar '(lambda (pkg)
 494                (let (pkg-sym info version desc
 495                              b e extent current-vers disp)
 496                  (setq pkg-sym (car pkg)
 497                        info (package-get-info-version (cdr pkg) nil))
 498                  (setq version (package-get-info-prop info 'version)
 499                        desc (package-get-info-prop info 'description))
 500
 501                  (setq disp (pui-package-symbol-char pkg-sym
 502                                                      version))
 503                  (setq b (point))
 504                  (if pui-list-verbose
 505                      (progn
 506                        (setq current-vers (package-get-key pkg-sym :version))
 507                        (cond
 508                         ( (not current-vers)
 509                           (setq current-vers "-----") )
 510                         ( (stringp current-vers)
 511                           (setq current-vers
 512                                 (format "%.2f"
 513                                         (string-to-number current-vers))) )
 514                         ( (numberp current-vers)
 515                           (setq current-vers (format "%.2f" current-vers)) )
 516                         )
 517                        (insert
 518                         (format "%s %-15s %-5.2f  %-5s  %s\n"
 519                                 (car disp) pkg-sym
 520                                 (if (stringp version)
 521                                     (string-to-number version)
 522                                   version)
 523                                 current-vers desc))
 524 ;;                     (insert
 525 ;;                      (format "\t\t  %-12s  %s\n"
 526 ;;                              (package-get-info-prop info 'author-version)
 527 ;;                              (package-get-info-prop info 'date)
 528 ;;                              ))
 529                        )
 530                    (insert (format "%s %-15s %-5s %s\n"
 531                                    (car disp)
 532                                    pkg-sym version desc)))
 533                  (save-excursion
 534                    (setq e (progn
 535                              (forward-line -1)
 536                              (end-of-line)
 537                              (point)))
 538                    )
 539                  (setq extent (make-extent b e))
 540                  (if (car (cdr disp))
 541                      (set-extent-face extent (get-face (car (cdr disp))))
 542                    (set-extent-face extent (get-face 'default)))
 543                  (set-extent-property extent 'highlight t)
 544                  (set-extent-property extent 'pui t)
 545                  (set-extent-property extent 'pui-package pkg-sym)
 546                  (set-extent-property extent 'pui-info info)
 547                  (set-extent-property extent 'help-echo 'pui-help-echo)
 548                  (set-extent-property extent 'keymap pui-package-keymap)
 549                  )) (sort (copy-sequence package-get-base)
 550                           '(lambda (a b)
 551                              (string< (symbol-name (car a))
 552                                       (symbol-name (car b)))
 553                                )))
 554     (insert sep-string)
 555     (insert (pui-help-string))
 556     (set-buffer-modified-p nil)
 557     (setq buffer-read-only t)
 558     (pop-to-buffer outbuf)
 559     (delete-other-windows)
 560     (goto-char start)
 561     (setq pui-selected-packages nil)    ; Reset list
 562     (when (featurep 'menubar)
 563       (set-buffer-menubar current-menubar)
 564       (add-submenu '() pui-menu)
 565       (setq mode-popup-menu pui-menu))
 566     (clear-message)
 567 ;    (message (substitute-command-keys "Press `\\[pui-help]' for help."))
 568     ))
 569
 570
 571 (provide 'package-ui)
 572
 573 ;;; package-ui.el ends here