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         (let ((installed (package-get-key pkg-sym :version)))
 217           (if (>= (if (stringp installed)
 218                       (string-to-number installed)
 219                     installed)
 220                   (if (stringp version)
 221                       (string-to-number version)
 222                     version))
 223               (list " " pui-up-to-date-package-face)
 224             (list "*" pui-outdated-package-face)))
 225       (list "-" pui-uninstalled-package-face))
 226     ))
 227
 228 (defun pui-update-package-display (extent &optional pkg-sym version)
 229   "Update the package status for EXTENT.
 230 If PKG-SYM or VERSION are not given, they are read from the extent.
 231 These are used to determine whether or not the package is installed,
 232 and whether or not it is up-to-date."
 233   (let (buffer-read-only disp sym-char)
 234     (if (not pkg-sym)
 235         (setq pkg-sym (extent-property extent 'pui-package)))
 236     (if (not version)
 237         (setq version (package-get-info-prop (extent-property extent 'pui-info)
 238                                              'version)))
 239     (if (member pkg-sym pui-selected-packages)
 240         (progn
 241           (if pui-selected-package-face
 242               (set-extent-face extent (get-face pui-selected-package-face))
 243             (set-extent-face extent (get-face 'default)))
 244           (setq sym-char "+")
 245           )
 246       (progn
 247         (setq disp (pui-package-symbol-char pkg-sym version))
 248         (setq sym-char (car disp))
 249         (if (car (cdr disp))
 250             (set-extent-face extent (get-face (car (cdr disp))))
 251           (set-extent-face extent (get-face 'default)))
 252         ))
 253     (save-excursion
 254       (goto-char (extent-start-position extent))
 255       (delete-char 1)
 256       (insert sym-char)
 257       (set-buffer-modified-p nil)
 258       )
 259     ))
 260
 261 (defun pui-toggle-package (extent)
 262   (let (pkg-sym)
 263     (setq pkg-sym (extent-property extent 'pui-package))
 264     (if (member pkg-sym pui-selected-packages)
 265         (setq pui-selected-packages
 266               (delete pkg-sym pui-selected-packages))
 267       (setq pui-selected-packages
 268             (cons pkg-sym pui-selected-packages)))
 269     (pui-update-package-display extent pkg-sym)
 270     ))
 271
 272 (defun pui-toggle-package-key ()
 273   "Select/unselect package for installation, using the keyboard."
 274   (interactive)
 275   (let (extent)
 276     (if (setq extent (extent-at (point) (current-buffer) 'pui))
 277         (progn
 278           (pui-toggle-package extent)
 279           (forward-line 1)
 280           )
 281       (error "No package under cursor!"))
 282     ))
 283
 284 (defun pui-toggle-package-event (event)
 285   "Select/unselect package for installation, using the mouse."
 286   (interactive "e")
 287   (let* ( (ep (event-point event))
 288           (buffer (window-buffer (event-window event)))
 289           (extent (extent-at ep buffer 'pui-package))
 290           )
 291     (pui-toggle-package extent)
 292     ))
 293
 294 (defun pui-toggle-verbosity-redisplay ()
 295   "Toggle verbose package info."
 296   (interactive)
 297   (progn
 298     (setq pui-list-verbose (not pui-list-verbose))
 299     (pui-list-packages)
 300     ))
 301
 302 (defun pui-install-selected-packages ()
 303   "Install selected packages."
 304   (interactive)
 305   (let ( (tmpbuf "*Packages-To-Install*") do-install)
 306     (if pui-selected-packages
 307         (progn
 308           ;; Don't change window config when asking the user if he really
 309           ;; wants to install the packages.  We do this to avoid messing up
 310           ;; the window configuration if errors occur (we don't want to
 311           ;; display random buffers in addition to the error buffer, if
 312           ;; errors occur, which would normally be caused by display-buffer).
 313           (save-window-excursion
 314             (with-output-to-temp-buffer tmpbuf
 315               (display-completion-list (sort
 316                                         (mapcar '(lambda (pkg)
 317                                                    (symbol-name pkg)
 318                                                    )
 319                                                 pui-selected-packages)
 320                                         'string<)
 321                                        :activate-callback nil
 322                                        :help-string "Packages selected for installation:\n"
 323                                        :completion-string t
 324                                        ))
 325             (setq tmpbuf (get-buffer-create tmpbuf))
 326             (display-buffer tmpbuf)
 327             (setq do-install (y-or-n-p "Install these packages? "))
 328             (kill-buffer tmpbuf)
 329             )
 330           (if do-install
 331               (progn
 332                 (save-excursion
 333                   ;; Clear old temp buffer history
 334                   (set-buffer (get-buffer-create package-admin-temp-buffer))
 335                   (buffer-disable-undo package-admin-temp-buffer)
 336                   (erase-buffer package-admin-temp-buffer)
 337                   )
 338                 (message "Installing selected packages ...") (sit-for 0)
 339                 (if (catch 'done
 340                       (mapcar (lambda (pkg)
 341                                 (if (not (package-get pkg nil nil
 342                                                       pui-package-install-dest-dir))
 343                                     (throw 'done nil)))
 344                               pui-selected-packages)
 345                       t)
 346                     (progn
 347                       (pui-list-packages)
 348                       (message "Packages installed")
 349                       ))
 350                 )
 351               (clear-message)
 352               )
 353           )
 354       (error "No packages have been selected!"))
 355     ))
 356
 357 (defun pui-add-required-packages ()
 358   "Select packages required by those already selected for installation."
 359   (interactive)
 360   (let ((tmpbuf "*Required-Packages*") do-select)
 361     (if pui-selected-packages
 362         (let ((dependencies
 363                (delq nil (mapcar
 364                           (lambda (pkg)
 365                             (let ((installed
 366                                    (package-get-key pkg :version))
 367                                   (current
 368                                    (package-get-info-prop
 369                                     (package-get-info-version
 370                                      (package-get-info-find-package
 371                                       package-get-base pkg) nil)
 372                                     'version)))
 373                               (if (< (if (stringp installed)
 374                                          (string-to-number installed)
 375                                        installed)
 376                                      (if (stringp current)
 377                                          (string-to-number current)
 378                                        current))
 379                                   pkg
 380                                 nil)))
 381                           (package-get-dependencies pui-selected-packages)))))
 382           ;; Don't change window config when asking the user if he really
 383           ;; wants to add the packages.  We do this to avoid messing up
 384           ;; the window configuration if errors occur (we don't want to
 385           ;; display random buffers in addition to the error buffer, if
 386           ;; errors occur, which would normally be caused by display-buffer).
 387           (save-window-excursion
 388             (with-output-to-temp-buffer tmpbuf
 389               (display-completion-list (sort
 390                                         (mapcar #'(lambda (pkg)
 391                                                     (symbol-name pkg))
 392                                                 dependencies)
 393                                         'string<)
 394                                        :activate-callback nil
 395                                        :help-string "Required packages:\n"
 396                                        :completion-string t))
 397             (setq tmpbuf (get-buffer-create tmpbuf))
 398             (display-buffer tmpbuf)
 399             (setq do-select (y-or-n-p "Select these packages? "))
 400             (kill-buffer tmpbuf))
 401           (if do-select
 402               (progn
 403                 (setq pui-selected-packages
 404                       (union pui-selected-packages dependencies))
 405                 (map-extents #'(lambda (extent maparg)
 406                                  (pui-update-package-display extent))
 407                              nil nil nil nil nil 'pui)
 408                 (message "added dependencies"))
 409               (clear-message)))
 410       (error "No packages have been selected!"))))
 411
 412 (defun pui-help-echo (extent &optional force-update)
 413   "Display additional package info in the modeline.
 414 EXTENT determines the package to display (the package information is
 415 attached to the extent as properties)."
 416   (let (pkg-sym info inst-ver auth-ver date maintainer)
 417     (if (or force-update (not (current-message))
 418             (string-match ".*: .*: " (current-message))
 419             )
 420         (progn
 421           (setq pkg-sym (extent-property extent 'pui-package)
 422                 info (extent-property extent 'pui-info)
 423                 inst-ver (package-get-key pkg-sym :version)
 424                 auth-ver (package-get-info-prop info 'author-version)
 425                 date (package-get-info-prop info 'date)
 426                 maintainer (package-get-info-prop info 'maintainer))
 427           (if (not inst-ver)
 428               (setq inst-ver ""))
 429           (if pui-list-verbose
 430               (format "Author version: %-8s %11s: %s"
 431                       auth-ver date maintainer)
 432             (format "%-6s: %-8s %11s: %s"
 433                     inst-ver auth-ver date maintainer))
 434           ))
 435     ))
 436
 437 (defun pui-display-info (&optional no-error)
 438   "Display additional package info in the modeline.
 439 Designed to be called interactively (from a keypress)."
 440   (interactive)
 441   (let (extent)
 442     (save-excursion
 443       (beginning-of-line)
 444       (if (setq extent (extent-at (point) (current-buffer) 'pui))
 445           (message (pui-help-echo extent t))
 446         (if no-error
 447             (clear-message nil)
 448           (error "No package under cursor!")))
 449       )))
 450
 451 (defun pui-help-string ()
 452   "Return the help string for the package-info buffer.
 453 This is not a defconst because of the call to substitute-command-keys."
 454   (save-excursion
 455     (set-buffer (get-buffer pui-info-buffer))
 456     (substitute-command-keys
 457 "Symbols in the leftmost column:
 458
 459   +     The package is marked for installation.
 460   -     The package has not been installed.
 461   *     The currently installed package is old, and a newer version is
 462         available.
 463
 464 Useful keys:
 465
 466   `\\[pui-toggle-package-key]' to select/unselect the current package for installation.
 467   `\\[pui-add-required-packages]' to add any packages required by those selected.
 468   `\\[pui-install-selected-packages]' to install selected packages.
 469   `\\[pui-display-info]' to display additional information about the package in the modeline.
 470   `\\[pui-list-packages]' to refresh the package list.
 471   `\\[pui-toggle-verbosity-redisplay]' to toggle between a verbose and non-verbose display.
 472   `\\[pui-quit]' to kill this buffer.
 473 ")
 474     ))
 475
 476 (defvar pui-menu
 477   '("Packages"
 478     ["Select" pui-toggle-package-key t]
 479     ["Info" pui-display-info t]
 480     "---"
 481     ["Add Required" pui-add-required-packages t]
 482     ["Install Selected" pui-install-selected-packages t]
 483     "---"
 484     ["Verbose" pui-toggle-verbosity-redisplay
 485      :active t :style toggle :selected pui-list-verbose]
 486     ["Refresh" pui-list-packages t]
 487     ["Help" pui-help t]
 488     ["Quit" pui-quit t]))
 489
 490
 491 ;;;###autoload
 492 (defun pui-list-packages ()
 493   "List all packages and package information.
 494 The package name, version, and description are displayed.  From the displayed
 495 buffer, the user can see which packages are installed, which are not, and
 496 which are out-of-date (a newer version is available).  The user can then
 497 select packages for installation via the keyboard or mouse."
 498   (interactive)
 499   (package-get-require-base t)
 500   (let ( (outbuf (get-buffer-create pui-info-buffer))
 501          (sep-string "===============================================================================\n")
 502          start )
 503     (message "Creating package list ...") (sit-for 0)
 504     (set-buffer outbuf)
 505     (setq buffer-read-only nil)
 506     (buffer-disable-undo outbuf)
 507     (erase-buffer outbuf)
 508     (use-local-map pui-display-keymap)
 509     (if pui-list-verbose
 510         (insert "                 Latest Installed
 511   Package name   Vers.  Vers.   Description
 512 ")
 513       (insert "                 Latest
 514   Package name   Vers.  Description
 515 "))
 516     (insert sep-string)
 517     (setq start (point))
 518     (mapcar '(lambda (pkg)
 519                (let (pkg-sym info version desc
 520                              b e extent current-vers disp)
 521                  (setq pkg-sym (car pkg)
 522                        info (package-get-info-version (cdr pkg) nil))
 523                  (setq version (package-get-info-prop info 'version)
 524                        desc (package-get-info-prop info 'description))
 525
 526                  (setq disp (pui-package-symbol-char pkg-sym
 527                                                      version))
 528                  (setq b (point))
 529                  (if pui-list-verbose
 530                      (progn
 531                        (setq current-vers (package-get-key pkg-sym :version))
 532                        (cond
 533                         ( (not current-vers)
 534                           (setq current-vers "-----") )
 535                         ( (stringp current-vers)
 536                           (setq current-vers
 537                                 (format "%.2f"
 538                                         (string-to-number current-vers))) )
 539                         ( (numberp current-vers)
 540                           (setq current-vers (format "%.2f" current-vers)) )
 541                         )
 542                        (insert
 543                         (format "%s %-15s %-5.2f  %-5s  %s\n"
 544                                 (car disp) pkg-sym
 545                                 (if (stringp version)
 546                                     (string-to-number version)
 547                                   version)
 548                                 current-vers desc))
 549 ;;                     (insert
 550 ;;                      (format "\t\t  %-12s  %s\n"
 551 ;;                              (package-get-info-prop info 'author-version)
 552 ;;                              (package-get-info-prop info 'date)
 553 ;;                              ))
 554                        )
 555                    (insert (format "%s %-15s %-5s %s\n"
 556                                    (car disp)
 557                                    pkg-sym version desc)))
 558                  (save-excursion
 559                    (setq e (progn
 560                              (forward-line -1)
 561                              (end-of-line)
 562                              (point)))
 563                    )
 564                  (setq extent (make-extent b e))
 565                  (if (car (cdr disp))
 566                      (set-extent-face extent (get-face (car (cdr disp))))
 567                    (set-extent-face extent (get-face 'default)))
 568                  (set-extent-property extent 'highlight t)
 569                  (set-extent-property extent 'pui t)
 570                  (set-extent-property extent 'pui-package pkg-sym)
 571                  (set-extent-property extent 'pui-info info)
 572                  (set-extent-property extent 'help-echo 'pui-help-echo)
 573                  (set-extent-property extent 'keymap pui-package-keymap)
 574                  )) (sort (copy-sequence package-get-base)
 575                           '(lambda (a b)
 576                              (string< (symbol-name (car a))
 577                                       (symbol-name (car b)))
 578                                )))
 579     (insert sep-string)
 580     (insert (pui-help-string))
 581     (set-buffer-modified-p nil)
 582     (setq buffer-read-only t)
 583     (pop-to-buffer outbuf)
 584     (delete-other-windows)
 585     (goto-char start)
 586     (setq pui-selected-packages nil)    ; Reset list
 587     (when (featurep 'menubar)
 588       (set-buffer-menubar current-menubar)
 589       (add-submenu '() pui-menu)
 590       (setq mode-popup-menu pui-menu))
 591     (clear-message)
 592 ;    (message (substitute-command-keys "Press `\\[pui-help]' for help."))
 593     ))
 594
 595
 596 (provide 'package-ui)
 597
 598 ;;; package-ui.el ends here