Mercurial > hg > xemacs-beta

comparison lisp/package-ui.el @ 442:abe6d1db359e r21-2-36

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-36
author cvs
date Mon, 13 Aug 2007 11:35:02 +0200
parents 8de8e3f6228a
children d7a9135ec789
comparison
equal deleted inserted replaced
441:72a7cfa4a488 442:abe6d1db359e
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;; User-changeable variables: 30 ;; User-changeable variables:
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 32
33 (defgroup pui nil 33 (defgroup pui nil
34 "Conventient interface to the package system." 34 "Convenient interface to the package system."
35 :group 'package-tools 35 :group 'package-tools
36 :tag "Package User interface" 36 :tag "Package User interface"
37 :prefix "pui-") 37 :prefix "pui-")
38 38
39 (defcustom pui-package-install-dest-dir nil 39 (defcustom pui-package-install-dest-dir nil
138 ;; Configuration routines 138 ;; Configuration routines
139 139
140 (defun pui-directory-exists (dir) 140 (defun pui-directory-exists (dir)
141 "Check to see if DIR exists in `package-get-remote'." 141 "Check to see if DIR exists in `package-get-remote'."
142 (let (found) 142 (let (found)
143 (mapcar '(lambda (item) 143 (mapcar #'(lambda (item)
144 (if (and (null (car item)) 144 (if (and (null (car item))
145 (string-equal (file-name-as-directory (car (cdr item))) 145 (string-equal (file-name-as-directory (car (cdr item)))
146 (file-name-as-directory dir))) 146 (file-name-as-directory dir)))
147 (setq found t)) 147 (setq found t)))
148 ) package-get-remote) 148 package-get-remote)
149 found 149 found
150 )) 150 ))
151 151
152 (defun pui-package-dir-list (buffer) 152 (defun pui-package-dir-list (buffer)
153 "In BUFFER, format the list of package binary paths." 153 "In BUFFER, format the list of package binary paths."
307 (if (member pkg-sym pui-deleted-packages) 307 (if (member pkg-sym pui-deleted-packages)
308 (setq pui-deleted-packages 308 (setq pui-deleted-packages
309 (delete pkg-sym pui-deleted-packages)) 309 (delete pkg-sym pui-deleted-packages))
310 (setq pui-deleted-packages 310 (setq pui-deleted-packages
311 (cons pkg-sym pui-deleted-packages)) 311 (cons pkg-sym pui-deleted-packages))
312 (setq pui-seleted-packages 312 (setq pui-selected-packages
313 (delete pkg-sym pui-selected-packages))) 313 (delete pkg-sym pui-selected-packages)))
314 (pui-update-package-display extent pkg-sym) 314 (pui-update-package-display extent pkg-sym)
315 )) 315 ))
316 316
317 317
356 (let ( (tmpbuf "*Packages-To-Remove*") do-delete) 356 (let ( (tmpbuf "*Packages-To-Remove*") do-delete)
357 (when pui-deleted-packages 357 (when pui-deleted-packages
358 (save-window-excursion 358 (save-window-excursion
359 (with-output-to-temp-buffer tmpbuf 359 (with-output-to-temp-buffer tmpbuf
360 (display-completion-list (sort 360 (display-completion-list (sort
361 (mapcar '(lambda (pkg) 361 (mapcar #'symbol-name pui-deleted-packages)
362 (symbol-name pkg) 362 #'string<)
363 )
364 pui-deleted-packages)
365 'string<)
366 :activate-callback nil 363 :activate-callback nil
367 :help-string "Packages selected for removal:\n" 364 :help-string "Packages selected for removal:\n"
368 :completion-string t 365 :completion-string t
369 )) 366 ))
370 (setq tmpbuf (get-buffer-create tmpbuf)) 367 (setq tmpbuf (get-buffer-create tmpbuf))
387 ;; the window configuration if errors occur (we don't want to 384 ;; the window configuration if errors occur (we don't want to
388 ;; display random buffers in addition to the error buffer, if 385 ;; display random buffers in addition to the error buffer, if
389 ;; errors occur, which would normally be caused by display-buffer). 386 ;; errors occur, which would normally be caused by display-buffer).
390 (save-window-excursion 387 (save-window-excursion
391 (with-output-to-temp-buffer tmpbuf 388 (with-output-to-temp-buffer tmpbuf
392 (display-completion-list (sort 389 (display-completion-list
393 (mapcar '(lambda (pkg) 390 (sort (mapcar #'symbol-name pui-selected-packages) #'string<)
394 (symbol-name pkg) 391 :activate-callback nil
395 ) 392 :help-string "Packages selected for installation:\n"
396 pui-selected-packages) 393 :completion-string t
397 'string<) 394 ))
398 :activate-callback nil
399 :help-string "Packages selected for installation:\n"
400 :completion-string t
401 ))
402 (setq tmpbuf (get-buffer-create tmpbuf)) 395 (setq tmpbuf (get-buffer-create tmpbuf))
403 (display-buffer tmpbuf) 396 (display-buffer tmpbuf)
404 (setq do-install (y-or-n-p "Install these packages? ")) 397 (setq do-install (y-or-n-p "Install these packages? "))
405 (kill-buffer tmpbuf) 398 (kill-buffer tmpbuf)
406 ) 399 )
526 (if no-error 519 (if no-error
527 (clear-message nil) 520 (clear-message nil)
528 (error "No package under cursor!"))) 521 (error "No package under cursor!")))
529 ))) 522 )))
530 523
531 ;;; "Why is there no standard function to do this?"
532 (defun pui-popup-context-sensitive (event)
533 (interactive "e")
534 (save-excursion
535 (set-buffer (event-buffer event))
536 (goto-char (event-point event))
537 (popup-menu pui-menu event)
538 ;; I agree with dired.el - this is seriously bogus.
539 (while (popup-menu-up-p)
540 (dispatch-event (next-event)))))
541
542 (defvar pui-menu 524 (defvar pui-menu
543 '("Packages" 525 '("Packages"
544 ["Toggle install " pui-toggle-package-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))] 526 ["Toggle install " pui-toggle-package-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))]
545 ["Toggle delete " pui-toggle-package-delete-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))] 527 ["Toggle delete " pui-toggle-package-delete-key :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))]
546 ["Info on" pui-display-info :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))] 528 ["Info on" pui-display-info :active (pui-current-package) :suffix (format "`%s'" (or (pui-current-package) "..."))]
552 :active t :style toggle :selected pui-list-verbose] 534 :active t :style toggle :selected pui-list-verbose]
553 ["Refresh" pui-list-packages t] 535 ["Refresh" pui-list-packages t]
554 ["Help" pui-help t] 536 ["Help" pui-help t]
555 ["Quit" pui-quit t])) 537 ["Quit" pui-quit t]))
556 538
539 ;;; "Why is there no standard function to do this?"
540 (defun pui-popup-context-sensitive (event)
541 (interactive "e")
542 (save-excursion
543 (set-buffer (event-buffer event))
544 (goto-char (event-point event))
545 (popup-menu pui-menu event)
546 ;; I agree with dired.el - this is seriously bogus.
547 (while (popup-up-p)
548 (dispatch-event (next-event)))))
557 549
558 (defun list-packages-mode () 550 (defun list-packages-mode ()
559 "Symbols in the leftmost column: 551 "Symbols in the leftmost column:
560 552
561 + The package is marked for installation. 553 + The package is marked for installation.
616 (insert " Latest 608 (insert " Latest
617 Package name Vers. Description 609 Package name Vers. Description
618 ")) 610 "))
619 (insert sep-string) 611 (insert sep-string)
620 (setq start (point)) 612 (setq start (point))
621 (mapcar '(lambda (pkg) 613 (mapcar
622 (let (pkg-sym info version desc 614 #'(lambda (pkg)
623 b e extent current-vers disp) 615 (let (pkg-sym info version desc
624 (setq pkg-sym (car pkg) 616 b e extent current-vers disp)
625 info (package-get-info-version (cdr pkg) nil)) 617 (setq pkg-sym (car pkg)
626 (setq version (package-get-info-prop info 'version) 618 info (package-get-info-version (cdr pkg) nil))
627 desc (package-get-info-prop info 'description)) 619 (setq version (package-get-info-prop info 'version)
628 620 desc (package-get-info-prop info 'description))
629 (setq disp (pui-package-symbol-char pkg-sym 621
630 version)) 622 (setq disp (pui-package-symbol-char pkg-sym
631 (setq b (point)) 623 version))
632 (if pui-list-verbose 624 (setq b (point))
633 (progn 625 (if pui-list-verbose
634 (setq current-vers (package-get-key pkg-sym :version)) 626 (progn
635 (cond 627 (setq current-vers (package-get-key pkg-sym :version))
636 ( (not current-vers) 628 (cond
637 (setq current-vers "-----") ) 629 ( (not current-vers)
638 ( (stringp current-vers) 630 (setq current-vers "-----") )
639 (setq current-vers 631 ( (stringp current-vers)
640 (format "%.2f" 632 (setq current-vers
641 (string-to-number current-vers))) ) 633 (format "%.2f"
642 ( (numberp current-vers) 634 (string-to-number current-vers))) )
643 (setq current-vers (format "%.2f" current-vers)) ) 635 ( (numberp current-vers)
644 ) 636 (setq current-vers (format "%.2f" current-vers)) )
645 (insert 637 )
646 (format "%s %-15s %-5.2f %-5s %s\n" 638 (insert
647 (car disp) pkg-sym 639 (format "%s %-15s %-5.2f %-5s %s\n"
648 (if (stringp version) 640 (car disp) pkg-sym
649 (string-to-number version) 641 (if (stringp version)
650 version) 642 (string-to-number version)
651 current-vers desc)) 643 version)
652 ;; (insert 644 current-vers desc))
653 ;; (format "\t\t %-12s %s\n" 645 ;; (insert
654 ;; (package-get-info-prop info 'author-version) 646 ;; (format "\t\t %-12s %s\n"
655 ;; (package-get-info-prop info 'date) 647 ;; (package-get-info-prop info 'author-version)
656 ;; )) 648 ;; (package-get-info-prop info 'date)))
657 ) 649 )
658 (insert (format "%s %-15s %-5s %s\n" 650 (insert (format "%s %-15s %-5s %s\n"
659 (car disp) 651 (car disp)
660 pkg-sym version desc))) 652 pkg-sym version desc)))
661 (save-excursion 653 (save-excursion
662 (setq e (progn 654 (setq e (progn
663 (forward-line -1) 655 (forward-line -1)
664 (end-of-line) 656 (end-of-line)
665 (point))) 657 (point))))
666 ) 658 (setq extent (make-extent b e))
667 (setq extent (make-extent b e)) 659 (if (car (cdr disp))
668 (if (car (cdr disp)) 660 (set-extent-face extent (get-face (car (cdr disp))))
669 (set-extent-face extent (get-face (car (cdr disp)))) 661 (set-extent-face extent (get-face 'default)))
670 (set-extent-face extent (get-face 'default))) 662 (set-extent-property extent 'highlight t)
671 (set-extent-property extent 'highlight t) 663 (set-extent-property extent 'pui t)
672 (set-extent-property extent 'pui t) 664 (set-extent-property extent 'pui-package pkg-sym)
673 (set-extent-property extent 'pui-package pkg-sym) 665 (set-extent-property extent 'pui-info info)
674 (set-extent-property extent 'pui-info info) 666 (set-extent-property extent 'help-echo 'pui-help-echo)
675 (set-extent-property extent 'help-echo 'pui-help-echo) 667 (set-extent-property extent 'keymap pui-package-keymap)
676 (set-extent-property extent 'keymap pui-package-keymap) 668 ))
677 )) (sort (copy-sequence package-get-base) 669 (sort (copy-sequence package-get-base)
678 '(lambda (a b) 670 #'(lambda (a b)
679 (string< (symbol-name (car a)) 671 (string< (symbol-name (car a))
680 (symbol-name (car b))) 672 (symbol-name (car b))))))
681 )))
682 (insert sep-string) 673 (insert sep-string)
683 (insert (documentation 'list-packages-mode)) 674 (insert (documentation 'list-packages-mode))
684 (set-buffer-modified-p nil) 675 (set-buffer-modified-p nil)
685 (setq buffer-read-only t) 676 (setq buffer-read-only t)
686 (pop-to-buffer outbuf) 677 (pop-to-buffer outbuf)
691 (when (featurep 'menubar) 682 (when (featurep 'menubar)
692 (set-buffer-menubar current-menubar) 683 (set-buffer-menubar current-menubar)
693 (add-submenu '() pui-menu) 684 (add-submenu '() pui-menu)
694 (setq mode-popup-menu pui-menu)) 685 (setq mode-popup-menu pui-menu))
695 (clear-message) 686 (clear-message)
696 ; (message (substitute-command-keys "Press `\\[pui-help]' for help.")) 687 ;; (message (substitute-command-keys "Press `\\[pui-help]' for help."))
697 )) 688 ))
698 689
699 ;;;###autoload 690 ;;;###autoload
700 (defalias 'list-packages 'pui-list-packages) 691 (defalias 'list-packages 'pui-list-packages)
701 692