lisp/bs.el

   1 ;;; bs.el --- menu for selecting and displaying buffers
   2
   3 ;; Copyright (C) 1998, 1999 Free Software Foundation, Inc.
   4 ;; Author: Olaf Sylvester <Olaf.Sylvester@netsurf.de>
   5 ;; Maintainer: Olaf Sylvester <Olaf.Sylvester@netsurf.de>
   6 ;; Keywords: convenience
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it 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 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Version: 1.17
  28 ;; X-URL: http://home.netsurf.de/olaf.sylvester/emacs
  29 ;;
  30 ;; The bs-package contains a main function bs-show for poping up a
  31 ;; buffer in a way similar to `list-buffers' and `electric-buffer-list':
  32 ;; The new buffer offers a Buffer Selection Menu for manipulating
  33 ;; the buffer list and buffers.
  34 ;;
  35 ;; -----------------------------------------------------------------------
  36 ;; | MR Buffer          Size  Mode          File                         |
  37 ;; | -- ------          ----  ----          ----                         |
  38 ;; |.   bs.el           14690  Emacs-Lisp    /home/sun/sylvester/el/bs.e$|
  39 ;; |  % executable.el    9429  Emacs-Lisp    /usr/share/emacs/19.34/lisp$|
  40 ;; |  % vc.el          104893  Emacs-Lisp    /usr/share/emacs/19.34/lisp$|
  41 ;; |  % test_vc.el        486  Emacs-Lisp    /home/sun/sylvester/el/test$|
  42 ;; |  % vc-hooks.el     43605  Emacs-Lisp    /usr/share/emacs/19.34/lisp$|
  43 ;; -----------------------------------------------------------------------
  44
  45 ;;; Quick Installation und Customization:
  46
  47 ;; Use
  48 ;;   M-x bs-show
  49 ;; for buffer selection or optional bind a key to main function `bs-show'
  50 ;;   (global-set-key "\C-x\C-b" 'bs-show)    ;; or another key
  51 ;;
  52 ;; For customization use
  53 ;; M-x bs-customize
  54
  55
  56 ;;; More Commentary:
  57
  58 ;; bs-show will generate a new buffer named *buffer-selection*, which shows
  59 ;; all buffers or a subset of them, and has possibilities for deleting,
  60 ;; saving and selecting buffers. For more details see docstring of
  61 ;; function `bs-mode'. A current configuration describes which buffers appear
  62 ;; in *buffer-selection*. See docstring of variable `bs-configurations' for
  63 ;; more details.
  64 ;;
  65 ;; The package bs combines the advantages of the Emacs functions
  66 ;; `list-buffers' and `electric-buffer-list'.
  67 ;;
  68 ;; Additioal features for Buffer Selection Menu:
  69 ;;  - configurable list of buffers (show only files etc.).
  70 ;;  - comfortable way to change displayed subset of all buffers.
  71 ;;  - show sorted list of buffers.
  72 ;;  - cyclic navigation:
  73 ;;     - goes to top of buffer list if you are on last line and press down.
  74 ;;     - goes to end of buffer list if you are on first line and press up.
  75 ;;  - Offer an alternative buffer list by prefix key C-u.
  76
  77 ;;; Cycling through buffers
  78
  79 ;; This package offers two functions for buffer cycling. If you want to cycle
  80 ;; through buffer list you can use `bs-cycle-next' or `bs-cycle-previous'.
  81 ;; Bind these function to a key like
  82 ;;   (global-set-key [(f9)]   'bs-cycle-previous)
  83 ;;   (global-set-key [(f10)]  'bs-cycle-next)
  84 ;;
  85 ;; Both functions use a special subset of all buffers for cycling to avoid
  86 ;; to go through internal buffers like *Messages*.
  87 ;;
  88 ;; Cycling through buffers ignores sorting because sorting destroys
  89 ;; the logical buffer list. If buffer list is sorted by size you
  90 ;; won't be able to cycle to the smallest buffer.
  91
  92 ;;; Customization:
  93
  94 ;; There is a customization group called `bs' in group `convenience'.
  95 ;; Start customization by M-x bs-customize
  96 ;;
  97 ;; Buffer list
  98 ;; -----------
  99 ;; You can define your own configurations by extending variable
 100 ;; `bs-configurations' (see docstring for details).
 101 ;;
 102 ;; `bs-default-configuration' contains the name of default configuration.
 103 ;; The default value is "files" which means to show only files.
 104 ;;
 105 ;; If you always want to see all buffers, customize variable
 106 ;; `bs-default-configuration' in customization group `bs'.
 107 ;;
 108 ;; Configure sorting
 109 ;; -----------------
 110 ;; You can define functions for sorting the buffer list.
 111 ;; When selecting buffers, you can step through available sorting
 112 ;; methods with key 'S'.
 113 ;; To define a new way of sorting, customize variable `bs-sort-functions'.
 114 ;;
 115 ;; There are four basic functions for sorting:
 116 ;;   by buffer name, by mode, by size, or by filename
 117 ;;
 118 ;; Configure buffer cycling
 119 ;; ------------------------
 120 ;; When cycling through buffer list the functions for cycling will use
 121 ;; the current configuration of bs to calculate the buffer list.
 122 ;; If you want to use a different configuration for cycling you have to set
 123 ;; the variable `bs-cycle-configuration-name'. You can customize this variable.
 124 ;;
 125 ;; For example: If you use the configuration called "files-and-scratch" you
 126 ;; can cycle through all file buffers and *scratch* although your current
 127 ;; configuration perhaps is "files" which ignores buffer *scratch*.
 128
 129 ;;; History:
 130
 131 ;;; Code:
 132
 133 ;; ----------------------------------------------------------------------
 134 ;; Globals for customization
 135 ;; ----------------------------------------------------------------------
 136
 137 (defgroup bs nil
 138   "Buffer Selection: Maintaining buffers by buffer menu."
 139   :version "21.1"
 140   :group 'convenience)
 141
 142 (defgroup bs-appearence nil
 143   "Buffer Selection appearence: Appearence of bs buffer menu."
 144   :group 'bs)
 145
 146 (defcustom bs-attributes-list
 147   '((""       1   1 left  bs--get-marked-string)
 148     ("M"      1   1 left  bs--get-modified-string)
 149     ("R"      2   2 left  bs--get-readonly-string)
 150     ("Buffer" bs--get-name-length 10 left  bs--get-name)
 151     (""       1   1 left  " ")
 152     ("Size"   8   8 right bs--get-size-string)
 153     (""       1   1 left  " ")
 154     ("Mode"   12 12 right bs--get-mode-name)
 155     (""       2   2 left  "  ")
 156     ("File"   12 12 left  bs--get-file-name)
 157     (""       2   2 left  "  "))
 158   "*List specifying the layout of a Buffer Selection Menu buffer.
 159 Each entry specifies a column and is a list of the form of:
 160 (HEADER MINIMUM-LENGTH MAXIMUM-LENGTH ALIGNMENT FUN-OR-STRING)
 161 HEADER         : string for header for first line or a function
 162   which calculates column title.
 163 MINIMUM-LENGTH : minimum width of column (number or name of function).
 164   The function must return a positive integer.
 165 MAXIMUM-LENGTH : maximum width of column (number or name of function)
 166                  (currently ignored)
 167 ALIGNMENT      : alignment of column: (`left' `right' `middle')
 168 FUN-OR-STRING  : Name of a function for calculating the value or
 169 a string for a constant value.
 170 The function gets as parameter the buffer we have started
 171 buffer selection and the list of all buffers to show.  The function must
 172 return a string representing the columns value."
 173   :group 'bs-appearence
 174   :type '(repeat sexp))
 175
 176 (defvar bs--running-in-xemacs (string-match "XEmacs" (emacs-version))
 177   "Non-nil when running under XEmacs.")
 178
 179
 180 (defun bs--make-header-match-string ()
 181   "Return a regexp matching the first line of a Buffer Selection Menu buffer."
 182   (let ((res "^\\(")
 183  (ele  bs-attributes-list))
 184     (while ele
 185       (setq res (concat res (car (car ele)) " *"))
 186       (setq ele (cdr ele)))
 187     (concat res "$\\)")))
 188
 189 ;;; Font-Lock-Settings
 190 (defvar bs-mode-font-lock-keywords
 191   (list ;; header in font-lock-type-face
 192         (list (bs--make-header-match-string)
 193        '(1 font-lock-type-face append) '(1 'bold append))
 194  ;; Buffername embedded by *
 195  (list "^\\(.*\\*.*\\*.*\\)$"
 196        1 (if bs--running-in-xemacs
 197       ;; problem in XEmacs with font-lock-constant-face
 198       (if (facep 'font-lock-constant-face)
 199    'font-lock-constant-face
 200         'font-lock-comment-face)
 201     'font-lock-constant-face))
 202  ;; Dired-Buffers
 203  '("^..\\(.*Dired by .*\\)$" 1 font-lock-function-name-face)
 204  ;; the star for modified buffers
 205  '("^.\\(\\*\\) +[^\\*]"     1 font-lock-comment-face))
 206   "Default font lock expressions for Buffer Selection Menu.")
 207
 208 (defcustom bs-max-window-height 20
 209   "*Maximal window height of Buffer Selection Menu."
 210   :group 'bs-appearence
 211   :type 'integer)
 212
 213 (defvar bs-dont-show-regexp nil
 214   "Regular expression specifying which buffers not to show.
 215 A buffer whose name matches this regular expression will not be
 216 included in the buffer list.")
 217
 218 (defvar bs-must-show-regexp nil
 219   "Regular expression for specifying buffers which must be shown.
 220 A buffer whose name matches this regular expression will be
 221 included in the buffer list.
 222 Note that this variable is temporary: if the configuration is changed
 223 it is reset to nil.  Use `bs-must-always-show-regexp' to specify buffers
 224 that must always be shown regardless of the configuration.")
 225
 226 (defcustom bs-must-always-show-regexp nil
 227   "*Regular expression for specifying buffers to show always.
 228 A buffer whose name matches this regular expression will
 229 be shown regardless of current configuration of Buffer Selection Menu."
 230   :group 'bs
 231   :type '(choice (const :tag "Nothing at all" nil) regexp))
 232
 233 (defvar bs-dont-show-function nil
 234   "Function for specifying buffers not to show.
 235 The function gets one argument - the buffer to test.  The function must
 236 return a value different from nil to ignore the buffer in
 237 Buffer Selection Menu.")
 238
 239 (defvar bs-must-show-function nil
 240   "Function for specifying buffers which must be shown.
 241 The function gets one argument - the buffer to test.")
 242
 243 (defvar bs-buffer-sort-function nil
 244   "Sort function to sort the buffers that appear in Buffer Selection Menu.
 245 The functions gets two arguments - the buffers to compare.")
 246
 247 (defcustom bs-maximal-buffer-name-column 45
 248   "*Maximum column width for buffer names.
 249 The column for buffer names has dynamic width.  The width depends on
 250 maximal and minimal length of names of buffers to show.  The maximal
 251 width is bounded by `bs-maximal-buffer-name-column'.
 252 See also `bs-minimal-buffer-name-column'."
 253   :group 'bs-appearence
 254   :type 'integer)
 255
 256 (defcustom bs-minimal-buffer-name-column 15
 257   "*Minimum column width for buffer names.
 258 The column for buffer names has dynamic width.  The width depends on
 259 maximal and minimal length of names of buffers to show.  The minimal
 260 width is bounded by `bs-minimal-buffer-name-column'.
 261 See also `bs-maximal-buffer-name-column'."
 262   :group 'bs-appearence
 263   :type 'integer)
 264
 265 (defconst bs-header-lines-length 2
 266   "Number of lines for headers in Buffer Selection Menu.")
 267
 268 (defcustom bs-configurations
 269   '(("all" nil nil nil nil nil)
 270     ("files" nil nil nil bs-visits-non-file bs-sort-buffer-interns-are-last)
 271     ("files-and-scratch" "^\\*scratch\\*" nil nil bs-visits-non-file
 272      bs-sort-buffer-interns-are-last)
 273     ("all-intern-last" nil nil nil nil bs-sort-buffer-interns-are-last))
 274   "*List of all configurations you can use in the Buffer Selection Menu.
 275 A configuration describes which buffers appear in Buffer Selection Menu
 276 and describes the order of buffers.  A configuration is a list with
 277 six elements.  The first element is a string and describes the configuration.
 278 The following five elements represent the values for Buffer Selection Menu
 279 configurations variables `bs-dont-show-regexp', `bs-dont-show-function',
 280 `bs-must-show-regexp', `bs-must-show-function' and `bs-buffer-sort-function'.
 281 By setting these variables you define a configuration."
 282   :group 'bs-appearence
 283   :type '(repeat sexp))
 284
 285 (defcustom bs-default-configuration "files"
 286   "*Name of default configuration used by in the Buffer Selection Menu.
 287 \\<bs-mode-map>
 288 Will be changed using key \\[bs-select-next-configuration].
 289 Must be a string used in `bs-configurations' for naming a configuration."
 290   :group 'bs
 291   :type 'string)
 292
 293 (defcustom bs-alternative-configuration "all"
 294   "*Name of configuration used when calling `bs-show' with \
 295 \\[universal-argument] as prefix key.
 296 Must be a string used in `bs-configurations' for naming a configuration."
 297   :group 'bs
 298   :type  'string)
 299
 300 (defvar bs-current-configuration bs-default-configuration
 301   "Name of current configuration.
 302 Must be a string found in `bs-configurations' for naming a configuration.")
 303
 304 (defcustom bs-cycle-configuration-name nil
 305   "*Name of configuration used when cycling through the buffer list.
 306 A value of nil means to use current configuration `bs-default-configuration'.
 307 Must be a string used in `bs-configurations' for naming a configuration."
 308   :group 'bs
 309   :type '(choice (const :tag "like current configuration" nil)
 310    string))
 311
 312 (defcustom bs-string-show-always "+"
 313   "*String added in column 1 indicating a buffer will always be shown."
 314   :group 'bs-appearence
 315   :type 'string)
 316
 317 (defcustom bs-string-show-never "-"
 318   "*String added in column 1 indicating a buffer will never be shown."
 319   :group 'bs-appearence
 320   :type 'string)
 321
 322 (defcustom bs-string-current "."
 323   "*String added in column 1 indicating the current buffer."
 324   :group 'bs-appearence
 325   :type 'string)
 326
 327 (defcustom bs-string-current-marked "#"
 328   "*String added in column 1 indicating the current buffer when it is marked."
 329   :group 'bs-appearence
 330   :type 'string)
 331
 332 (defcustom bs-string-marked ">"
 333   "*String added in column 1 indicating a marked buffer."
 334   :group 'bs-appearence
 335   :type 'string)
 336
 337 (defcustom bs-string-show-normally  " "
 338   "*String added in column 1 indicating a unmarked buffer."
 339   :group 'bs-appearence
 340   :type 'string)
 341
 342 (defvar bs--name-entry-length 20
 343   "Maximum length of all displayed buffer names.
 344 Used internally, only.")
 345
 346 ;; ----------------------------------------------------------------------
 347 ;; Intern globals
 348 ;; ----------------------------------------------------------------------
 349
 350 (defvar bs-buffer-show-mark nil
 351   "Flag for the current mode for showing this buffer.
 352 A value of nil means buffer will be shown depending on the current on
 353 current configuration.
 354 A value of `never' means to never show the buffer.
 355 A value of `always' means to show buffer regardless of the configuration.")
 356
 357 (make-variable-buffer-local 'bs-buffer-show-mark)
 358
 359 ;; Make face named region (for XEmacs)
 360 (unless (facep 'region)
 361   (make-face 'region)
 362   (set-face-background 'region "gray75"))
 363
 364
 365 (defun bs--sort-by-name (b1 b2)
 366   "Compare buffers B1 and B2 by buffer name."
 367   (string< (buffer-name b1)
 368     (buffer-name b2)))
 369
 370 (defun bs--sort-by-filename (b1 b2)
 371   "Compare buffers B1 and B2 by file name."
 372   (string< (or (buffer-file-name b1) "")
 373     (or (buffer-file-name b2) "")))
 374
 375 (defun bs--sort-by-mode (b1 b2)
 376   "Compare buffers B1 and B2 by mode name."
 377   (save-excursion
 378     (string< (progn (set-buffer b1) (format "%s" mode-name))
 379       (progn (set-buffer b2) (format "%s" mode-name)))))
 380
 381 (defun bs--sort-by-size (b1 b2)
 382   "Compare buffers B1 and B2 by buffer size."
 383   (save-excursion
 384     (< (progn (set-buffer b1) (buffer-size))
 385        (progn (set-buffer b2) (buffer-size)))))
 386
 387 (defcustom bs-sort-functions
 388   '(("by name"     bs--sort-by-name     "Buffer" region)
 389     ("by size"     bs--sort-by-size     "Size"   region)
 390     ("by mode"     bs--sort-by-mode     "Mode"   region)
 391     ("by filename" bs--sort-by-filename "File"   region)
 392     ("by nothing"  nil                  nil      nil))
 393   "*List of all possible sorting aspects for Buffer Selection Menu.
 394 You can add a new entry with a call to `bs-define-sort-function'.
 395 Each element is a list of four elements (NAME FUNCTION REGEXP-FOR-SORTING FACE)
 396 NAME specifies the sort order defined by function FUNCTION.
 397 FUNCTION nil means don't sort the buffer list.  Otherwise the functions
 398 must have two parameters - the buffers to compare.
 399 REGEXP-FOR-SORTING is a regular expression which describes the
 400 column title to highlight.
 401 FACE is a face used to fontify the sorted column title.  A value of nil means
 402 don't highlight."
 403   :group 'bs
 404   :type '(repeat sexp))
 405
 406 (defun bs-define-sort-function (name fun &optional regexp-for-sorting face)
 407   "Define a new function for buffer sorting in Buffer Selection Menu.
 408 NAME specifies the sort order defined by function FUN.
 409 A value of nil for FUN means don't sort the buffer list.  Otherwise the
 410 functions must have two parameters - the buffers to compare.
 411 REGEXP-FOR-SORTING is a regular expression which describes the
 412 column title to highlight.
 413 FACE is a face used to fontify the sorted column title.  A value of nil means
 414 don't highlight.
 415 The new sort aspect will be inserted into list `bs-sort-functions'."
 416   (let ((tupel (assoc name bs-sort-functions)))
 417     (if tupel
 418  (setcdr tupel (list fun regexp-for-sorting face))
 419       (setq bs-sort-functions
 420      (cons (list name fun regexp-for-sorting face)
 421     bs-sort-functions)))))
 422
 423 (defvar bs--current-sort-function nil
 424   "Description of the current function for sorting the buffer list.
 425 This is an element of `bs-sort-functions'.")
 426
 427 (defcustom bs-default-sort-name "by nothing"
 428   "*Name of default sort behavior.
 429 Must be \"by nothing\" or a string used in `bs-sort-functions' for
 430 naming a sort behavior.  Default is \"by nothing\" which means no sorting."
 431   :group 'bs
 432   :type  'string
 433   :set (lambda (var-name value)
 434   (set var-name value)
 435   (setq bs--current-sort-function
 436         (assoc value bs-sort-functions))))
 437
 438 (defvar bs--buffer-coming-from nil
 439   "The buffer in which the user started the current Buffer Selection Menu.")
 440
 441 (defvar bs--show-all nil
 442   "Flag whether showing all buffers regardless of current configuration.
 443 Non nil means to show all buffers.  Otherwise show buffers
 444 defined by current configuration `bs-current-configuration'.")
 445
 446 (defvar bs--window-config-coming-from nil
 447   "Window configuration before starting Buffer Selection Menu.")
 448
 449 (defvar bs--intern-show-never "^ \\|\\*buffer-selection\\*"
 450   "Regular expression specifying which buffers never to show.
 451 A buffer whose name matches this regular expression will never be
 452 included in the buffer list.")
 453
 454 (defvar bs-current-list nil
 455   "List of buffers shown in Buffer Selection Menu.
 456 Used internally, only.")
 457
 458 (defvar bs--marked-buffers nil
 459   "Currently marked buffers in Buffer Selection Menu.")
 460
 461 (defvar bs-mode-map ()
 462   "Keymap of `bs-mode'.")
 463
 464 (if bs-mode-map
 465     ()
 466   (setq bs-mode-map (make-sparse-keymap))
 467   (define-key bs-mode-map " "       'bs-select)
 468   (define-key bs-mode-map "f"       'bs-select)
 469   (define-key bs-mode-map "v"       'bs-view)
 470   (define-key bs-mode-map "!"       'bs-select-in-one-window)
 471   (define-key bs-mode-map [mouse-2] 'bs-mouse-select) ;; for GNU EMACS
 472   (define-key bs-mode-map [button2] 'bs-mouse-select) ;; for XEmacs
 473   (define-key bs-mode-map "F"       'bs-select-other-frame)
 474
 475   (let ((key ?1))
 476     (while (<= key ?9)
 477       (define-key bs-mode-map (char-to-string key) 'digit-argument)
 478       (setq key (1+ key))))
 479
 480   (define-key bs-mode-map "-"       'negative-argument)
 481   (define-key bs-mode-map "\e-"     'negative-argument)
 482
 483   (define-key bs-mode-map "o"       'bs-select-other-window)
 484   (define-key bs-mode-map "\C-o"    'bs-tmp-select-other-window)
 485   ;; for GNU EMACS
 486   (define-key bs-mode-map [mouse-3] 'bs-mouse-select-other-frame)
 487   ;; for XEmacs
 488   (define-key bs-mode-map [button3] 'bs-mouse-select-other-frame)
 489   (define-key bs-mode-map [up]      'bs-up)
 490   (define-key bs-mode-map "n"       'bs-down)
 491   (define-key bs-mode-map "p"       'bs-up)
 492   (define-key bs-mode-map [down]    'bs-down)
 493   (define-key bs-mode-map "\C-m"    'bs-select)
 494   (define-key bs-mode-map "b"       'bs-bury-buffer)
 495   (define-key bs-mode-map "s"       'bs-save)
 496   (define-key bs-mode-map "S"       'bs-show-sorted)
 497   (define-key bs-mode-map "a"       'bs-toggle-show-all)
 498   (define-key bs-mode-map "d"       'bs-delete)
 499   (define-key bs-mode-map "\C-d"    'bs-delete-backward)
 500   (define-key bs-mode-map "k"       'bs-delete)
 501   (define-key bs-mode-map "g"       'bs-refresh)
 502   (define-key bs-mode-map "C"       'bs-set-configuration-and-refresh)
 503   (define-key bs-mode-map "c"       'bs-select-next-configuration)
 504   (define-key bs-mode-map "q"       'bs-kill)
 505   ;; (define-key bs-mode-map "z"       'bs-kill)
 506   (define-key bs-mode-map "\C-c\C-c" 'bs-kill)
 507   (define-key bs-mode-map "\C-g"    'bs-abort)
 508   (define-key bs-mode-map "\C-]"    'bs-abort)
 509   (define-key bs-mode-map "%"       'bs-toggle-readonly)
 510   (define-key bs-mode-map "~"       'bs-clear-modified)
 511   (define-key bs-mode-map "M"       'bs-toggle-current-to-show)
 512   (define-key bs-mode-map "+"       'bs-set-current-buffer-to-show-always)
 513   ;;(define-key bs-mode-map "-"       'bs-set-current-buffer-to-show-never)
 514   (define-key bs-mode-map "t"       'bs-visit-tags-table)
 515   (define-key bs-mode-map "m"       'bs-mark-current)
 516   (define-key bs-mode-map "u"       'bs-unmark-current)
 517   (define-key bs-mode-map ">"       'scroll-right)
 518   (define-key bs-mode-map "<"       'scroll-left)
 519   (define-key bs-mode-map "\e\e"    nil)
 520   (define-key bs-mode-map "\e\e\e"  'bs-kill)
 521   (define-key bs-mode-map [escape escape escape] 'bs-kill)
 522   (define-key bs-mode-map "?"       'bs-help))
 523
 524 ;; ----------------------------------------------------------------------
 525 ;; Functions
 526 ;; ----------------------------------------------------------------------
 527
 528 (defun bs-buffer-list (&optional list sort-description)
 529   "Return a list of buffers to be shown.
 530 LIST is a list of buffers to test for appearence in Buffer Selection Menu.
 531 The result list depends on the global variables `bs-dont-show-regexp',
 532 `bs-must-show-regexp', `bs-dont-show-function', `bs-must-show-function'
 533 and `bs-buffer-sort-function'.
 534 If SORT-DESCRIPTION isn't nil the list will be sorted by
 535 a special function.  SORT-DESCRIPTION is an element of `bs-sort-functions'."
 536   (setq sort-description (or sort-description bs--current-sort-function)
 537  list (or list (buffer-list)))
 538   (let ((result nil))
 539     (while list
 540       (let* ((buffername (buffer-name (car list)))
 541       (int-show-never (string-match bs--intern-show-never buffername))
 542       (ext-show-never (and bs-dont-show-regexp
 543          (string-match bs-dont-show-regexp
 544          buffername)))
 545       (extern-must-show (or (and bs-must-always-show-regexp
 546      (string-match bs-must-always-show-regexp
 547             buffername))
 548        (and bs-must-show-regexp
 549      (string-match bs-must-show-regexp
 550             buffername))))
 551       (extern-show-never-from-fun (and bs-dont-show-function
 552            (funcall bs-dont-show-function
 553              (car list))))
 554       (extern-must-show-from-fun (and bs-must-show-function
 555           (funcall bs-must-show-function
 556             (car list))))
 557       (show-flag (save-excursion
 558      (set-buffer (car list))
 559      bs-buffer-show-mark)))
 560  (if (or (eq show-flag 'always)
 561   (and (or bs--show-all (not (eq show-flag 'never)))
 562        (not int-show-never)
 563        (or bs--show-all
 564     extern-must-show
 565     extern-must-show-from-fun
 566     (and (not ext-show-never)
 567          (not extern-show-never-from-fun)))))
 568      (setq result (cons (car list)
 569           result)))
 570  (setq list (cdr list))))
 571     (setq result (reverse result))
 572     ;; The current buffer which was the start point of bs should be an element
 573     ;; of result list, so that we can leave with space and be back in the
 574     ;; buffer we started bs-show.
 575     (if (and bs--buffer-coming-from
 576       (buffer-live-p bs--buffer-coming-from)
 577       (not (memq bs--buffer-coming-from result)))
 578  (setq result (cons bs--buffer-coming-from result)))
 579     ;; sorting
 580     (if (and sort-description
 581       (nth 1 sort-description))
 582  (setq result (sort result (nth 1 sort-description)))
 583       ;; else standard sorting
 584       (bs-buffer-sort result))))
 585
 586 (defun bs-buffer-sort (buffer-list)
 587   "Sort buffers in BUFFER-LIST according to `bs-buffer-sort-function'."
 588   (if bs-buffer-sort-function
 589       (sort buffer-list bs-buffer-sort-function)
 590     buffer-list))
 591
 592 (defun bs--redisplay (&optional keep-line-p sort-description)
 593   "Redisplay whole Buffer Selection Menu.
 594 If KEEP-LINE-P is non nil the point will stay on current line.
 595 SORT-DESCRIPTION is an element of `bs-sort-functions'"
 596   (let ((line (1+ (count-lines 1 (point)))))
 597     (bs-show-in-buffer (bs-buffer-list nil sort-description))
 598     (if keep-line-p
 599  (goto-line line))
 600     (beginning-of-line)))
 601
 602 (defun bs--goto-current-buffer ()
 603   "Goto line which represents the current buffer;
 604 actually the line which begins with character in `bs-string-current' or
 605 `bs-string-current-marked'."
 606   (let (point
 607  (regexp (concat "^"
 608    (regexp-quote bs-string-current)
 609    "\\|^"
 610    (regexp-quote bs-string-current-marked))))
 611     (save-excursion
 612       (goto-char (point-min))
 613       (if (search-forward-regexp regexp nil t)
 614    (setq point (- (point) 1))))
 615     (if point
 616  (goto-char point))))
 617
 618 (defun bs--current-config-message ()
 619   "Return a string describing the current `bs-mode' configuration."
 620   (if bs--show-all
 621       "Show all buffers."
 622     (format "Show buffer by configuration %S"
 623      bs-current-configuration)))
 624
 625 (defun bs-mode ()
 626   "Major mode for editing a subset of Emacs' buffers.
 627 \\<bs-mode-map>
 628 Aside from two header lines each line describes one buffer.
 629 Move to a line representing the buffer you want to edit and select
 630 buffer by \\[bs-select] or SPC. Abort buffer list with \\[bs-kill].
 631 There are many key commands similar to `Buffer-menu-mode' for
 632 manipulating the buffer list and buffers.
 633 For faster navigation each digit key is a digit argument.
 634
 635 \\[bs-select] or SPACE -- select current line's buffer and other marked buffers.
 636 \\[bs-toggle-show-all]  -- toggle between all buffers and a special subset.
 637 \\[bs-select-other-window] -- select current line's buffer in other window.
 638 \\[bs-tmp-select-other-window] -- make another window display that buffer and
 639     remain in Buffer Selection Menu.
 640 \\[bs-mouse-select] -- select current line's buffer and other marked buffers.
 641 \\[bs-save] -- save current line's buffer immediatly.
 642 \\[bs-delete] -- kill current line's buffer immediatly.
 643 \\[bs-toggle-readonly] -- toggle read-only status of current line's buffer.
 644 \\[bs-clear-modified] -- clear modified-flag on that buffer.
 645 \\[bs-mark-current] -- mark current line's buffer to be displayed.
 646 \\[bs-unmark-current] -- unmark current line's buffer to be displayed.
 647 \\[bs-show-sorted] -- display buffer list sorted by next sort aspect.
 648 \\[bs-set-configuration-and-refresh] -- ask user for a configuration and \
 649 apply selected configuration.
 650 \\[bs-select-next-configuration] -- select and apply next \
 651 available Buffer Selection Menu configuration.
 652 \\[bs-kill] -- leave Buffer Selection Menu without a selection.
 653 \\[bs-toggle-current-to-show] -- toggle status of appearence .
 654 \\[bs-set-current-buffer-to-show-always] -- mark current line's buffer \
 655 to show always.
 656 \\[bs-visit-tags-table] -- call `visit-tags-table' on current line'w buffer.
 657 \\[bs-help] -- display this help text."
 658   (interactive)
 659   (kill-all-local-variables)
 660   (use-local-map bs-mode-map)
 661   (make-local-variable 'font-lock-defaults)
 662   (make-local-variable 'font-lock-verbose)
 663   (setq major-mode 'bs-mode
 664  mode-name "Buffer-Selection-Menu"
 665  buffer-read-only t
 666  truncate-lines t
 667  font-lock-defaults '(bs-mode-font-lock-keywords t)
 668  font-lock-verbose nil)
 669   (run-hooks 'bs-mode-hook))
 670
 671 (defun bs-kill ()
 672   "Let buffer disappear and reset window-configuration."
 673   (interactive)
 674   (bury-buffer (current-buffer))
 675   (set-window-configuration bs--window-config-coming-from))
 676
 677 (defun bs-abort ()
 678   "Ding and leave Buffer Selection Menu without a selection."
 679  (interactive)
 680   (ding)
 681   (bs-kill))
 682
 683 (defun bs-set-configuration-and-refresh ()
 684   "Ask user for a configuration and apply selected configuration.
 685 Refresh whole Buffer Selection Menu."
 686   (interactive)
 687   (call-interactively 'bs-set-configuration)
 688   (bs--redisplay t))
 689
 690 (defun bs-refresh ()
 691   "Refresh whole Buffer Selection Menu."
 692   (interactive)
 693   (bs--redisplay t))
 694
 695 (defun bs--window-for-buffer (buffer-name)
 696   "Return a window showing a buffer with name BUFFER-NAME.
 697 Take only windows of current frame into account.
 698 Return nil if there is no such buffer."
 699   (let ((window nil))
 700     (walk-windows (lambda (wind)
 701       (if (string= (buffer-name (window-buffer wind))
 702      buffer-name)
 703    (setq window wind))))
 704     window))
 705
 706 (defun bs--set-window-height ()
 707   "Change the height of the selected window to suit the current buffer list."
 708   (unless (one-window-p t)
 709     (shrink-window (- (window-height (selected-window))
 710         ;; window-height in xemacs includes mode-line
 711         (+ (if bs--running-in-xemacs 3 1)
 712     bs-header-lines-length
 713     (min (length bs-current-list)
 714          bs-max-window-height))))))
 715
 716 (defun bs--current-buffer ()
 717   "Return buffer on current line.
 718 Raise an error if not an a buffer line."
 719   (beginning-of-line)
 720   (let ((line (+ (- bs-header-lines-length)
 721    (count-lines 1 (point)))))
 722     (if (< line 0)
 723  (error "You are on a header row"))
 724     (nth line bs-current-list)))
 725
 726 (defun bs--update-current-line ()
 727   "Update the entry on current line for Buffer Selection Menu."
 728   (let ((buffer (bs--current-buffer))
 729  (inhibit-read-only t))
 730     (beginning-of-line)
 731     (delete-region (point) (line-end-position))
 732     (bs--insert-one-entry buffer)
 733     (beginning-of-line)))
 734
 735 (defun bs-view ()
 736   "View current line's buffer in View mode.
 737 Leave Buffer Selection Menu."
 738   (interactive)
 739   (view-buffer (bs--current-buffer)))
 740
 741 (defun bs-select ()
 742   "Select current line's buffer and other marked buffers.
 743 If there are no marked buffers the window configuration before starting
 744 Buffer Selectin Menu will be restored.
 745 If there are marked buffers each marked buffer and the current line's buffer
 746 will be selected in a window.
 747 Leave Buffer Selection Menu."
 748   (interactive)
 749   (let ((buffer (bs--current-buffer)))
 750     (bury-buffer (current-buffer))
 751     (set-window-configuration bs--window-config-coming-from)
 752     (switch-to-buffer buffer)
 753     (if bs--marked-buffers
 754  ;; Some marked buffers for selection
 755  (let* ((all (delq buffer bs--marked-buffers))
 756         (height (/ (1- (frame-height)) (1+ (length all)))))
 757    (delete-other-windows)
 758    (switch-to-buffer buffer)
 759    (while all
 760      (split-window nil height)
 761      (other-window 1)
 762      (switch-to-buffer (car all))
 763      (setq all (cdr all)))
 764    ;; goto window we have started bs.
 765    (other-window 1)))))
 766
 767 (defun bs-select-other-window ()
 768   "Select current line's buffer by `switch-to-buffer-other-window'.
 769 The window configuration before starting Buffer Selectin Menu will be restored
 770 unless there is no other window.  In this case a new window will be created.
 771 Leave Buffer Selection Menu."
 772   (interactive)
 773   (let ((buffer (bs--current-buffer)))
 774     (bury-buffer (current-buffer))
 775     (set-window-configuration bs--window-config-coming-from)
 776     (switch-to-buffer-other-window buffer)))
 777
 778 (defun bs-tmp-select-other-window ()
 779   "Make the other window select this line's buffer.
 780 The current window remains selected."
 781   (interactive)
 782   (let ((buffer (bs--current-buffer)))
 783     (display-buffer buffer t)))
 784
 785 (defun bs-select-other-frame ()
 786   "Select current line's buffer in new created frame.
 787 Leave Buffer Selection Menu."
 788   (interactive)
 789   (let ((buffer (bs--current-buffer)))
 790     (bury-buffer (current-buffer))
 791     (set-window-configuration bs--window-config-coming-from)
 792     (switch-to-buffer-other-frame buffer)))
 793
 794 (defun bs-mouse-select-other-frame (event)
 795   "Select selected line's buffer in new created frame.
 796 Leave Buffer Selection Menu.
 797 EVENT: a mouse click EVENT."
 798   (interactive "e")
 799   (mouse-set-point event)
 800   (bs-select-other-frame))
 801
 802 (defun bs-mouse-select (event)
 803   "Select buffer on mouse click EVENT.
 804 Select buffer by `bs-select'."
 805   (interactive "e")
 806   (mouse-set-point event)
 807   (bs-select))
 808
 809 (defun bs-select-in-one-window ()
 810   "Select current line's buffer in one window and delete other windows.
 811 Leave Buffer Selection Menu."
 812   (interactive)
 813   (bs-select)
 814   (delete-other-windows))
 815
 816 (defun bs-bury-buffer ()
 817   "Bury buffer on current line."
 818   (interactive)
 819   (bury-buffer (bs--current-buffer))
 820   (bs--redisplay t))
 821
 822 (defun bs-save ()
 823   "Save buffer on current line."
 824   (interactive)
 825   (let ((buffer (bs--current-buffer)))
 826     (save-excursion
 827       (set-buffer buffer)
 828       (save-buffer))
 829     (bs--update-current-line)))
 830
 831 (defun bs-visit-tags-table ()
 832   "Visit the tags table in the buffer on this line.
 833 See `visit-tags-table'."
 834   (interactive)
 835   (let ((file (buffer-file-name (bs--current-buffer))))
 836     (if file
 837  (visit-tags-table file)
 838       (error "Specified buffer has no file"))))
 839
 840 (defun bs-toggle-current-to-show ()
 841   "Toggle status of showing flag for buffer in current line."
 842   (interactive)
 843   (let ((buffer (bs--current-buffer))
 844  res)
 845     (save-excursion
 846       (set-buffer buffer)
 847       (setq res (cond ((null bs-buffer-show-mark)
 848          'never)
 849         ((eq bs-buffer-show-mark 'never)
 850          'always)
 851         (t nil)))
 852       (setq bs-buffer-show-mark res))
 853     (bs--update-current-line)
 854     (bs--set-window-height)
 855     (bs--show-config-message res)))
 856
 857 (defun bs-set-current-buffer-to-show-always (&optional not-to-show-p)
 858   "Toggle status of buffer on line to `always shown'.
 859 NOT-TO-SHOW-P: prefix argument.
 860 With no prefix argument the buffer on current line is marked to show
 861 always.  Otherwise it is marked to show never."
 862   (interactive "P")
 863   (if not-to-show-p
 864       (bs-set-current-buffer-to-show-never)
 865     (bs--set-toggle-to-show (bs--current-buffer) 'always)))
 866
 867 (defun bs-set-current-buffer-to-show-never ()
 868   "Toggle status of buffer on line to `never shown'."
 869   (interactive)
 870   (bs--set-toggle-to-show (bs--current-buffer) 'never))
 871
 872 (defun bs--set-toggle-to-show (buffer what)
 873   "Set value `bs-buffer-show-mark' of buffer BUFFER to WHAT.
 874 Redisplay current line and display a message describing
 875 the status of buffer on current line."
 876   (save-excursion
 877     (set-buffer buffer)
 878     (setq bs-buffer-show-mark what))
 879   (bs--update-current-line)
 880   (bs--set-window-height)
 881   (bs--show-config-message what))
 882
 883 (defun bs-mark-current (count)
 884   "Mark buffers.
 885 COUNT is the number of buffers to mark.
 886 Move cursor vertically down COUNT lines."
 887   (interactive "p")
 888   (let ((dir (if (> count 0) 1 -1))
 889  (count (abs count)))
 890     (while (> count 0)
 891       (let ((buffer (bs--current-buffer)))
 892  (if buffer
 893      (setq bs--marked-buffers (cons buffer bs--marked-buffers)))
 894  (bs--update-current-line)
 895  (bs-down dir))
 896       (setq count (1- count)))))
 897
 898 (defun bs-unmark-current (count)
 899   "Unmark buffers.
 900 COUNT is the number of buffers to unmark.
 901 Move cursor vertically down COUNT lines."
 902   (interactive "p")
 903   (let ((dir (if (> count 0) 1 -1))
 904  (count (abs count)))
 905     (while (> count 0)
 906       (let ((buffer (bs--current-buffer)))
 907  (if buffer
 908      (setq bs--marked-buffers (delq buffer bs--marked-buffers)))
 909  (bs--update-current-line)
 910  (bs-down dir))
 911       (setq count (1- count)))))
 912
 913 (defun bs--show-config-message (what)
 914   "Show message indicating the new showing status WHAT.
 915 WHAT is a value of nil, `never', or `always'."
 916   (bs-message-without-log (cond ((null what)
 917      "Buffer will be shown normally.")
 918     ((eq what 'never)
 919      "Mark buffer to never be shown.")
 920     (t "Mark buffer to show always."))))
 921
 922 (defun bs-delete ()
 923   "Kill buffer on current line."
 924   (interactive)
 925   (let ((current (bs--current-buffer))
 926  (inhibit-read-only t))
 927     (setq bs-current-list (delq current bs-current-list))
 928     (kill-buffer current)
 929     (beginning-of-line)
 930     (delete-region (point) (save-excursion
 931         (end-of-line)
 932         (if (eobp) (point) (1+ (point)))))
 933     (if (eobp)
 934  (progn
 935    (backward-delete-char 1)
 936    (beginning-of-line)
 937    (recenter -1)))
 938     (bs--set-window-height)))
 939
 940 (defun bs-delete-backward ()
 941   "Like `bs-delete' but go to buffer in front of current."
 942   (interactive)
 943   (let ((on-last-line-p (save-excursion (end-of-line) (eobp))))
 944     (bs-delete)
 945     (unless on-last-line-p
 946  (bs-up 1))))
 947
 948 (defun bs-show-sorted ()
 949   "Show buffer list sorted by buffer name."
 950   (interactive)
 951   (setq bs--current-sort-function
 952  (bs-next-config-aux (car bs--current-sort-function)
 953        bs-sort-functions))
 954   (bs--redisplay)
 955   (bs--goto-current-buffer)
 956   (bs-message-without-log "Sorted %s" (car bs--current-sort-function)))
 957
 958 (defun bs-apply-sort-faces (&optional sort-description)
 959   "Set text properties for the sort described by SORT-DESCRIPTION.
 960 SORT-DESCRIPTION is an element of `bs-sort-functions'.
 961 Default is `bs--current-sort-function'."
 962   (let ((sort-description (or sort-description
 963          bs--current-sort-function)))
 964     (save-excursion
 965       (goto-char (point-min))
 966       (if (and window-system
 967         (nth 2 sort-description)
 968         (search-forward-regexp (nth 2 sort-description) nil t))
 969    (let ((inhibit-read-only t))
 970      (put-text-property (match-beginning 0)
 971           (match-end 0)
 972           'face
 973           (or (nth 3 sort-description)
 974        'region)))))))
 975
 976 (defun bs-toggle-show-all ()
 977   "Toggle show all buffers / show buffers with current configuration."
 978   (interactive)
 979   (setq bs--show-all (not bs--show-all))
 980   (bs--redisplay)
 981   (bs--goto-current-buffer)
 982   (bs-message-without-log "%s" (bs--current-config-message)))
 983
 984 (defun bs-toggle-readonly ()
 985   "Toggle read-only status for buffer on current line.
 986 Uses Function `vc-toggle-read-only'."
 987   (interactive)
 988   (let ((buffer (bs--current-buffer)))
 989     (save-excursion
 990       (set-buffer buffer)
 991       (vc-toggle-read-only))
 992     (bs--update-current-line)))
 993
 994 (defun bs-clear-modified ()
 995   "Set modified flag for buffer on current line to nil."
 996   (interactive)
 997   (let ((buffer (bs--current-buffer)))
 998     (save-excursion
 999       (set-buffer buffer)
1000       (set-buffer-modified-p nil)))
1001   (bs--update-current-line))
1002
1003 (defun bs--nth-wrapper (count fun &rest args)
1004   "Call COUNT times function FUN with arguments ARGS."
1005   (setq count (or count 1))
1006   (while (> count 0)
1007     (apply fun args)
1008     (setq count (1- count))))
1009
1010 (defun bs-up (arg)
1011   "Move cursor vertically up ARG lines in Buffer Selection Menu."
1012   (interactive "p")
1013   (if (and arg (numberp arg) (< arg 0))
1014       (bs--nth-wrapper (- arg) 'bs--down)
1015     (bs--nth-wrapper arg 'bs--up)))
1016
1017 (defun bs--up ()
1018   "Move cursor vertically up one line.
1019 If on top of buffer list go to last line."
1020   (interactive "p")
1021   (previous-line 1)
1022   (if (<= (count-lines 1 (point)) (1- bs-header-lines-length))
1023       (progn
1024  (goto-char (point-max))
1025  (beginning-of-line)
1026  (recenter -1))
1027     (beginning-of-line)))
1028
1029 (defun bs-down (arg)
1030   "Move cursor vertically down ARG lines in Buffer Selection Menu."
1031   (interactive "p")
1032   (if (and arg (numberp arg) (< arg 0))
1033       (bs--nth-wrapper (- arg) 'bs--up)
1034     (bs--nth-wrapper arg 'bs--down)))
1035
1036 (defun bs--down ()
1037   "Move cursor vertically down one line.
1038 If at end of buffer list go to first line."
1039   (let ((last (line-end-position)))
1040     (if (eq last (point-max))
1041  (goto-line (1+ bs-header-lines-length))
1042       (next-line 1))))
1043
1044 (defun bs-visits-non-file (buffer)
1045   "Return t or nil whether BUFFER visits no file.
1046 A value of t means BUFFER belongs to no file.
1047 A value of nil means BUFFER belongs to a file."
1048   (not (buffer-file-name buffer)))
1049
1050 (defun bs-sort-buffer-interns-are-last (b1 b2)
1051   "Function for sorting intern buffers B1 and B2 at the end of all buffers."
1052   (string-match "^\\*" (buffer-name b2)))
1053
1054 ;; ----------------------------------------------------------------------
1055 ;; Configurations:
1056 ;; ----------------------------------------------------------------------
1057
1058 (defun bs-config-clear ()
1059   "*Reset all variables which specify a configuration.
1060 These variables are `bs-dont-show-regexp', `bs-must-show-regexp',
1061 `bs-dont-show-function', `bs-must-show-function' and
1062 `bs-buffer-sort-function'."
1063   (setq bs-dont-show-regexp nil
1064  bs-must-show-regexp nil
1065  bs-dont-show-function nil
1066  bs-must-show-function nil
1067  bs-buffer-sort-function nil))
1068
1069 (defun bs-config--only-files ()
1070   "Define a configuration for showing only buffers visiting a file."
1071   (bs-config-clear)
1072   (setq ;; I want to see *-buffers at the end
1073         bs-buffer-sort-function 'bs-sort-buffer-interns-are-last
1074  ;; Don't show files who don't belong to a file
1075  bs-dont-show-function 'bs-visits-non-file))
1076
1077 (defun bs-config--files-and-scratch ()
1078   "Define a configuration for showing buffer *scratch* and file buffers."
1079   (bs-config-clear)
1080   (setq ;; I want to see *-buffers at the end
1081         bs-buffer-sort-function 'bs-sort-buffer-interns-are-last
1082  ;; Don't show files who don't belong to a file
1083  bs-dont-show-function 'bs-visits-non-file
1084  ;; Show *scratch* buffer.
1085  bs-must-show-regexp "^\\*scratch\\*"))
1086
1087 (defun bs-config--all ()
1088   "Define a configuration for showing all buffers.
1089 Reset all according variables by `bs-config-clear'."
1090   (bs-config-clear))
1091
1092 (defun bs-config--all-intern-last ()
1093   "Define a configuration for showing all buffers.
1094 Intern buffers appear at end of all buffers."
1095   (bs-config-clear)
1096   ;; I want to see *-buffers at the end
1097   (setq bs-buffer-sort-function 'bs-sort-buffer-interns-are-last))
1098
1099 (defun bs-set-configuration (name)
1100   "Set configuration to the one saved under string NAME in `bs-configurations'.
1101 When called interactively ask user for a configuration and apply selected
1102 configuration."
1103   (interactive (list (completing-read "Use configuration: "
1104           bs-configurations
1105           nil
1106           t)))
1107   (let ((list (assoc name bs-configurations)))
1108     (if list
1109  (if (listp list)
1110      (setq bs-current-configuration name
1111     bs-must-show-regexp     (nth 1 list)
1112     bs-must-show-function   (nth 2 list)
1113     bs-dont-show-regexp     (nth 3 list)
1114     bs-dont-show-function   (nth 4 list)
1115     bs-buffer-sort-function (nth 5 list))
1116    ;; for backward compability
1117    (funcall (cdr list)))
1118       ;; else
1119       (ding)
1120       (bs-message-without-log "No bs-configuration named %S." name))))
1121
1122 (defun bs-help ()
1123   "Help for `bs-show'."
1124   (interactive)
1125   (describe-function 'bs-mode))
1126
1127 (defun bs-next-config-aux (start-name list)
1128   "Get the next assoc after START-NAME in list LIST.
1129 Will return the first if START-NAME is at end."
1130   (let ((assocs list)
1131  (length (length list))
1132  pos)
1133     (while (and assocs (not pos))
1134       (if (string= (car (car assocs)) start-name)
1135    (setq pos (- length (length assocs))))
1136       (setq assocs (cdr assocs)))
1137     (setq pos (1+ pos))
1138     (if (eq pos length)
1139  (car list)
1140       (nth pos list))))
1141
1142 (defun bs-next-config (name)
1143   "Return next configuration with respect to configuration with name NAME."
1144   (bs-next-config-aux name bs-configurations))
1145
1146 (defun bs-select-next-configuration (&optional start-name)
1147   "Apply next configuration START-NAME and refresh buffer list.
1148 If START-NAME is nil the current configuration `bs-current-configuration'
1149 will be used."
1150   (interactive)
1151   (let ((config (bs-next-config (or start-name bs-current-configuration))))
1152     (bs-set-configuration (car config))
1153     (setq bs-default-configuration bs-current-configuration)
1154     (bs--redisplay t)
1155     (bs--set-window-height)
1156     (bs-message-without-log "Selected config: %s" (car config))))
1157
1158 (defun bs-show-in-buffer (list)
1159   "Display buffer list LIST in buffer *buffer-selection*.
1160 Select buffer *buffer-selection* and display buffers according to current
1161 configuration `bs-current-configuration'.  Set window height, fontify buffer
1162 and move point to current buffer."
1163   (setq bs-current-list list)
1164   (switch-to-buffer (get-buffer-create "*buffer-selection*"))
1165   (bs-mode)
1166   (let* ((inhibit-read-only t)
1167   (map-fun (lambda (entry)
1168       (length (buffer-name entry))))
1169   (max-length-of-names (apply 'max
1170          (cons 0 (mapcar map-fun list))))
1171   (name-entry-length (min bs-maximal-buffer-name-column
1172      (max bs-minimal-buffer-name-column
1173           max-length-of-names))))
1174     (erase-buffer)
1175     (setq bs--name-entry-length name-entry-length)
1176     (bs--show-header)
1177     (while list
1178       (bs--insert-one-entry (car list))
1179       (insert "\n")
1180       (setq list (cdr list)))
1181     (delete-backward-char 1)
1182     (bs--set-window-height)
1183     (bs--goto-current-buffer)
1184     (font-lock-fontify-buffer)
1185     (bs-apply-sort-faces)))
1186
1187 (defun bs-next-buffer (&optional buffer-list sorting-p)
1188   "Return next buffer and buffer list for buffer cycling in BUFFER-LIST.
1189 Ignore sorting when SORTING-P is nil.
1190 If BUFFER-LIST is nil the result of `bs-buffer-list' will be used as
1191 buffer list.  The result is a cons of normally the second element of
1192 BUFFER-LIST and the buffer list used for buffer cycling."
1193   (let* ((bs--current-sort-function (if sorting-p
1194      bs--current-sort-function))
1195   (bs-buffer-list (or buffer-list (bs-buffer-list))))
1196     (cons (or (car (cdr bs-buffer-list))
1197        (car bs-buffer-list)
1198        (current-buffer))
1199    bs-buffer-list)))
1200
1201 (defun bs-previous-buffer (&optional buffer-list sorting-p)
1202   "Return previous buffer and buffer list for buffer cycling in BUFFER-LIST.
1203 Ignore sorting when SORTING-P is nil.
1204 If BUFFER-LIST is nil the result of `bs-buffer-list' will be used as
1205 buffer list.  The result is a cons of last element of BUFFER-LIST and the
1206 buffer list used for buffer cycling."
1207   (let* ((bs--current-sort-function (if sorting-p
1208      bs--current-sort-function))
1209   (bs-buffer-list (or buffer-list (bs-buffer-list))))
1210     (cons (or (car (last bs-buffer-list))
1211        (current-buffer))
1212    bs-buffer-list)))
1213
1214 (defun bs-message-without-log (&rest args)
1215   "Like `message' but don't log it on the message log.
1216 All arguments ARGS are transfered to function `message'."
1217   (let ((message-log-max nil))
1218     (apply 'message args)))
1219
1220 (defvar bs--cycle-list nil
1221   "Currentyl buffer list used for cycling.")
1222
1223 ;;;###autoload
1224 (defun bs-cycle-next ()
1225   "Select next buffer defined by buffer cycling.
1226 The buffers taking part in buffer cycling are defined
1227 by buffer configuration `bs-cycle-configuration-name'."
1228   (interactive)
1229   (let ((bs--buffer-coming-from (current-buffer))
1230  (bs-dont-show-regexp   bs-dont-show-regexp)
1231  (bs-must-show-regexp   bs-must-show-regexp)
1232  (bs-dont-show-function bs-dont-show-function)
1233  (bs-must-show-function bs-must-show-function)
1234  (bs--show-all          bs--show-all))
1235     (if bs-cycle-configuration-name
1236  (bs-set-configuration bs-cycle-configuration-name))
1237     (let ((bs-buffer-sort-function nil)
1238    (bs--current-sort-function nil))
1239       (let* ((tupel (bs-next-buffer (if (or (eq last-command
1240       'bs-cycle-next)
1241          (eq last-command
1242       'bs-cycle-previous))
1243      bs--cycle-list)))
1244       (next (car tupel))
1245       (cycle-list (cdr tupel)))
1246  (setq bs--cycle-list (append (cdr cycle-list)
1247          (list (car cycle-list))))
1248  (bury-buffer)
1249  (switch-to-buffer next)
1250  (bs-message-without-log "Next buffers: %s"
1251     (or (cdr bs--cycle-list)
1252         "this buffer"))))))
1253
1254
1255 ;;;###autoload
1256 (defun bs-cycle-previous ()
1257   "Select previous buffer defined by buffer cycling.
1258 The buffers taking part in buffer cycling are defined
1259 by buffer configuration `bs-cycle-configuration-name'."
1260   (interactive)
1261   (let ((bs--buffer-coming-from (current-buffer))
1262  (bs-dont-show-regexp   bs-dont-show-regexp)
1263  (bs-must-show-regexp   bs-must-show-regexp)
1264  (bs-dont-show-function bs-dont-show-function)
1265  (bs-must-show-function bs-must-show-function)
1266  (bs--show-all          bs--show-all))
1267     (if bs-cycle-configuration-name
1268  (bs-set-configuration bs-cycle-configuration-name))
1269     (let ((bs-buffer-sort-function nil)
1270    (bs--current-sort-function nil))
1271       (let* ((tupel (bs-previous-buffer (if (or (eq last-command
1272           'bs-cycle-next)
1273       (eq last-command
1274           'bs-cycle-previous))
1275          bs--cycle-list)))
1276       (prev-buffer (car tupel))
1277       (cycle-list (cdr tupel)))
1278  (setq bs--cycle-list (append (last cycle-list)
1279          (reverse (cdr (reverse cycle-list)))))
1280  (switch-to-buffer prev-buffer)
1281  (bs-message-without-log "Previous buffers: %s"
1282     (or (reverse (cdr bs--cycle-list))
1283         "this buffer"))))))
1284
1285 (defun bs--get-value (fun &optional args)
1286   "Apply function FUN with arguments ARGS.
1287 Return result of evaluation.  Will return FUN if FUN is a number
1288 or a string."
1289   (cond ((numberp fun)
1290   fun)
1291  ((stringp fun)
1292   fun)
1293  (t (apply fun args))))
1294
1295 (defun bs--get-marked-string (start-buffer all-buffers)
1296   "Return a string which describes whether current buffer is marked.
1297 START-BUFFER is the buffer where we started buffer selection.
1298 ALL-BUFFERS is the list of buffer appearing in Buffer Selection Menu.
1299 The result string is one of `bs-string-current', `bs-string-current-marked',
1300 `bs-string-marked', `bs-string-show-normally', `bs-string-show-never', or
1301 `bs-string-show-always'."
1302   (cond ;; current buffer is the buffer we started buffer selection.
1303         ((eq (current-buffer) start-buffer)
1304   (if (memq (current-buffer) bs--marked-buffers)
1305       bs-string-current-marked ; buffer is marked
1306     bs-string-current))
1307  ;; current buffer is marked
1308  ((memq (current-buffer) bs--marked-buffers)
1309   bs-string-marked)
1310  ;; current buffer hasn't a special mark.
1311  ((null bs-buffer-show-mark)
1312   bs-string-show-normally)
1313  ;; current buffer has a mark not to show itself.
1314  ((eq bs-buffer-show-mark 'never)
1315   bs-string-show-never)
1316  ;; otherwise current buffer is marked to show always.
1317  (t
1318   bs-string-show-always)))
1319
1320 (defun bs--get-modified-string (start-buffer all-buffers)
1321   "Return a string which describes whether current buffer is modified.
1322 START-BUFFER is the buffer where we started buffer selection.
1323 ALL-BUFFERS is the list of buffer appearing in Buffer Selection Menu."
1324   (if (buffer-modified-p) "*" " "))
1325
1326 (defun bs--get-readonly-string (start-buffer all-buffers)
1327   "Return a string which describes whether current buffer is read only.
1328 START-BUFFER is the buffer where we started buffer selection.
1329 ALL-BUFFERS is the list of buffer appearing in Buffer Selection Menu."
1330   (if buffer-read-only "%" " "))
1331
1332 (defun bs--get-size-string (start-buffer all-buffers)
1333   "Return a string which describes the size of current buffer.
1334 START-BUFFER is the buffer where we started buffer selection.
1335 ALL-BUFFERS is the list of buffer appearing in Buffer Selection Menu."
1336   (int-to-string (buffer-size)))
1337
1338 (defun bs--get-name (start-buffer all-buffers)
1339   "Return name of current buffer for Buffer Selection Menu.
1340 The name of current buffer gets additional text properties
1341 for mouse highlighting.
1342 START-BUFFER is the buffer where we started buffer selection.
1343 ALL-BUFFERS is the list of buffer appearing in Buffer Selection Menu."
1344   (let ((name (copy-sequence (buffer-name))))
1345     (put-text-property 0 (length name) 'mouse-face 'highlight name)
1346     (if (< (length name) bs--name-entry-length)
1347  (concat name
1348   (make-string (- bs--name-entry-length (length name)) ? ))
1349       name)))
1350
1351
1352 (defun bs--get-mode-name (start-buffer all-buffers)
1353   "Return the name of mode of current buffer for Buffer Selection Menu.
1354 START-BUFFER is the buffer where we started buffer selection.
1355 ALL-BUFFERS is the list of buffer appearing in Buffer Selection Menu."
1356   mode-name)
1357
1358 (defun bs--get-file-name (start-buffer all-buffers)
1359   "Return string for column 'File' in Buffer Selection Menu.
1360 This is the variable `buffer-file-name' of current buffer.
1361 If current mode is `dired-mode' or `shell-mode' it returns the
1362 default directory.
1363 START-BUFFER is the buffer where we started buffer selection.
1364 ALL-BUFFERS is the list of buffer appearing in Buffer Selection Menu."
1365   (let ((string (copy-sequence (if (member major-mode
1366         '(shell-mode dired-mode))
1367        default-directory
1368      (or buffer-file-name "")))))
1369     (put-text-property 0 (length string) 'mouse-face 'highlight string)
1370     string))
1371
1372
1373 (defun bs--insert-one-entry (buffer)
1374   "Generate one entry for buffer BUFFER in Buffer Selection Menu.
1375 It goes over all columns described in `bs-attributes-list'
1376 and evaluates corresponding string.  Inserts string in current buffer;
1377 normally *buffer-selection*."
1378   (let ((string "")
1379  (columns bs-attributes-list)
1380  (to-much 0)
1381         (apply-args (append (list bs--buffer-coming-from bs-current-list))))
1382     (save-excursion
1383       (while columns
1384  (set-buffer buffer)
1385  (let ((min   (bs--get-value (nth 1 (car columns))))
1386        ;;(max   (bs--get-value (nth 2 (car columns)))) refered no more
1387        (align (nth 3 (car columns)))
1388        (fun   (nth 4 (car columns)))
1389        (val   nil)
1390        new-string)
1391    (setq val (bs--get-value fun apply-args))
1392    (setq new-string (bs--format-aux val align (- min to-much)))
1393    (setq string (concat string new-string))
1394    (if (> (length new-string) min)
1395        (setq to-much (- (length new-string) min)))
1396    ) ; let
1397  (setq columns (cdr columns))))
1398     (insert string)
1399     string))
1400
1401 (defun bs--format-aux (string align len)
1402   "Generate a string with STRING with alignment ALIGN and length LEN.
1403 ALIGN is one of the symbols `left', `middle', or `right'."
1404   (let ((length (length string)))
1405     (if (>= length len)
1406  string
1407       (if (eq 'right align)
1408    (concat (make-string (- len length) ? ) string)
1409  (concat string (make-string (- len length) ? ))))))
1410
1411 (defun bs--show-header ()
1412   "Insert header for Buffer Selection Menu in current buffer."
1413   (mapcar '(lambda (string)
1414       (insert string "\n"))
1415    (bs--create-header)))
1416
1417 (defun bs--get-name-length ()
1418   "Return value of `bs--name-entry-length'."
1419   bs--name-entry-length)
1420
1421 (defun bs--create-header ()
1422   "Return all header lines used in Buffer Selection Menu as a list of strings."
1423   (list (mapconcat (lambda (column)
1424        (bs--format-aux (bs--get-value (car column))
1425          (nth 3 column) ; align
1426          (bs--get-value (nth 1 column))))
1427      bs-attributes-list
1428      "")
1429  (mapconcat (lambda (column)
1430        (let ((length (length (bs--get-value (car column)))))
1431          (bs--format-aux (make-string length ?-)
1432            (nth 3 column) ; align
1433            (bs--get-value (nth 1 column)))))
1434      bs-attributes-list
1435      "")))
1436
1437 (defun bs--show-with-configuration (name &optional arg)
1438   "Display buffer list of configuration with NAME name.
1439 Set configuration NAME and determine window for Buffer Selection Menu.
1440 Unless current buffer is buffer *buffer-selection* we have to save
1441 the buffer we started Buffer Selection Menu and the current window
1442 configuration to restore buffer and window configuration after a
1443 selection.  If there is already a window displaying *buffer-selection*
1444 select this window for Buffer Selection Menu.  Otherwise open a new
1445 window.
1446 The optional argument ARG is the prefix argument when calling a function
1447 for buffer selection."
1448   (bs-set-configuration name)
1449   (let ((bs--show-all (or bs--show-all arg)))
1450   (unless (string= "*buffer-selection*" (buffer-name))
1451       ;; Only when not in buffer *buffer-selection*
1452       ;; we have to set the buffer we started the command
1453       (progn
1454  (setq bs--buffer-coming-from (current-buffer))
1455  (setq bs--window-config-coming-from (current-window-configuration))))
1456   (let ((liste (bs-buffer-list))
1457  (active-window (bs--window-for-buffer "*buffer-selection*")))
1458     (if active-window
1459  (select-window active-window)
1460       (if (> (window-height (selected-window)) 7)
1461    (progn
1462      (split-window-vertically)
1463      (other-window 1))))
1464     (bs-show-in-buffer liste)
1465     (bs-message-without-log "%s" (bs--current-config-message)))))
1466
1467 (defun bs--configuration-name-for-prefix-arg (prefix-arg)
1468   "Convert prefix argument PREFIX-ARG to a name of a buffer configuration.
1469 If PREFIX-ARG is nil return `bs-default-configuration'.
1470 If PREFIX-ARG is an integer return PREFIX-ARG element of `bs-configurations'.
1471 Otherwise return `bs-alternative-configuration'."
1472   (cond ;; usually activation
1473         ((null prefix-arg)
1474   bs-default-configuration)
1475  ;; call with integer as prefix argument
1476  ((integerp prefix-arg)
1477   (if (and (< 0 prefix-arg) (<= prefix-arg (length bs-configurations)))
1478       (car (nth (1- prefix-arg) bs-configurations))
1479     bs-default-configuration))
1480  ;; call by prefix argument C-u
1481  (t bs-alternative-configuration)))
1482
1483 ;; ----------------------------------------------------------------------
1484 ;; Main function bs-customize and bs-show
1485 ;; ----------------------------------------------------------------------
1486
1487 ;;;###autoload
1488 (defun bs-customize ()
1489   "Customization of group bs for Buffer Selection Menu."
1490   (interactive)
1491   (customize-group "bs"))
1492
1493 ;;;###autoload
1494 (defun bs-show (arg)
1495   "Make a menu of buffers so you can manipulate buffer list or buffers itself.
1496 \\<bs-mode-map>
1497 There are many key commands similar to `Buffer-menu-mode' for
1498 manipulating buffer list and buffers itself.
1499 User can move with [up] or [down], select a buffer
1500 by \\[bs-select] or [SPC]\n
1501 Type \\[bs-kill] to leave Buffer Selection Menu without a selection.
1502 Type \\[bs-help] after invocation to get help on commands available.
1503 With prefix argument ARG show a different buffer list.  Function
1504 `bs--configuration-name-for-prefix-arg' determine accordingly
1505 name of buffer configuration."
1506   (interactive "P")
1507   (setq bs--marked-buffers nil)
1508   (bs--show-with-configuration (bs--configuration-name-for-prefix-arg arg)))
1509
1510 ;;; Now provide feature bs
1511 (provide 'bs)
1512
1513 ;;; bs.el ends here