/[emacs]/emacs/lisp/msb.el
ViewVC logotype

Diff of /emacs/lisp/msb.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.42 by rms, Wed May 8 13:13:57 2002 UTC revision 1.42.2.1 by miles, Fri Apr 4 06:20:10 2003 UTC
# Line 1  Line 1 
1  ;;; msb.el --- customizable buffer-selection with multiple menus  ;;; msb.el --- customizable buffer-selection with multiple menus
2    
3  ;; Copyright (C) 1993, 94, 95, 97, 98, 99, 2000, 2001  ;; Copyright (C) 1993, 94, 95, 97, 98, 99, 2000, 2001, 2003
4  ;;  Free Software Foundation, Inc.  ;;  Free Software Foundation, Inc.
5    
6  ;; Author: Lars Lindberg <lars.lindberg@home.se>  ;; Author: Lars Lindberg <lars.lindberg@home.se>
# Line 41  Line 41 
41  ;;   There are some constants for you to try here:  ;;   There are some constants for you to try here:
42  ;;   msb--few-menus  ;;   msb--few-menus
43  ;;   msb--very-many-menus (default)  ;;   msb--very-many-menus (default)
44  ;;    ;;
45  ;;   Look at the variable `msb-item-handling-function' for customization  ;;   Look at the variable `msb-item-handling-function' for customization
46  ;;   of the appearance of every menu item.  Try for instance setting  ;;   of the appearance of every menu item.  Try for instance setting
47  ;;   it to `msb-alon-item-handler'.  ;;   it to `msb-alon-item-handler'.
48  ;;    ;;
49  ;;   Look at the variable `msb-item-sort-function' for customization  ;;   Look at the variable `msb-item-sort-function' for customization
50  ;;   of sorting the menus.  Set it to t for instance, which means no  ;;   of sorting the menus.  Set it to t for instance, which means no
51  ;;   sorting - you will get latest used buffer first.  ;;   sorting - you will get latest used buffer first.
# Line 320  No buffers at all if less than 1 or nil Line 320  No buffers at all if less than 1 or nil
320    :type 'string    :type 'string
321    :set 'msb-custom-set    :set 'msb-custom-set
322    :group 'msb)    :group 'msb)
323    
324  (defvar msb-horizontal-shift-function '(lambda () 0)  (defvar msb-horizontal-shift-function '(lambda () 0)
325    "*Function that specifies how many pixels to shift the top menu leftwards.")    "*Function that specifies how many pixels to shift the top menu leftwards.")
326    
# Line 362  Set this to nil or t if you don't want a Line 362  Set this to nil or t if you don't want a
362                   (const :tag "Oldest first" nil))                   (const :tag "Oldest first" nil))
363    :set 'msb-custom-set    :set 'msb-custom-set
364    :group 'msb)    :group 'msb)
365                    
366  (defcustom msb-files-by-directory nil  (defcustom msb-files-by-directory nil
367    "*Non-nil means that files should be sorted by directory.    "*Non-nil means that files should be sorted by directory.
368  This is instead of the groups in `msb-menu-cond'."  This is instead of the groups in `msb-menu-cond'."
# Line 496  If the argument is left out or nil, then Line 496  If the argument is left out or nil, then
496    (file-name-directory (directory-file-name dir)))    (file-name-directory (directory-file-name dir)))
497    
498  ;; Create an alist with all buffers from LIST that lies under the same  ;; Create an alist with all buffers from LIST that lies under the same
499  ;; directory will be in the same item as the directory string.  ;; directory will be in the same item as the directory name.
500  ;; ((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K BUFFER-K+1...)) ...)  ;; ((DIR1 . (BUFFER-1 BUFFER-2 ...)) (DIR2 . (BUFFER-K BUFFER-K+1...)) ...)
501  (defun msb--init-file-alist (list)  (defun msb--init-file-alist (list)
502    (let ((buffer-alist    (let ((buffer-alist
503           ;; Make alist that looks like           ;; Make alist that looks like
504           ;; ((PATH-1 BUFFER-1) (PATH-2 BUFFER-2) ...)           ;; ((DIR-1 BUFFER-1) (DIR-2 BUFFER-2) ...)
505           ;; sorted on PATH-x           ;; sorted on DIR-x
506           (sort           (sort
507            (apply #'nconc            (apply #'nconc
508                   (mapcar                   (mapcar
# Line 514  If the argument is left out or nil, then Line 514  If the argument is left out or nil, then
514                    list))                    list))
515            (lambda (item1 item2)            (lambda (item1 item2)
516              (string< (car item1) (car item2))))))              (string< (car item1) (car item2))))))
517      ;; Now clump buffers together that have the same path      ;; Now clump buffers together that have the same directory name
518      ;; Make alist that looks like      ;; Make alist that looks like
519      ;; ((PATH1 . (BUFFER-1 BUFFER-2 ...)) (PATH2 . (BUFFER-K)) ...)      ;; ((DIR1 . (BUFFER-1 BUFFER-2 ...)) (DIR2 . (BUFFER-K)) ...)
520      (let ((path nil)      (let ((dir nil)
521            (buffers nil))            (buffers nil))
522        (nconc        (nconc
523         (apply         (apply
524          #'nconc          #'nconc
525          (mapcar (lambda (item)          (mapcar (lambda (item)
526                    (cond                    (cond
527                     ((equal path (car item))                     ((equal dir (car item))
528                      ;; The same path as earlier: Add to current list of                      ;; The same dir as earlier:
529                      ;; buffers.                      ;; Add to current list of buffers.
530                      (push (cdr item) buffers)                      (push (cdr item) buffers)
531                      ;; This item should not be added to list                      ;; This item should not be added to list
532                      nil)                      nil)
533                     (t                     (t
534                      ;; New path                      ;; New dir
535                      (let ((result (and path (cons path buffers))))                      (let ((result (and dir (cons dir buffers))))
536                        (setq path (car item))                        (setq dir (car item))
537                        (setq buffers (list (cdr item)))                        (setq buffers (list (cdr item)))
538                        ;; Add the last result the list.                        ;; Add the last result the list.
539                        (and result (list result))))))                        (and result (list result))))))
540                  buffer-alist))                  buffer-alist))
541         ;; Add the last result to the list         ;; Add the last result to the list
542         (list (cons path buffers))))))         (list (cons dir buffers))))))
543    
544  (defun msb--format-title (top-found-p path number-of-items)  (defun msb--format-title (top-found-p dir number-of-items)
545    "Format a suitable title for the menu item."    "Format a suitable title for the menu item."
546    (format (if top-found-p "%s... (%d)" "%s (%d)")    (format (if top-found-p "%s... (%d)" "%s (%d)")
547            (abbreviate-file-name path) number-of-items))            (abbreviate-file-name dir) number-of-items))
548    
549  ;; Variables for debugging.  ;; Variables for debugging.
550  (defvar msb--choose-file-menu-list)  (defvar msb--choose-file-menu-list)
# Line 559  If the argument is left out or nil, then Line 559  If the argument is left out or nil, then
559                                    msb-max-file-menu-items                                    msb-max-file-menu-items
560                                  10))                                  10))
561          (top-found-p nil)          (top-found-p nil)
562          (last-path nil)          (last-dir nil)
563          first rest path buffers old-path)          first rest dir buffers old-dir)
564      ;; Prepare for looping over all items in buffer-alist      ;; Prepare for looping over all items in buffer-alist
565      (setq first (car buffer-alist)      (setq first (car buffer-alist)
566            rest (cdr buffer-alist)            rest (cdr buffer-alist)
567            path (car first)            dir (car first)
568            buffers (cdr first))            buffers (cdr first))
569      (setq msb--choose-file-menu-list (copy-sequence rest))      (setq msb--choose-file-menu-list (copy-sequence rest))
570      ;; This big loop tries to clump buffers together that have a      ;; This big loop tries to clump buffers together that have a
571      ;; similar name. Remember that buffer-alist is sorted based on the      ;; similar name. Remember that buffer-alist is sorted based on the
572      ;; path for the buffers.      ;; directory name of the buffers' visited files.
573      (while rest      (while rest
574        (let ((found-p nil)        (let ((found-p nil)
575              (tmp-rest rest)              (tmp-rest rest)
576              result              result
577              new-path item)              new-dir item)
578          (setq item (car tmp-rest))          (setq item (car tmp-rest))
579          ;; Clump together the "rest"-buffers that have a path that is          ;; Clump together the "rest"-buffers that have a dir that is
580          ;; a subpath of the current one.          ;; a subdir of the current one.
581          (while (and tmp-rest          (while (and tmp-rest
582                      (<= (length buffers) max-clumped-together)                      (<= (length buffers) max-clumped-together)
583                      (>= (length (car item)) (length path))                      (>= (length (car item)) (length dir))
584                      ;; `completion-ignore-case' seems to default to t                      ;; `completion-ignore-case' seems to default to t
585                      ;; on the systems with case-insensitive file names.                      ;; on the systems with case-insensitive file names.
586                      (eq t (compare-strings path 0 nil                      (eq t (compare-strings dir 0 nil
587                                             (car item) 0 (length path)                                             (car item) 0 (length dir)
588                                             completion-ignore-case)))                                             completion-ignore-case)))
589            (setq found-p t)            (setq found-p t)
590            (setq buffers (append buffers (cdr item))) ;nconc is faster than append            (setq buffers (append buffers (cdr item))) ;nconc is faster than append
# Line 594  If the argument is left out or nil, then Line 594  If the argument is left out or nil, then
594           ((> (length buffers) max-clumped-together)           ((> (length buffers) max-clumped-together)
595            ;; Oh, we failed. Too many buffers clumped together.            ;; Oh, we failed. Too many buffers clumped together.
596            ;; Just use the original ones for the result.            ;; Just use the original ones for the result.
597            (setq last-path (car first))            (setq last-dir (car first))
598            (push (cons (msb--format-title top-found-p            (push (cons (msb--format-title top-found-p
599                                           (car first)                                           (car first)
600                                           (length (cdr first)))                                           (length (cdr first)))
# Line 603  If the argument is left out or nil, then Line 603  If the argument is left out or nil, then
603            (setq top-found-p nil)            (setq top-found-p nil)
604            (setq first (car rest)            (setq first (car rest)
605                  rest (cdr rest)                  rest (cdr rest)
606                  path (car first)                  dir (car first)
607                  buffers (cdr first)))                  buffers (cdr first)))
608           (t           (t
609            ;; The first pass of clumping together worked out, go ahead            ;; The first pass of clumping together worked out, go ahead
610            ;; with this result.            ;; with this result.
611            (when found-p            (when found-p
612              (setq top-found-p t)              (setq top-found-p t)
613              (setq first (cons path buffers)              (setq first (cons dir buffers)
614                    rest tmp-rest))                    rest tmp-rest))
615            ;; Now see if we can clump more buffers together if we go up            ;; Now see if we can clump more buffers together if we go up
616            ;; one step in the file hierarchy.            ;; one step in the file hierarchy.
617            ;; If path isn't changed by msb--strip-dir, we are looking            ;; If dir isn't changed by msb--strip-dir, we are looking
618            ;; at the machine name component of an ange-ftp filename.            ;; at the machine name component of an ange-ftp filename.
619            (setq old-path path)            (setq old-dir dir)
620            (setq path (msb--strip-dir path)            (setq dir (msb--strip-dir dir)
621                  buffers (cdr first))                  buffers (cdr first))
622            (if (equal old-path path)            (if (equal old-dir dir)
623                (setq last-path path))                (setq last-dir dir))
624            (when (and last-path            (when (and last-dir
625                       (or (and (>= (length path) (length last-path))                       (or (and (>= (length dir) (length last-dir))
626                                (eq t (compare-strings                                (eq t (compare-strings
627                                       last-path 0 nil path 0                                       last-dir 0 nil dir 0
628                                       (length last-path)                                       (length last-dir)
629                                       completion-ignore-case)))                                       completion-ignore-case)))
630                           (and (< (length path) (length last-path))                           (and (< (length dir) (length last-dir))
631                                (eq t (compare-strings                                (eq t (compare-strings
632                                       path 0 nil last-path 0 (length path)                                       dir 0 nil last-dir 0 (length dir)
633                                       completion-ignore-case)))))                                       completion-ignore-case)))))
634              ;; We have reached the same place in the file hierarchy as              ;; We have reached the same place in the file hierarchy as
635              ;; the last result, so we should quit at this point and              ;; the last result, so we should quit at this point and
# Line 642  If the argument is left out or nil, then Line 642  If the argument is left out or nil, then
642              (setq top-found-p nil)              (setq top-found-p nil)
643              (setq first (car rest)              (setq first (car rest)
644                    rest (cdr rest)                    rest (cdr rest)
645                    path (car first)                    dir (car first)
646                    buffers (cdr first)))))))                    buffers (cdr first)))))))
647      ;; Now take care of the last item.      ;; Now take care of the last item.
648      (when first      (when first
# Line 729  to the buffer-list variable in function- Line 729  to the buffer-list variable in function-
729                                max-buffer-name-length)                                max-buffer-name-length)
730                       buffer)                       buffer)
731                 (eval list-symbol)))))                 (eval list-symbol)))))
732    
733  (defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)  (defsubst msb--choose-menu (buffer function-info-vector max-buffer-name-length)
734    "Select the appropriate menu for BUFFER."    "Select the appropriate menu for BUFFER."
735    ;; This is all side-effects, folks!    ;; This is all side-effects, folks!
# Line 1132  variable `msb-menu-cond'." Line 1132  variable `msb-menu-cond'."
1132  ;; C-down-mouse-1).  ;; C-down-mouse-1).
1133  (defvar msb-mode-map  (defvar msb-mode-map
1134    (let ((map (make-sparse-keymap "Msb")))    (let ((map (make-sparse-keymap "Msb")))
1135      (substitute-key-definition 'mouse-buffer-menu 'msb map global-map)      (define-key map [remap mouse-buffer-menu] 'msb)
1136      map))      map))
1137    
1138  ;;;###autoload  ;;;###autoload

Legend:
Removed from v.1.42  
changed lines
  Added in v.1.42.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26