Now on revision 108144. ------------------------------------------------------------ revno: 108144 committer: Chong Yidong branch nick: trunk timestamp: Mon 2012-05-07 13:37:38 +0800 message: Restore Buffer-menu-use-header-line functionality. * lisp/emacs-lisp/tabulated-list.el: Add no-header-line alternative. (tabulated-list-use-header-line): New var. (tabulated-list-init-header): Use it. (tabulated-list-print-fake-header): New function. (tabulated-list-print): Use it. (tabulated-list-sort-button-map): Add non-header-line commands. (tabulated-list-init-header): Add column name property to basic labels as well. (tabulated-list-col-sort): Handle non-header-line button case. (tabulated-list--sort-by-column-name): Fix a corner case. * lisp/buff-menu.el (list-buffers--refresh): Handle Buffer-menu-use-header-line. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-05-06 16:45:46 +0000 +++ lisp/ChangeLog 2012-05-07 05:37:38 +0000 @@ -1,3 +1,19 @@ +2012-05-07 Chong Yidong + + * emacs-lisp/tabulated-list.el: Add no-header-line alternative. + (tabulated-list-use-header-line): New var. + (tabulated-list-init-header): Use it. + (tabulated-list-print-fake-header): New function. + (tabulated-list-print): Use it. + (tabulated-list-sort-button-map): Add non-header-line commands. + (tabulated-list-init-header): Add column name property to basic + labels as well. + (tabulated-list-col-sort): Handle non-header-line button case. + (tabulated-list--sort-by-column-name): Fix a corner case. + + * buff-menu.el (list-buffers--refresh): Handle + Buffer-menu-use-header-line. + 2012-05-06 Chong Yidong * buff-menu.el: Convert to Tabulated List mode. === modified file 'lisp/buff-menu.el' --- lisp/buff-menu.el 2012-05-06 16:45:46 +0000 +++ lisp/buff-menu.el 2012-05-07 05:37:38 +0000 @@ -574,6 +574,7 @@ `("Size" ,size-width tabulated-list-entry-size->) `("Mode" ,Buffer-menu-mode-width t) '("File" 1 t)))) + (setq tabulated-list-use-header-line Buffer-menu-use-header-line) ;; Collect info for each buffer we're interested in. (let ((buffer-menu-buffer (current-buffer)) (show-non-file (not Buffer-menu-files-only)) === modified file 'lisp/emacs-lisp/tabulated-list.el' --- lisp/emacs-lisp/tabulated-list.el 2012-05-06 16:45:46 +0000 +++ lisp/emacs-lisp/tabulated-list.el 2012-05-07 05:37:38 +0000 @@ -56,6 +56,10 @@ right of the column (defaults to 1 if omitted).") (make-variable-buffer-local 'tabulated-list-format) +(defvar tabulated-list-use-header-line t + "Whether the Tabulated List buffer should use a header line.") +(make-variable-buffer-local 'tabulated-list-use-header-line) + (defvar tabulated-list-entries nil "Entries displayed in the current Tabulated List buffer. This should be either a function, or a list. @@ -154,6 +158,9 @@ (let ((map (make-sparse-keymap))) (define-key map [header-line mouse-1] 'tabulated-list-col-sort) (define-key map [header-line mouse-2] 'tabulated-list-col-sort) + (define-key map [mouse-1] 'tabulated-list-col-sort) + (define-key map [mouse-2] 'tabulated-list-col-sort) + (define-key map "\C-m" 'tabulated-list-sort) (define-key map [follow-link] 'mouse-face) map) "Local keymap for `tabulated-list-mode' sort buttons.") @@ -167,6 +174,9 @@ table) "The `glyphless-char-display' table in Tabulated List buffers.") +(defvar tabulated-list--header-string nil) +(defvar tabulated-list--header-overlay nil) + (defun tabulated-list-init-header () "Set up header line for the Tabulated List buffer." (let ((x (max tabulated-list-padding 0)) @@ -185,7 +195,8 @@ (push (cond ;; An unsortable column - ((not (nth 2 col)) label) + ((not (nth 2 col)) + (propertize label 'tabulated-list-column-name label)) ;; The selected sort column ((equal (car col) (car tabulated-list-sort-key)) (apply 'propertize @@ -197,11 +208,11 @@ " ▲") (t " ▼"))) 'face 'bold - 'tabulated-list-column-name (car col) + 'tabulated-list-column-name label button-props)) ;; Unselected sortable column. (t (apply 'propertize label - 'tabulated-list-column-name (car col) + 'tabulated-list-column-name label button-props))) cols) (if (> pad-right 0) @@ -209,7 +220,22 @@ 'display `(space :align-to ,x) 'face 'fixed-pitch) cols)))) - (setq header-line-format (mapconcat 'identity (nreverse cols) "")))) + (setq cols (apply 'concat (nreverse cols))) + (if tabulated-list-use-header-line + (setq header-line-format cols) + (setq header-line-format nil) + (set (make-local-variable 'tabulated-list--header-string) cols)))) + +(defun tabulated-list-print-fake-header () + "Insert a fake Tabulated List \"header line\" at the start of the buffer." + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (insert tabulated-list--header-string "\n") + (if tabulated-list--header-overlay + (move-overlay tabulated-list--header-overlay (point-min) (point)) + (set (make-local-variable 'tabulated-list--header-overlay) + (make-overlay (point-min) (point)))) + (overlay-put tabulated-list--header-overlay 'face 'underline))) (defun tabulated-list-revert (&rest ignored) "The `revert-buffer-function' for `tabulated-list-mode'. @@ -248,6 +274,8 @@ (setq entry-id (tabulated-list-get-id)) (setq saved-col (current-column))) (erase-buffer) + (unless tabulated-list-use-header-line + (tabulated-list-print-fake-header)) ;; Sort the buffers, if necessary. (when (and tabulated-list-sort-key (car tabulated-list-sort-key)) @@ -391,12 +419,12 @@ "Sort Tabulated List entries by the column of the mouse click E." (interactive "e") (let* ((pos (event-start e)) - (obj (posn-object pos)) - (name (get-text-property (if obj (cdr obj) (posn-point pos)) - 'tabulated-list-column-name - (car obj)))) + (obj (posn-object pos))) (with-current-buffer (window-buffer (posn-window pos)) - (tabulated-list--sort-by-column-name name)))) + (tabulated-list--sort-by-column-name + (get-text-property (if obj (cdr obj) (posn-point pos)) + 'tabulated-list-column-name + (car obj)))))) (defun tabulated-list-sort (&optional n) "Sort Tabulated List entries by the column at point. @@ -409,7 +437,7 @@ (tabulated-list--sort-by-column-name name))) (defun tabulated-list--sort-by-column-name (name) - (when (derived-mode-p 'tabulated-list-mode) + (when (and name (derived-mode-p 'tabulated-list-mode)) ;; Flip the sort order on a second click. (if (equal name (car tabulated-list-sort-key)) (setcdr tabulated-list-sort-key ------------------------------------------------------------ revno: 108143 committer: Chong Yidong branch nick: trunk timestamp: Mon 2012-05-07 00:45:46 +0800 message: * lisp/buff-menu.el: Convert to Tabulated List mode. (Buffer-menu-buffer+size-width): Make obsolete. (Buffer-menu-name-width, Buffer-menu-size-width): New variables. (Buffer-menu-mode-map): Inherit from tabulated-list-mode-map. (Buffer-menu-mode): Derive from tabulated-list-mode. Move command documentation into docstring of buffer-menu. (Buffer-menu-toggle-files-only): Add an informative message. (Buffer-menu-sort): Convert to alias for tabulated-list-sort. (Buffer-menu-buffer, Buffer-menu-beginning, Buffer-menu-mark) (Buffer-menu-unmark, Buffer-menu-backup-unmark) (Buffer-menu-delete, Buffer-menu-save, Buffer-menu-not-modified) (Buffer-menu-execute, Buffer-menu-select) (Buffer-menu-marked-buffers, Buffer-menu-toggle-read-only) (Buffer-menu-bury): Use Tabulated List machinery. (Buffer-menu-mouse-select, Buffer-menu-sort-by-column) (Buffer-menu-sort-button-map, Buffer-menu-make-sort-button): Deleted. (list-buffers--refresh): New function. (list-buffers-noselect): Use it. (tabulated-list-entry-size->, Buffer-menu--pretty-name) (Buffer-menu--pretty-file-name): New helper functions. * lisp/loadup.el: Preload tabulated-list. * lisp/emacs-lisp/tabulated-list.el (tabulated-list-sort): Rename from tabulated-list-sort-column. (tabulated-list-init-header): Add the initial aligning space even if tabulated-list-padding is zero. * src/lisp.mk (lisp): Update. diff: === modified file 'etc/NEWS' --- etc/NEWS 2012-05-06 08:32:37 +0000 +++ etc/NEWS 2012-05-06 16:45:46 +0000 @@ -163,7 +163,7 @@ ** Tabulated List and packages derived from it -*** New command `tabulated-list-sort-column' bound to `S' sorts column +*** New command `tabulated-list-sort', bound to `S', sorts the column at point, or the Nth column if a numeric prefix argument is given. ** Obsolete packages: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-05-06 15:38:30 +0000 +++ lisp/ChangeLog 2012-05-06 16:45:46 +0000 @@ -1,3 +1,34 @@ +2012-05-06 Chong Yidong + + * buff-menu.el: Convert to Tabulated List mode. + (Buffer-menu-buffer+size-width): Make obsolete. + (Buffer-menu-name-width, Buffer-menu-size-width): New variables. + (Buffer-menu-mode-map): Inherit from tabulated-list-mode-map. + (Buffer-menu-mode): Derive from tabulated-list-mode. Move command + documentation into docstring of buffer-menu. + (Buffer-menu-toggle-files-only): Add an informative message. + (Buffer-menu-sort): Convert to alias for tabulated-list-sort. + (Buffer-menu-buffer, Buffer-menu-beginning, Buffer-menu-mark) + (Buffer-menu-unmark, Buffer-menu-backup-unmark) + (Buffer-menu-delete, Buffer-menu-save, Buffer-menu-not-modified) + (Buffer-menu-execute, Buffer-menu-select) + (Buffer-menu-marked-buffers, Buffer-menu-toggle-read-only) + (Buffer-menu-bury): Use Tabulated List machinery. + (Buffer-menu-mouse-select, Buffer-menu-sort-by-column) + (Buffer-menu-sort-button-map, Buffer-menu-make-sort-button): + Deleted. + (list-buffers--refresh): New function. + (list-buffers-noselect): Use it. + (tabulated-list-entry-size->, Buffer-menu--pretty-name) + (Buffer-menu--pretty-file-name): New helper functions. + + * loadup.el: Preload tabulated-list. + + * emacs-lisp/tabulated-list.el (tabulated-list-sort): Rename from + tabulated-list-sort-column. + (tabulated-list-init-header): Add the initial aligning space even + if tabulated-list-padding is zero. + 2012-05-06 Christopher Schmidt * emacs-lisp/cl-macs.el (cl-expr-contains): Handle cons cells === modified file 'lisp/buff-menu.el' --- lisp/buff-menu.el 2012-05-06 08:43:46 +0000 +++ lisp/buff-menu.el 2012-05-06 16:45:46 +0000 @@ -1,4 +1,4 @@ -;;; buff-menu.el --- buffer menu main function and support functions -*- coding:utf-8 -*- +;;; buff-menu.el --- Interface for viewing and manipulating buffers ;; Copyright (C) 1985-1987, 1993-1995, 2000-2012 ;; Free Software Foundation, Inc. @@ -24,44 +24,13 @@ ;;; Commentary: -;; Edit, delete, or change attributes of all currently active Emacs -;; buffers from a list summarizing their state. A good way to browse -;; any special or scratch buffers you have loaded, since you can't find -;; them by filename. The single entry point is `list-buffers', -;; normally bound to C-x C-b. - -;;; Change Log: - -;; Buffer-menu-view: New function -;; Buffer-menu-view-other-window: New function - -;; Merged by esr with recent mods to Emacs 19 buff-menu, 23 Mar 1993 -;; -;; Modified by Bob Weiner, Motorola, Inc., 4/14/89 -;; -;; Added optional backup argument to 'Buffer-menu-unmark' to make it undelete -;; current entry and then move to previous one. -;; -;; Based on FSF code dating back to 1985. +;; The Buffer Menu is used to view, edit, delete, or change attributes +;; of buffers. The entry points are C-x C-b (`list-buffers') and +;; M-x buffer-menu. ;;; Code: -;;Trying to preserve the old window configuration works well in -;;simple scenarios, when you enter the buffer menu, use it, and exit it. -;;But it does strange things when you switch back to the buffer list buffer -;;with C-x b, later on, when the window configuration is different. -;;The choice seems to be, either restore the window configuration -;;in all cases, or in no cases. -;;I decided it was better not to restore the window config at all. -- rms. - -;;But since then, I changed buffer-menu to use the selected window, -;;so q now once again goes back to the previous window configuration. - -;;(defvar Buffer-menu-window-config nil -;; "Window configuration saved from entry to `buffer-menu'.") - -;; Put buffer *Buffer List* into proper mode right away -;; so that from now on even list-buffers is enough to get a buffer menu. +(require 'tabulated-list) (defgroup Buffer-menu nil "Show a menu of all buffers in a buffer." @@ -69,23 +38,41 @@ :group 'convenience) (defcustom Buffer-menu-use-header-line t - "Non-nil means to use an immovable header-line." + "If non-nil, use the header line to display Buffer Menu column titles." :type 'boolean :group 'Buffer-menu) (defface buffer-menu-buffer '((t (:weight bold))) - "Face used to highlight buffer names in the buffer menu." + "Face for buffer names in the Buffer Menu." :group 'Buffer-menu) (put 'Buffer-menu-buffer 'face-alias 'buffer-menu-buffer) -(defcustom Buffer-menu-buffer+size-width 26 - "How wide to jointly make the buffer name and size columns." - :type 'number - :group 'Buffer-menu) +(defcustom Buffer-menu-buffer+size-width nil + "Combined width of buffer name and size columns in Buffer Menu. +If nil, use `Buffer-menu-name-width' and `Buffer-menu-size-width'." + :type 'number + :group 'Buffer-menu + :version "24.2") + +(make-obsolete-variable 'Buffer-menu-buffer+size-width + "`Buffer-menu-name-width' and `Buffer-menu-size-width'" + "24.2") + +(defcustom Buffer-menu-name-width 19 + "Width of buffer size column in the Buffer Menu." + :type 'number + :group 'Buffer-menu + :version "24.2") + +(defcustom Buffer-menu-size-width 7 + "Width of buffer name column in the Buffer Menu." + :type 'number + :group 'Buffer-menu + :version "24.2") (defcustom Buffer-menu-mode-width 16 - "How wide to make the mode name column." + "Width of mode name column in the Buffer Menu." :type 'number :group 'Buffer-menu) @@ -99,35 +86,19 @@ :group 'Buffer-menu :version "22.1") -;; This should get updated & resorted when you click on a column heading -(defvar Buffer-menu-sort-column nil - "Which column to sort the menu on. -Use 2 to sort by buffer names, or 5 to sort by file names. -A nil value means sort by visited order (the default).") - -(defconst Buffer-menu-buffer-column 4) - (defvar Buffer-menu-files-only nil - "Non-nil if the current buffer-menu lists only file buffers. -This variable determines whether reverting the buffer lists only -file buffers. It affects both manual reverting and reverting by -Auto Revert Mode.") + "Non-nil if the current Buffer Menu lists only file buffers. +This is set by the prefix argument to `buffer-menu' and related +commands.") (make-variable-buffer-local 'Buffer-menu-files-only) -(defvar Buffer-menu--buffers nil - "If non-nil, list of buffers shown in the current buffer-menu. -This variable determines whether reverting the buffer lists only -these buffers. It affects both manual reverting and reverting by -Auto Revert Mode.") -(make-variable-buffer-local 'Buffer-menu--buffers) - -(defvar Info-current-file) ;; from info.el -(defvar Info-current-node) ;; from info.el +(defvar Info-current-file) ; from info.el +(defvar Info-current-node) ; from info.el (defvar Buffer-menu-mode-map - (let ((map (make-keymap)) + (let ((map (make-sparse-keymap)) (menu-map (make-sparse-keymap))) - (suppress-keymap map t) + (set-keymap-parent map tabulated-list-mode-map) (define-key map "v" 'Buffer-menu-select) (define-key map "2" 'Buffer-menu-2-window) (define-key map "1" 'Buffer-menu-1-window) @@ -139,12 +110,10 @@ (define-key map "s" 'Buffer-menu-save) (define-key map "d" 'Buffer-menu-delete) (define-key map "k" 'Buffer-menu-delete) + (define-key map "\C-k" 'Buffer-menu-delete) (define-key map "\C-d" 'Buffer-menu-delete-backwards) - (define-key map "\C-k" 'Buffer-menu-delete) (define-key map "x" 'Buffer-menu-execute) (define-key map " " 'next-line) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) (define-key map "\177" 'Buffer-menu-backup-unmark) (define-key map "~" 'Buffer-menu-not-modified) (define-key map "u" 'Buffer-menu-unmark) @@ -154,10 +123,9 @@ (define-key map "b" 'Buffer-menu-bury) (define-key map "V" 'Buffer-menu-view) (define-key map "T" 'Buffer-menu-toggle-files-only) - (define-key map [mouse-2] 'Buffer-menu-mouse-select) - (define-key map [follow-link] 'mouse-face) (define-key map (kbd "M-s a C-s") 'Buffer-menu-isearch-buffers) (define-key map (kbd "M-s a M-C-s") 'Buffer-menu-isearch-buffers-regexp) + (define-key map [menu-bar Buffer-menu-mode] (cons (purecopy "Buffer-Menu") menu-map)) (define-key menu-map [quit] `(menu-item ,(purecopy "Quit") quit-window @@ -224,142 +192,122 @@ map) "Local keymap for `Buffer-menu-mode' buffers.") -;; Buffer Menu mode is suitable only for specially formatted data. -(put 'Buffer-menu-mode 'mode-class 'special) - -(define-derived-mode Buffer-menu-mode special-mode "Buffer Menu" - "Major mode for editing a list of buffers. -Each line describes one of the buffers in Emacs. -Letters do not insert themselves; instead, they are commands. -\\ -\\[Buffer-menu-mouse-select] -- select buffer you click on, in place of the buffer menu. -\\[Buffer-menu-this-window] -- select current line's buffer in place of the buffer menu. -\\[Buffer-menu-other-window] -- select that buffer in another window, - so the buffer menu buffer remains visible in its window. -\\[Buffer-menu-view] -- select current line's buffer, but in view-mode. -\\[Buffer-menu-view-other-window] -- select that buffer in - another window, in view-mode. -\\[Buffer-menu-switch-other-window] -- make another window display that buffer. -\\[Buffer-menu-mark] -- mark current line's buffer to be displayed. -\\[Buffer-menu-select] -- select current line's buffer. - Also show buffers marked with m, in other windows. -\\[Buffer-menu-1-window] -- select that buffer in full-frame window. -\\[Buffer-menu-2-window] -- select that buffer in one window, - together with buffer selected before this one in another window. -\\[Buffer-menu-isearch-buffers] -- Do incremental search in the marked buffers. -\\[Buffer-menu-isearch-buffers-regexp] -- Isearch for regexp in the marked buffers. -\\[Buffer-menu-visit-tags-table] -- visit-tags-table this buffer. -\\[Buffer-menu-not-modified] -- clear modified-flag on that buffer. -\\[Buffer-menu-save] -- mark that buffer to be saved, and move down. -\\[Buffer-menu-delete] -- mark that buffer to be deleted, and move down. -\\[Buffer-menu-delete-backwards] -- mark that buffer to be deleted, and move up. -\\[Buffer-menu-execute] -- delete or save marked buffers. -\\[Buffer-menu-unmark] -- remove all kinds of marks from current line. - With prefix argument, also move up one line. -\\[Buffer-menu-backup-unmark] -- back up a line and remove marks. -\\[Buffer-menu-toggle-read-only] -- toggle read-only status of buffer on this line. -\\[revert-buffer] -- update the list of buffers. -\\[Buffer-menu-toggle-files-only] -- toggle whether the menu displays only file buffers. -\\[Buffer-menu-bury] -- bury the buffer listed on this line." - (set (make-local-variable 'revert-buffer-function) - 'Buffer-menu-revert-function) +(define-derived-mode Buffer-menu-mode tabulated-list-mode "Buffer Menu" + "Major mode for Buffer Menu buffers. +The Buffer Menu is invoked by the commands \\[list-buffers], \\[buffer-menu], and +\\[buffer-menu-other-window]. See `buffer-menu' for details." (set (make-local-variable 'buffer-stale-function) (lambda (&optional _noconfirm) 'fast)) - (setq truncate-lines t) - (setq buffer-read-only t) - ;; Force L2R direction, to avoid messing the display if the first - ;; buffer in the list happens to begin with a strong R2L character. - (setq bidi-paragraph-direction 'left-to-right)) + (add-hook 'tabulated-list-revert-hook 'list-buffers--refresh nil t)) (define-obsolete-variable-alias 'buffer-menu-mode-hook 'Buffer-menu-mode-hook "23.1") -(defun Buffer-menu-revert-function (_ignore1 _ignore2) - (or (eq buffer-undo-list t) - (setq buffer-undo-list nil)) - ;; We can not use save-excursion here. The buffer gets erased. - (let ((opoint (point)) - (eobp (eobp)) - (ocol (current-column)) - (oline (progn (move-to-column Buffer-menu-buffer-column) - (get-text-property (point) 'buffer))) - (prop (point-min)) - ;; do not make undo records for the reversion. - (buffer-undo-list t)) - ;; We can be called by Auto Revert Mode with the "*Buffer Menu*" - ;; temporarily the current buffer. Make sure that the - ;; interactively current buffer is correctly identified with a `.' - ;; by `list-buffers-noselect'. - (with-current-buffer (window-buffer) - (list-buffers-noselect Buffer-menu-files-only Buffer-menu--buffers)) - (if oline - (while (setq prop (next-single-property-change prop 'buffer)) - (when (eq (get-text-property prop 'buffer) oline) - (goto-char prop) - (move-to-column ocol))) - (goto-char (if eobp (point-max) opoint))))) +(defun buffer-menu (&optional arg) + "Switch to the Buffer Menu. +By default, all buffers are listed except those whose names start +with a space (which are for internal use). With prefix argument +ARG, show only buffers that are visiting files. + +The first column (denoted \"C\") shows \".\" for the buffer from +which you came. It shows \">\" for buffers you mark to be +displayed, and \"D\" for those you mark for deletion. + +The \"R\" column has a \"%\" if the buffer is read-only. +The \"M\" column has a \"*\" if it is modified, or \"S\" if you +have marked it for saving. + +After this come the buffer name, its size in characters, its +major mode, and the visited file name (if any). + + +In the Buffer Menu, the following commands are defined: +\\ +\\[quit-window] Remove the Buffer Menu from the display. +\\[Buffer-menu-this-window] Select current line's buffer in place of the buffer menu. +\\[Buffer-menu-other-window] Select that buffer in another window, + so the Buffer Menu remains visible in its window. +\\[Buffer-menu-view] Select current line's buffer, in View mode. +\\[Buffer-menu-view-other-window] Select that buffer in + another window, in view-mode. +\\[Buffer-menu-switch-other-window] Make another window display that buffer. +\\[Buffer-menu-mark] Mark current line's buffer to be displayed. +\\[Buffer-menu-select] Select current line's buffer. + Also show buffers marked with m, in other windows. +\\[Buffer-menu-1-window] Select that buffer in full-frame window. +\\[Buffer-menu-2-window] Select that buffer in one window, together with the + buffer selected before this one in another window. +\\[Buffer-menu-isearch-buffers] Incremental search in the marked buffers. +\\[Buffer-menu-isearch-buffers-regexp] Isearch for regexp in the marked buffers. +\\[Buffer-menu-visit-tags-table] visit-tags-table this buffer. +\\[Buffer-menu-not-modified] Clear modified-flag on that buffer. +\\[Buffer-menu-save] Mark that buffer to be saved, and move down. +\\[Buffer-menu-delete] Mark that buffer to be deleted, and move down. +\\[Buffer-menu-delete-backwards] Mark that buffer to be deleted, and move up. +\\[Buffer-menu-execute] Delete or save marked buffers. +\\[Buffer-menu-unmark] Remove all marks from current line. + With prefix argument, also move up one line. +\\[Buffer-menu-backup-unmark] Back up a line and remove marks. +\\[Buffer-menu-toggle-read-only] Toggle read-only status of buffer on this line. +\\[revert-buffer] Update the list of buffers. +\\[Buffer-menu-toggle-files-only] Toggle whether the menu displays only file buffers. +\\[Buffer-menu-bury] Bury the buffer listed on this line." + (interactive "P") + (switch-to-buffer (list-buffers-noselect arg)) + (message + "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help.")) + +(defun buffer-menu-other-window (&optional arg) + "Display the Buffer Menu in another window. +See `buffer-menu' for a description of the Buffer Menu. + +By default, all buffers are listed except those whose names start +with a space (which are for internal use). With prefix argument +ARG, show only buffers that are visiting files." + (interactive "P") + (switch-to-buffer-other-window (list-buffers-noselect arg)) + (message + "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help.")) + +(defun list-buffers (&optional arg) + "Display a list of existing buffers. +The list is displayed in a buffer named \"*Buffer List*\". +See `buffer-menu' for details about the Buffer Menu buffer. + +By default, all buffers are listed except those whose names start +with a space (which are for internal use). With prefix argument +ARG, show only buffers that are visiting files." + (interactive "P") + (display-buffer (list-buffers-noselect arg))) (defun Buffer-menu-toggle-files-only (arg) "Toggle whether the current buffer-menu displays only file buffers. -With a positive ARG display only file buffers. With zero or +With a positive ARG, display only file buffers. With zero or negative ARG, display other buffers as well." (interactive "P") (setq Buffer-menu-files-only (cond ((not arg) (not Buffer-menu-files-only)) ((> (prefix-numeric-value arg) 0) t))) + (message (if Buffer-menu-files-only + "Showing only file-visiting buffers." + "Showing all non-internal buffers.")) (revert-buffer)) - -(defun Buffer-menu-buffer (error-if-non-existent-p) - "Return buffer described by this line of buffer menu." - (let* ((where (+ (line-beginning-position) Buffer-menu-buffer-column)) - (name (and (not (eobp)) (get-text-property where 'buffer-name))) - (buf (and (not (eobp)) (get-text-property where 'buffer)))) - (if name - (or (get-buffer name) - (and buf (buffer-name buf) buf) - (if error-if-non-existent-p - (error "No buffer named `%s'" name) - nil)) - (or (and buf (buffer-name buf) buf) - (if error-if-non-existent-p - (error "No buffer on this line") - nil))))) - -(defun buffer-menu (&optional arg) - "Make a menu of buffers so you can save, delete or select them. -With argument, show only buffers that are visiting files. -Type ? after invocation to get help on commands available. -Type q to remove the buffer menu from the display. - -The first column shows `>' for a buffer you have -marked to be displayed, `D' for one you have marked for -deletion, and `.' for the current buffer. - -The C column has a `.' for the buffer from which you came. -The R column has a `%' if the buffer is read-only. -The M column has a `*' if it is modified, -or `S' if you have marked it for saving. -After this come the buffer name, its size in characters, -its major mode, and the visited file name (if any)." - (interactive "P") -;;; (setq Buffer-menu-window-config (current-window-configuration)) - (switch-to-buffer (list-buffers-noselect arg)) - (message - "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help.")) - -(defun buffer-menu-other-window (&optional arg) - "Display a list of buffers in another window. -With the buffer list buffer, you can save, delete or select the buffers. -With argument, show only buffers that are visiting files. -Type ? after invocation to get help on commands available. -Type q to remove the buffer menu from the display. -For more information, see the function `buffer-menu'." - (interactive "P") -;;; (setq Buffer-menu-window-config (current-window-configuration)) - (switch-to-buffer-other-window (list-buffers-noselect arg)) - (message - "Commands: d, s, x, u; f, o, 1, 2, m, v; ~, %%; q to quit; ? for help.")) +(defalias 'Buffer-menu-sort 'tabulated-list-sort) + + +(defun Buffer-menu-buffer (&optional error-if-non-existent-p) + "Return the buffer described by the current Buffer Menu line. +If there is no buffer here, return nil if ERROR-IF-NON-EXISTENT-P +is nil or omitted, and signal an error otherwise." + (let ((buffer (tabulated-list-get-id))) + (cond ((null buffer) + (if error-if-non-existent-p + (error "No buffer on this line"))) + ((not (buffer-live-p buffer)) + (if error-if-non-existent-p + (error "This buffer has been killed"))) + (t buffer)))) (defun Buffer-menu-no-header () (beginning-of-line) @@ -370,166 +318,140 @@ (forward-line 1) nil)) +(defun Buffer-menu-beginning () + (goto-char (point-min)) + (unless Buffer-menu-use-header-line + (forward-line))) + + +;;; Commands for modifying Buffer Menu entries. + (defun Buffer-menu-mark () - "Mark buffer on this line for being displayed by \\\\[Buffer-menu-select] command." + "Mark the Buffer menu entry at point for later display. +It will be displayed by the \\\\[Buffer-menu-select] command." (interactive) - (when (Buffer-menu-no-header) - (let ((inhibit-read-only t)) - (delete-char 1) - (insert ?>) - (forward-line 1)))) + (tabulated-list-set-col 0 ">" t) + (forward-line)) (defun Buffer-menu-unmark (&optional backup) "Cancel all requested operations on buffer on this line and move down. Optional prefix arg means move up." (interactive "P") - (when (Buffer-menu-no-header) - (let* ((buf (Buffer-menu-buffer t)) - (mod (buffer-modified-p buf)) - (readonly (with-current-buffer buf buffer-read-only)) - (inhibit-read-only t)) - (delete-char 3) - (insert (if readonly (if mod " %*" " % ") (if mod " *" " "))))) + (tabulated-list-set-col 0 " " t) (forward-line (if backup -1 1))) (defun Buffer-menu-backup-unmark () "Move up and cancel all requested operations on buffer on line above." (interactive) (forward-line -1) - (Buffer-menu-unmark) - (forward-line -1)) + (tabulated-list-set-col 0 " " t)) (defun Buffer-menu-delete (&optional arg) - "Mark buffer on this line to be deleted by \\\\[Buffer-menu-execute] command. -Prefix arg is how many buffers to delete. -Negative arg means delete backwards." + "Mark the buffer on this Buffer Menu buffer line for deletion. +A subsequent \\`\\[Buffer-menu-execute]' command +will delete it. + +If prefix argument ARG is non-nil, it specifies the number of +buffers to delete; a negative ARG means to delete backwards." (interactive "p") - (when (Buffer-menu-no-header) - (let ((inhibit-read-only t)) - (if (or (null arg) (= arg 0)) - (setq arg 1)) - (while (> arg 0) - (delete-char 1) - (insert ?D) - (forward-line 1) - (setq arg (1- arg))) - (while (and (< arg 0) - (Buffer-menu-no-header)) - (delete-char 1) - (insert ?D) - (forward-line -1) - (setq arg (1+ arg)))))) + (if (or (null arg) (= arg 0)) + (setq arg 1)) + (while (> arg 0) + (when (Buffer-menu-buffer) + (tabulated-list-set-col 0 "D" t)) + (forward-line 1) + (setq arg (1- arg))) + (while (< arg 0) + (when (Buffer-menu-buffer) + (tabulated-list-set-col 0 "D" t)) + (forward-line -1) + (setq arg (1+ arg)))) (defun Buffer-menu-delete-backwards (&optional arg) - "Mark buffer on this line to be deleted by \\\\[Buffer-menu-execute] command -and then move up one line. Prefix arg means move that many lines." + "Mark the buffer on this Buffer Menu line for deletion, and move up. +Prefix ARG means move that many lines." (interactive "p") (Buffer-menu-delete (- (or arg 1)))) (defun Buffer-menu-save () - "Mark buffer on this line to be saved by \\\\[Buffer-menu-execute] command." + "Mark the buffer on this Buffer Menu line for saving. +A subsequent \\`\\[Buffer-menu-execute]' command +will save it." (interactive) - (when (Buffer-menu-no-header) - (let ((inhibit-read-only t)) - (forward-char 2) - (delete-char 1) - (insert ?S) - (forward-line 1)))) + (when (Buffer-menu-buffer) + (tabulated-list-set-col 2 "S" t) + (forward-line 1))) (defun Buffer-menu-not-modified (&optional arg) - "Mark buffer on this line as unmodified (no changes to save)." + "Mark the buffer on this line as unmodified (no changes to save). +If ARG is non-nil (interactively, with a prefix argument), mark +it as modified." (interactive "P") (with-current-buffer (Buffer-menu-buffer t) (set-buffer-modified-p arg)) - (save-excursion - (beginning-of-line) - (forward-char 2) - (if (= (char-after) (if arg ?\s ?*)) - (let ((inhibit-read-only t)) - (delete-char 1) - (insert (if arg ?* ?\s)))))) - -(defun Buffer-menu-beginning () - (goto-char (point-min)) - (unless Buffer-menu-use-header-line - (forward-line))) + (tabulated-list-set-col 2 (if arg "*" " ") t)) (defun Buffer-menu-execute () - "Save and/or delete buffers marked with \\\\[Buffer-menu-save] or \\\\[Buffer-menu-delete] commands." + "Save and/or delete marked buffers in the Buffer Menu. +Buffers marked with \\`\\[Buffer-menu-save]' are saved. +Buffers marked with \\`\\[Buffer-menu-delete]' are deleted." (interactive) (save-excursion (Buffer-menu-beginning) - (while (re-search-forward "^..S" nil t) - (let ((modp nil)) - (with-current-buffer (Buffer-menu-buffer t) - (save-buffer) - (setq modp (buffer-modified-p))) - (let ((inhibit-read-only t)) - (delete-char -1) - (insert (if modp ?* ?\s)))))) - (save-excursion - (Buffer-menu-beginning) - (let ((buff-menu-buffer (current-buffer)) - (inhibit-read-only t)) - (while (re-search-forward "^D" nil t) - (forward-char -1) - (let ((buf (Buffer-menu-buffer nil))) - (or (eq buf nil) - (eq buf buff-menu-buffer) - (save-excursion (kill-buffer buf))) - (if (and buf (buffer-name buf)) - (progn (delete-char 1) - (insert ?\s)) - (delete-region (point) (progn (forward-line 1) (point))) - (unless (bobp) - (forward-char -1)))))))) + (while (not (eobp)) + (let ((buffer (tabulated-list-get-id)) + (entry (tabulated-list-get-entry))) + (cond ((null entry) + (forward-line 1)) + ((not (buffer-live-p buffer)) + (tabulated-list-delete-entry)) + (t + (let ((delete (eq (char-after) ?D))) + (when (equal (aref entry 2) "S") + (condition-case nil + (progn + (with-current-buffer buffer + (save-buffer)) + (tabulated-list-set-col 2 " " t)) + (error (warn "Error saving %s" buffer)))) + (if delete + (unless (eq buffer (current-buffer)) + (kill-buffer buffer) + (tabulated-list-delete-entry)) + (forward-line 1))))))))) (defun Buffer-menu-select () - "Select this line's buffer; also display buffers marked with `>'. -You can mark buffers with the \\\\[Buffer-menu-mark] command. + "Select this line's buffer; also, display buffers marked with `>'. +You can mark buffers with the \\`\\[Buffer-menu-mark]' command. This command deletes and replaces all the previously existing windows in the selected frame." (interactive) - (let ((buff (Buffer-menu-buffer t)) - (menu (current-buffer)) - (others ()) - tem) - (Buffer-menu-beginning) - (while (re-search-forward "^>" nil t) - (setq tem (Buffer-menu-buffer t)) - (let ((inhibit-read-only t)) - (delete-char -1) - (insert ?\s)) - (or (eq tem buff) (memq tem others) (setq others (cons tem others)))) - (setq others (nreverse others) - tem (/ (1- (frame-height)) (1+ (length others)))) + (let* ((this-buffer (Buffer-menu-buffer t)) + (menu-buffer (current-buffer)) + (others (delq this-buffer (Buffer-menu-marked-buffers t))) + (height (/ (1- (frame-height)) (1+ (length others))))) (delete-other-windows) - (switch-to-buffer buff) - (or (eq menu buff) - (bury-buffer menu)) - (if (equal (length others) 0) - (progn -;;; ;; Restore previous window configuration before displaying -;;; ;; selected buffers. -;;; (if Buffer-menu-window-config -;;; (progn -;;; (set-window-configuration Buffer-menu-window-config) -;;; (setq Buffer-menu-window-config nil))) - (switch-to-buffer buff)) - (while others - (split-window nil tem) - (other-window 1) - (switch-to-buffer (car others)) - (setq others (cdr others))) - (other-window 1) ;back to the beginning! -))) + (switch-to-buffer this-buffer) + (unless (eq menu-buffer this-buffer) + (bury-buffer menu-buffer)) + (dolist (buffer others) + (split-window nil height) + (other-window 1) + (switch-to-buffer buffer)) + ;; Back to the beginning! + (other-window 1))) -(defun Buffer-menu-marked-buffers () - "Return a list of buffers marked with the \\\\[Buffer-menu-mark] command." +(defun Buffer-menu-marked-buffers (&optional unmark) + "Return the list of buffers marked with `Buffer-menu-mark'. +If UNMARK is non-nil, unmark them." (let (buffers) (Buffer-menu-beginning) (while (re-search-forward "^>" nil t) - (setq buffers (cons (Buffer-menu-buffer t) buffers))) + (let ((buffer (Buffer-menu-buffer))) + (if (and buffer unmark) + (tabulated-list-set-col 0 " " t)) + (if (buffer-live-p buffer) + (push buffer buffers)))) (nreverse buffers))) (defun Buffer-menu-isearch-buffers () @@ -558,20 +480,6 @@ (bury-buffer (other-buffer)) (delete-other-windows)) -(defun Buffer-menu-mouse-select (event) - "Select the buffer whose line you click on." - (interactive "e") - (let (buffer) - (with-current-buffer (window-buffer (posn-window (event-end event))) - (save-excursion - (goto-char (posn-point (event-end event))) - (setq buffer (Buffer-menu-buffer t)))) - (select-window (posn-window (event-end event))) - (if (and (window-dedicated-p (selected-window)) - (eq (selected-window) (frame-root-window))) - (switch-to-buffer-other-frame buffer) - (switch-to-buffer buffer)))) - (defun Buffer-menu-this-window () "Select this line's buffer in this window." (interactive) @@ -599,340 +507,128 @@ (bury-buffer menu))) (defun Buffer-menu-toggle-read-only () - "Toggle read-only status of buffer on this line, perhaps via version control." + "Toggle read-only status of buffer on this line." (interactive) - (let (char) + (let (read-only) (with-current-buffer (Buffer-menu-buffer t) - (toggle-read-only) - (setq char (if buffer-read-only ?% ?\s))) - (save-excursion - (beginning-of-line) - (forward-char 1) - (if (/= (following-char) char) - (let ((inhibit-read-only t)) - (delete-char 1) - (insert char)))))) + (with-no-warnings (toggle-read-only)) + (setq read-only buffer-read-only)) + (tabulated-list-set-col 1 (if read-only "%" " ") t))) (defun Buffer-menu-bury () "Bury the buffer listed on this line." (interactive) - (when (Buffer-menu-no-header) - (save-excursion - (beginning-of-line) - (bury-buffer (Buffer-menu-buffer t)) - (let ((line (buffer-substring (point) (progn (forward-line 1) (point)))) - (inhibit-read-only t)) - (delete-region (point) (progn (forward-line -1) (point))) - (goto-char (point-max)) - (insert line)) - (message "Buried buffer moved to the end")))) - + (let ((buffer (tabulated-list-get-id))) + (cond ((null buffer)) + ((buffer-live-p buffer) + (bury-buffer buffer) + (save-excursion + (let ((elt (tabulated-list-delete-entry))) + (goto-char (point-max)) + (apply 'tabulated-list-print-entry elt))) + (message "Buffer buried.")) + (t + (tabulated-list-delete-entry) + (message "Buffer is dead; removing from list."))))) (defun Buffer-menu-view () "View this line's buffer in View mode." (interactive) (view-buffer (Buffer-menu-buffer t))) - (defun Buffer-menu-view-other-window () "View this line's buffer in View mode in another window." (interactive) (view-buffer-other-window (Buffer-menu-buffer t))) - -;;;###autoload -(defun list-buffers (&optional files-only) - "Display a list of names of existing buffers. -The list is displayed in a buffer named `*Buffer List*'. -Note that buffers with names starting with spaces are omitted. -Non-null optional arg FILES-ONLY means mention only file buffers. - -For more information, see the function `buffer-menu'." - (interactive "P") - (display-buffer (list-buffers-noselect files-only))) - -(defconst Buffer-menu-short-ellipsis - ;; This file is preloaded, so we can't use char-displayable-p here - ;; because we don't know yet what display we're going to connect to. - ":" ;; (if (char-displayable-p ?…) "…" ":") - ) - -(defun Buffer-menu-buffer+size (name size &optional name-props size-props) - (if (> (+ (string-width name) (string-width size) 2) - Buffer-menu-buffer+size-width) - (setq name - (let ((tail - (if (string-match "<[0-9]+>$" name) - (match-string 0 name) - ""))) - (concat (truncate-string-to-width - name - (- Buffer-menu-buffer+size-width - (max (string-width size) 3) - (string-width tail) - 2)) - Buffer-menu-short-ellipsis - tail))) - ;; Don't put properties on (buffer-name). - (setq name (copy-sequence name))) - (add-text-properties 0 (length name) name-props name) - (add-text-properties 0 (length size) size-props size) - (let ((name+space-width (- Buffer-menu-buffer+size-width - (string-width size)))) - (concat name - (propertize (make-string (- name+space-width (string-width name)) - ?\s) - 'display `(space :align-to - ,(+ Buffer-menu-buffer-column - name+space-width))) - size))) - -(defun Buffer-menu-sort (column) - "Sort the buffer menu by COLUMN." - (interactive "P") - (when column - (setq column (prefix-numeric-value column)) - (if (< column 2) (setq column 2)) - (if (> column 5) (setq column 5))) - (setq Buffer-menu-sort-column column) - (let ((inhibit-read-only t) l buf m1 m2) - (save-excursion - (Buffer-menu-beginning) - (while (not (eobp)) - (when (buffer-live-p - (setq buf (get-text-property - (+ (point) - Buffer-menu-buffer-column) - 'buffer))) - (setq m1 (char-after) - m1 (if (memq m1 '(?> ?D)) m1) - m2 (char-after (+ (point) 2)) - m2 (if (eq m2 ?S) m2)) - (if (or m1 m2) - (push (list buf m1 m2) l))) - (forward-line))) - (revert-buffer) - (save-excursion - (Buffer-menu-beginning) - (while (not (eobp)) - (when (setq buf (assq (get-text-property (+ (point) - Buffer-menu-buffer-column) - 'buffer) l)) - (setq m1 (cadr buf) - m2 (cadr (cdr buf))) - (when m1 - (delete-char 1) - (insert m1) - (backward-char 1)) - (when m2 - (forward-char 2) - (delete-char 1) - (insert m2))) - (forward-line))))) - -(defun Buffer-menu-sort-by-column (&optional e) - "Sort the buffer menu by the column clicked on." - (interactive (list last-input-event)) - (if e (mouse-select-window e)) - (let* ((pos (event-start e)) - (obj (posn-object pos)) - (col (if obj - (get-text-property (cdr obj) 'column (car obj)) - (get-text-property (posn-point pos) 'column)))) - (Buffer-menu-sort col))) - -(defvar Buffer-menu-sort-button-map - (let ((map (make-sparse-keymap))) - ;; This keymap handles both nil and non-nil values for - ;; Buffer-menu-use-header-line. - (define-key map [header-line mouse-1] 'Buffer-menu-sort-by-column) - (define-key map [header-line mouse-2] 'Buffer-menu-sort-by-column) - (define-key map [mouse-2] 'Buffer-menu-sort-by-column) - (define-key map [follow-link] 'mouse-face) - (define-key map "\C-m" 'Buffer-menu-sort-by-column) - map) - "Local keymap for Buffer menu sort buttons.") - -(defun Buffer-menu-make-sort-button (name column) - (if (equal column Buffer-menu-sort-column) (setq column nil)) - (propertize name - 'column column - 'help-echo (concat - (if Buffer-menu-use-header-line - "mouse-1, mouse-2: sort by " - "mouse-2, RET: sort by ") - (if column (downcase name) "visited order")) - 'mouse-face 'highlight - 'keymap Buffer-menu-sort-button-map)) +;;; Functions for populating the Buffer Menu. (defun list-buffers-noselect (&optional files-only buffer-list) - "Create and return a buffer with a list of names of existing buffers. -The buffer is named `*Buffer List*'. -Note that buffers with names starting with spaces are omitted. -Non-null optional arg FILES-ONLY means mention only file buffers. - -If BUFFER-LIST is non-nil, it should be a list of buffers; -it means list those buffers and no others. - -For more information, see the function `buffer-menu'." - (let* ((old-buffer (current-buffer)) - (standard-output standard-output) - (mode-end (make-string (- Buffer-menu-mode-width 2) ?\s)) - (header (concat "CRM " - (Buffer-menu-buffer+size - (Buffer-menu-make-sort-button "Buffer" 2) - (Buffer-menu-make-sort-button "Size" 3)) - " " - (Buffer-menu-make-sort-button "Mode" 4) mode-end - (Buffer-menu-make-sort-button "File" 5) "\n")) - list desired-point) - (when Buffer-menu-use-header-line - (let ((pos 0)) - ;; Turn whitespace chars in the header into stretch specs so - ;; they work regardless of the header-line face. - (while (string-match "[ \t\n]+" header pos) - (setq pos (match-end 0)) - (put-text-property (match-beginning 0) pos 'display - ;; Assume fixed-size chars in the buffer. - (list 'space :align-to pos) - header))) - ;; Try to better align the one-char headers. - (put-text-property 0 3 'face 'fixed-pitch header) - ;; Add a "dummy" leading space to align the beginning of the header - ;; line with the beginning of the text (rather than with the left - ;; scrollbar or the left fringe). --Stef - (setq header (concat (propertize " " 'display '(space :align-to 0)) - header))) - (with-current-buffer (get-buffer-create "*Buffer List*") - (setq buffer-read-only nil) - (erase-buffer) - (setq standard-output (current-buffer)) - ;; Force L2R direction, to avoid messing the display if the - ;; first buffer in the list happens to begin with a strong R2L - ;; character. - (setq bidi-paragraph-direction 'left-to-right) - (unless Buffer-menu-use-header-line - ;; Use U+2014 (EM DASH) to underline if possible, else use ASCII - ;; (i.e. U+002D, HYPHEN-MINUS). - (let ((underline (if (char-displayable-p ?\u2014) ?\u2014 ?-))) - (insert header - (apply 'string - (mapcar (lambda (c) - (if (memq c '(?\n ?\s)) c underline)) - header))))) - ;; Collect info for every buffer we're interested in. - (dolist (buffer (or buffer-list - (buffer-list - (when Buffer-menu-use-frame-buffer-list - (selected-frame))))) - (with-current-buffer buffer - (let ((name (buffer-name)) - (file buffer-file-name)) - (unless (and (not buffer-list) - (or - ;; Don't mention internal buffers. - (and (string= (substring name 0 1) " ") (null file)) - ;; Maybe don't mention buffers without files. - (and files-only (not file)) - (string= name "*Buffer List*"))) - ;; Otherwise output info. - (let ((mode (concat (format-mode-line mode-name nil nil buffer) - (if mode-line-process - (format-mode-line mode-line-process - nil nil buffer)))) - (bits (string - (if (eq buffer old-buffer) ?. ?\s) - ;; Handle readonly status. The output buffer - ;; is special cased to appear readonly; it is - ;; actually made so at a later date. - (if (or (eq buffer standard-output) - buffer-read-only) - ?% ?\s) - ;; Identify modified buffers. - (if (buffer-modified-p) ?* ?\s) - ;; Space separator. - ?\s))) - (unless file - ;; No visited file. Check local value of - ;; list-buffers-directory and, for Info buffers, - ;; Info-current-file. - (cond ((and (boundp 'list-buffers-directory) - list-buffers-directory) - (setq file list-buffers-directory)) - ((eq major-mode 'Info-mode) - (setq file Info-current-file) - (cond - ((equal file "dir") - (setq file "*Info Directory*")) - ((eq file 'apropos) - (setq file "*Info Apropos*")) - ((eq file 'history) - (setq file "*Info History*")) - ((eq file 'toc) - (setq file "*Info TOC*")) - ((not (stringp file)) ;; avoid errors - (setq file nil)) - (t - (setq file (concat "(" - (file-name-nondirectory file) - ") " - Info-current-node))))))) - (push (list buffer bits name (buffer-size) mode file) - list)))))) - ;; Preserve the original buffer-list ordering, just in case. - (setq list (nreverse list)) - ;; Place the buffers's info in the output buffer, sorted if necessary. - (dolist (buffer - (if Buffer-menu-sort-column - (sort list - (if (eq Buffer-menu-sort-column 3) - (lambda (a b) - (< (nth Buffer-menu-sort-column a) - (nth Buffer-menu-sort-column b))) - (lambda (a b) - (string< (nth Buffer-menu-sort-column a) - (nth Buffer-menu-sort-column b))))) - list)) - (if (eq (car buffer) old-buffer) - (setq desired-point (point))) - (insert (cadr buffer) - ;; Put the buffer name into a text property - ;; so we don't have to extract it from the text. - ;; This way we avoid problems with unusual buffer names. - (let ((name (nth 2 buffer)) - (size (int-to-string (nth 3 buffer)))) - (Buffer-menu-buffer+size name size - `(buffer-name ,name - buffer ,(car buffer) - font-lock-face buffer-menu-buffer - mouse-face highlight - help-echo - ,(if (>= (length name) - (- Buffer-menu-buffer+size-width - (max (length size) 3) - 2)) - name - "mouse-2: select this buffer")))) - " " - (if (> (string-width (nth 4 buffer)) Buffer-menu-mode-width) - (truncate-string-to-width (nth 4 buffer) - Buffer-menu-mode-width) - (nth 4 buffer))) - (when (nth 5 buffer) - (indent-to (+ Buffer-menu-buffer-column Buffer-menu-buffer+size-width - Buffer-menu-mode-width 4) 1) - (princ (abbreviate-file-name (nth 5 buffer)))) - (princ "\n")) + "Create and return a Buffer Menu buffer. +This is called by `buffer-menu' and others as a subroutine. + +If FILES-ONLY is non-nil, show only file-visiting buffers. +If BUFFER-LIST is non-nil, it should be a list of buffers; it +means list those buffers and no others." + (let ((old-buffer (current-buffer)) + (buffer (get-buffer-create "*Buffer List*"))) + (with-current-buffer buffer (Buffer-menu-mode) - (when Buffer-menu-use-header-line - (setq header-line-format header)) - ;; DESIRED-POINT doesn't have to be set; it is not when the - ;; current buffer is not displayed for some reason. - (and desired-point - (goto-char desired-point)) - (setq Buffer-menu-files-only files-only) - (setq Buffer-menu--buffers buffer-list) - (set-buffer-modified-p nil) - (current-buffer)))) + (setq Buffer-menu-files-only (and files-only (>= files-only 0))) + (list-buffers--refresh buffer-list old-buffer) + (tabulated-list-print)) + buffer)) + +(defun list-buffers--refresh (&optional buffer-list old-buffer) + ;; Set up `tabulated-list-format'. + (let ((name-width Buffer-menu-name-width) + (size-width Buffer-menu-size-width)) + ;; Handle obsolete variable: + (if Buffer-menu-buffer+size-width + (setq name-width (- Buffer-menu-buffer+size-width size-width))) + (setq tabulated-list-format + (vector '("C" 1 t :pad-right 0) + '("R" 1 t :pad-right 0) + '("M" 1 t) + `("Buffer" ,name-width t) + `("Size" ,size-width tabulated-list-entry-size->) + `("Mode" ,Buffer-menu-mode-width t) + '("File" 1 t)))) + ;; Collect info for each buffer we're interested in. + (let ((buffer-menu-buffer (current-buffer)) + (show-non-file (not Buffer-menu-files-only)) + entries) + (dolist (buffer (or buffer-list + (buffer-list (if Buffer-menu-use-frame-buffer-list + (selected-frame))))) + (with-current-buffer buffer + (let* ((name (buffer-name)) + (file buffer-file-name)) + (when (and (buffer-live-p buffer) + (or buffer-list + (and (not (string= (substring name 0 1) " ")) + (not (eq buffer buffer-menu-buffer)) + (or file show-non-file)))) + (push (list buffer + (vector (if (eq buffer old-buffer) "." " ") + (if buffer-read-only "%" " ") + (if (buffer-modified-p) "*" " ") + (Buffer-menu--pretty-name name) + (number-to-string (buffer-size)) + (concat (format-mode-line mode-name nil nil buffer) + (if mode-line-process + (format-mode-line mode-line-process + nil nil buffer))) + (Buffer-menu--pretty-file-name file))) + entries))))) + (setq tabulated-list-entries (nreverse entries))) + (tabulated-list-init-header)) + +(defun tabulated-list-entry-size-> (entry1 entry2) + (> (string-to-number (aref (cadr entry1) 4)) + (string-to-number (aref (cadr entry2) 4)))) + +(defun Buffer-menu--pretty-name (name) + (propertize name 'font-lock-face 'buffer-menu-buffer)) + +(defun Buffer-menu--pretty-file-name (file) + (cond (file + (abbreviate-file-name file)) + ((and (boundp 'list-buffers-directory) + list-buffers-directory) + list-buffers-directory) + ((eq major-mode 'Info-mode) + (Buffer-menu-info-node-description Info-current-file)) + (t ""))) + +(defun Buffer-menu-info-node-description (file) + (cond + ((equal file "dir") "*Info Directory*") + ((eq file 'apropos) "*Info Apropos*") + ((eq file 'history) "*Info History*") + ((eq file 'toc) "*Info TOC*") + ((not (stringp file)) "") ; Avoid errors + (t + (concat "(" (file-name-nondirectory file) ") " Info-current-node)))) ;;; buff-menu.el ends here === modified file 'lisp/emacs-lisp/cl-loaddefs.el' --- lisp/emacs-lisp/cl-loaddefs.el 2012-04-26 03:18:47 +0000 +++ lisp/emacs-lisp/cl-loaddefs.el 2012-05-06 16:45:46 +0000 @@ -286,7 +286,7 @@ ;;;;;; flet progv psetq do-all-symbols do-symbols dotimes dolist ;;;;;; do* do loop return-from return block etypecase typecase ecase ;;;;;; case load-time-value eval-when destructuring-bind function* -;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "abb2e33c6f61539d69ddbe7c4046261b") +;;;;;; defmacro* defun* gentemp gensym) "cl-macs" "cl-macs.el" "e10ebd95224fcfbe6a5edc59f40d695a") ;;; Generated autoloads from cl-macs.el (autoload 'gensym "cl-macs" "\ === modified file 'lisp/emacs-lisp/tabulated-list.el' --- lisp/emacs-lisp/tabulated-list.el 2012-05-06 08:32:37 +0000 +++ lisp/emacs-lisp/tabulated-list.el 2012-05-06 16:45:46 +0000 @@ -144,7 +144,7 @@ (set-keymap-parent map button-buffer-map) (define-key map "n" 'next-line) (define-key map "p" 'previous-line) - (define-key map "S" 'tabulated-list-sort-column) + (define-key map "S" 'tabulated-list-sort) (define-key map [follow-link] 'mouse-face) (define-key map [mouse-2] 'mouse-select-window) map) @@ -174,8 +174,7 @@ mouse-face highlight keymap ,tabulated-list-sort-button-map)) (cols nil)) - (if (> tabulated-list-padding 0) - (push (propertize " " 'display `(space :align-to ,x)) cols)) + (push (propertize " " 'display `(space :align-to ,x)) cols) (dotimes (n (length tabulated-list-format)) (let* ((col (aref tabulated-list-format n)) (label (nth 0 col)) @@ -183,9 +182,6 @@ (props (nthcdr 3 col)) (pad-right (or (plist-get props :pad-right) 1))) (setq x (+ x pad-right width)) - (and (<= tabulated-list-padding 0) - (= n 0) - (setq label (concat " " label))) (push (cond ;; An unsortable column @@ -402,7 +398,7 @@ (with-current-buffer (window-buffer (posn-window pos)) (tabulated-list--sort-by-column-name name)))) -(defun tabulated-list-sort-column (&optional n) +(defun tabulated-list-sort (&optional n) "Sort Tabulated List entries by the column at point. With a numeric prefix argument N, sort the Nth column." (interactive "P") @@ -424,7 +420,6 @@ ;;; The mode definition: -;;;###autoload (define-derived-mode tabulated-list-mode special-mode "Tabulated" "Generic major mode for browsing a list of items. This mode is usually not used directly; instead, other major === modified file 'lisp/loadup.el' --- lisp/loadup.el 2012-04-16 03:47:43 +0000 +++ lisp/loadup.el 2012-05-06 16:45:46 +0000 @@ -188,6 +188,7 @@ (load "textmodes/fill") (load "replace") +(load "emacs-lisp/tabulated-list") (load "buff-menu") (if (fboundp 'x-create-frame) === modified file 'src/ChangeLog' --- src/ChangeLog 2012-05-05 04:32:58 +0000 +++ src/ChangeLog 2012-05-06 16:45:46 +0000 @@ -1,3 +1,7 @@ +2012-05-06 Chong Yidong + + * lisp.mk (lisp): Update. + 2012-05-05 Jim Meyering * w32font.c (fill_in_logfont): NUL-terminate a string (Bug#11372). === modified file 'src/lisp.mk' --- src/lisp.mk 2012-04-21 08:03:52 +0000 +++ src/lisp.mk 2012-05-06 16:45:46 +0000 @@ -129,6 +129,7 @@ $(lispsource)/textmodes/text-mode.elc \ $(lispsource)/textmodes/fill.elc \ $(lispsource)/replace.elc \ + $(lispsource)/emacs-lisp/tabulated-list.elc \ $(lispsource)/buff-menu.elc \ $(lispsource)/fringe.elc \ $(lispsource)/emacs-lisp/regexp-opt.elc \ ------------------------------------------------------------ revno: 108142 fixes bug(s): http://debbugs.gnu.org/cgi/bugreport.cgi?bug=11038 author: Christopher Schmidt committer: Stefan Monnier branch nick: trunk timestamp: Sun 2012-05-06 11:38:30 -0400 message: * lisp/emacs-lisp/cl-macs.el (cl-expr-contains): Handle cons cells whose cdr is not a cons cell correctly. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-05-06 08:43:46 +0000 +++ lisp/ChangeLog 2012-05-06 15:38:30 +0000 @@ -1,18 +1,23 @@ +2012-05-06 Christopher Schmidt + + * emacs-lisp/cl-macs.el (cl-expr-contains): Handle cons cells + whose cdr is not a cons cell correctly (bug#11038). + 2012-05-06 Chong Yidong - * emacs-lisp/tabulated-list.el (tabulated-list-format): Accept - additional plist in column descriptors. + * emacs-lisp/tabulated-list.el (tabulated-list-format): + Accept additional plist in column descriptors. (tabulated-list-init-header): Obey it. (tabulated-list-get-entry): New function. (tabulated-list-put-tag): Use it. Use string-width instead of length. (tabulated-list--column-number): New function. (tabulated-list-print): Use it. - (tabulated-list-print-col): New function. Set - `tabulated-list-column-name' property on each column's text. + (tabulated-list-print-col): New function. + Set `tabulated-list-column-name' property on each column's text. (tabulated-list-print-entry): Use it. - (tabulated-list-delete-entry, tabulated-list-set-col): New - functions. + (tabulated-list-delete-entry, tabulated-list-set-col): + New functions. (tabulated-list-sort-column): New command (Bug#11337). * buff-menu.el (list-buffers): Move C-x C-b binding from === modified file 'lisp/emacs-lisp/cl-macs.el' --- lisp/emacs-lisp/cl-macs.el 2012-04-26 03:18:47 +0000 +++ lisp/emacs-lisp/cl-macs.el 2012-05-06 15:38:30 +0000 @@ -143,11 +143,16 @@ ;;; Count number of times X refers to Y. Return nil for 0 times. (defun cl-expr-contains (x y) + ;; FIXME: This is naive, and it will count Y as referred twice in + ;; (let ((Y 1)) Y) even though it should be 0. Also it is often called on + ;; non-macroexpanded code, so it may also miss some occurrences that would + ;; only appear in the expanded code. (cond ((equal y x) 1) ((and (consp x) (not (memq (car-safe x) '(quote function function*)))) (let ((sum 0)) - (while x + (while (consp x) (setq sum (+ sum (or (cl-expr-contains (pop x) y) 0)))) + (setq sum (+ sum (or (cl-expr-contains x y) 0))) (and (> sum 0) sum))) (t nil))) ------------------------------------------------------------ revno: 108141 committer: Glenn Morris branch nick: trunk timestamp: Sun 2012-05-06 06:18:48 -0400 message: Auto-commit of generated files. diff: === modified file 'autogen/configure' --- autogen/configure 2012-05-05 04:32:58 +0000 +++ autogen/configure 2012-05-06 10:18:48 +0000 @@ -14906,7 +14906,7 @@ ## option to use it. darwin) LIBS_TERMCAP="-lncurses" ;; - gnu*) "x$LIBS_TERMCAP" = x && LIBS_TERMCAP="-lncurses" ;; + gnu*) test -z "$LIBS_TERMCAP" && LIBS_TERMCAP="-lncurses" ;; freebsd) { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether FreeBSD is new enough to use terminfo" >&5 @@ -14950,7 +14950,7 @@ ;; netbsd) - if "x$LIBS_TERMCAP" != "x-lterminfo" ; then + if test "x$LIBS_TERMCAP" != "x-lterminfo"; then TERMINFO=no LIBS_TERMCAP="-ltermcap" fi ------------------------------------------------------------ revno: 108140 committer: Chong Yidong branch nick: trunk timestamp: Sun 2012-05-06 16:43:46 +0800 message: Some cleanups for the buffer menu and electric buffer menu. * lisp/buff-menu.el (list-buffers): Move C-x C-b binding from buff-menu.el to bindings.el. * lisp/ebuff-menu.el (Electric-buffer-menu-undefined): Use the :advertised-binding feature. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-05-06 08:32:37 +0000 +++ lisp/ChangeLog 2012-05-06 08:43:46 +0000 @@ -15,6 +15,12 @@ functions. (tabulated-list-sort-column): New command (Bug#11337). + * buff-menu.el (list-buffers): Move C-x C-b binding from + buff-menu.el to bindings.el. + + * ebuff-menu.el (Electric-buffer-menu-undefined): Use the + :advertised-binding feature. + 2012-05-06 Troels Nielsen (tiny change) * progmodes/compile.el (compilation-internal-error-properties): === modified file 'lisp/bindings.el' --- lisp/bindings.el 2012-05-04 23:16:47 +0000 +++ lisp/bindings.el 2012-05-06 08:43:46 +0000 @@ -40,7 +40,7 @@ (interactive "e") (save-selected-window (select-window (posn-window (event-start event))) - (toggle-read-only) + (with-no-warnings (toggle-read-only)) (force-mode-line-update))) @@ -1190,6 +1190,7 @@ ;; (define-key ctl-x-map "\-" 'inverse-add-global-abbrev) (define-key esc-map "'" 'abbrev-prefix-mark) (define-key ctl-x-map "'" 'expand-abbrev) +(define-key ctl-x-map "\C-b" 'list-buffers) (define-key ctl-x-map "z" 'repeat) === modified file 'lisp/buff-menu.el' --- lisp/buff-menu.el 2012-01-19 07:21:25 +0000 +++ lisp/buff-menu.el 2012-05-06 08:43:46 +0000 @@ -641,9 +641,6 @@ ;;;###autoload -(define-key ctl-x-map "\C-b" 'list-buffers) - -;;;###autoload (defun list-buffers (&optional files-only) "Display a list of names of existing buffers. The list is displayed in a buffer named `*Buffer List*'. === modified file 'lisp/ebuff-menu.el' --- lisp/ebuff-menu.el 2012-01-19 07:21:25 +0000 +++ lisp/ebuff-menu.el 2012-05-06 08:43:46 +0000 @@ -85,6 +85,11 @@ (define-key map [mouse-2] 'Electric-buffer-menu-mouse-select) map)) +(put 'Electric-buffer-menu-quit :advertised-binding "\C-c\C-c") +(put 'Electric-buffer-menu-select :advertised-binding " ") +(put 'Helper-help :advertised-binding (char-to-string help-char)) +(put 'Helper-describe-bindings :advertised-binding "?") + (defvar electric-buffer-menu-mode-hook nil "Normal hook run by `electric-buffer-list'.") @@ -251,15 +256,10 @@ (interactive) (ding) (message "%s" - (if (and (eq (key-binding "\C-c\C-c") 'Electric-buffer-menu-quit) - (eq (key-binding " ") 'Electric-buffer-menu-select) - (eq (key-binding (char-to-string help-char)) 'Helper-help) - (eq (key-binding "?") 'Helper-describe-bindings)) - (substitute-command-keys "Type C-c C-c to exit, Space to select, \\[Helper-help] for help, ? for commands") - (substitute-command-keys "\ + (substitute-command-keys "\ Type \\[Electric-buffer-menu-quit] to exit, \ \\[Electric-buffer-menu-select] to select, \ -\\[Helper-help] for help, \\[Helper-describe-bindings] for commands."))) +\\[Helper-help] for help, \\[Helper-describe-bindings] for commands.")) (sit-for 4)) (defun Electric-buffer-menu-mode-view-buffer () ------------------------------------------------------------ revno: 108139 fixes bug(s): http://debbugs.gnu.org/11337 committer: Chong Yidong branch nick: trunk timestamp: Sun 2012-05-06 16:32:37 +0800 message: Improvements for Tabulated List mode. * lisp/emacs-lisp/tabulated-list.el (tabulated-list-format): Accept additional plist in column descriptors. (tabulated-list-init-header): Obey it. (tabulated-list-get-entry): New function. (tabulated-list-put-tag): Use it. Use string-width instead of length. (tabulated-list--column-number): New function. (tabulated-list-print): Use it. (tabulated-list-print-col): New function. Set `tabulated-list-column-name' property on each column's text. (tabulated-list-print-entry): Use it. (tabulated-list-delete-entry, tabulated-list-set-col): New functions. (tabulated-list-sort-column): New command. diff: === modified file 'etc/NEWS' --- etc/NEWS 2012-05-05 21:31:41 +0000 +++ etc/NEWS 2012-05-06 08:32:37 +0000 @@ -161,6 +161,11 @@ The function `notifications-get-capabilities' returns the supported server properties. +** Tabulated List and packages derived from it + +*** New command `tabulated-list-sort-column' bound to `S' sorts column +at point, or the Nth column if a numeric prefix argument is given. + ** Obsolete packages: *** assoc.el === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-05-06 04:52:58 +0000 +++ lisp/ChangeLog 2012-05-06 08:32:37 +0000 @@ -1,3 +1,20 @@ +2012-05-06 Chong Yidong + + * emacs-lisp/tabulated-list.el (tabulated-list-format): Accept + additional plist in column descriptors. + (tabulated-list-init-header): Obey it. + (tabulated-list-get-entry): New function. + (tabulated-list-put-tag): Use it. Use string-width instead of + length. + (tabulated-list--column-number): New function. + (tabulated-list-print): Use it. + (tabulated-list-print-col): New function. Set + `tabulated-list-column-name' property on each column's text. + (tabulated-list-print-entry): Use it. + (tabulated-list-delete-entry, tabulated-list-set-col): New + functions. + (tabulated-list-sort-column): New command (Bug#11337). + 2012-05-06 Troels Nielsen (tiny change) * progmodes/compile.el (compilation-internal-error-properties): === modified file 'lisp/emacs-lisp/tabulated-list.el' --- lisp/emacs-lisp/tabulated-list.el 2012-04-17 15:07:21 +0000 +++ lisp/emacs-lisp/tabulated-list.el 2012-05-06 08:32:37 +0000 @@ -22,22 +22,26 @@ ;;; Commentary: -;; This file defines `tabulated-list-mode', a generic major mode for displaying -;; lists of tabulated data, intended for other major modes to inherit from. It -;; provides several utility routines, e.g. for pretty-printing lines of -;; tabulated data to fit into the appropriate columns. +;; This file defines Tabulated List mode, a generic major mode for +;; displaying lists of tabulated data, intended for other major modes +;; to inherit from. It provides several utility routines, e.g. for +;; pretty-printing lines of tabulated data to fit into the appropriate +;; columns. ;; For usage information, see the documentation of `tabulated-list-mode'. -;; This package originated from Tom Tromey's Package Menu mode, extended and -;; generalized to be used by other modes. +;; This package originated from Tom Tromey's Package Menu mode, +;; extended and generalized to be used by other modes. ;;; Code: (defvar tabulated-list-format nil "The format of the current Tabulated List mode buffer. -This should be a vector of elements (NAME WIDTH SORT), where: +This should be a vector of elements (NAME WIDTH SORT . PROPS), +where: - NAME is a string describing the column. + This is the label for the column in the header line. + Different columns must have non-`equal' names. - WIDTH is the width to reserve for the column. For the final element, its numerical value is ignored. - SORT specifies how to sort entries by this column. @@ -45,7 +49,11 @@ If t, sort by comparing the string value printed in the column. Otherwise, it should be a predicate function suitable for `sort', accepting arguments with the same form as the elements - of `tabulated-list-entries'.") + of `tabulated-list-entries'. + - PROPS is a plist of additional column properties. + Currently supported properties are: + - `:pad-right': Number of additional padding spaces to the + right of the column (defaults to 1 if omitted).") (make-variable-buffer-local 'tabulated-list-format) (defvar tabulated-list-entries nil @@ -95,12 +103,18 @@ non-nil, means to invert the resulting sort.") (make-variable-buffer-local 'tabulated-list-sort-key) -(defun tabulated-list-get-id (&optional pos) - "Obtain the entry ID of the Tabulated List mode entry at POS. -This is an ID object from `tabulated-list-entries', or nil. +(defsubst tabulated-list-get-id (&optional pos) + "Return the entry ID of the Tabulated List entry at POS. +The value is an ID object from `tabulated-list-entries', or nil. POS, if omitted or nil, defaults to point." (get-text-property (or pos (point)) 'tabulated-list-id)) +(defsubst tabulated-list-get-entry (&optional pos) + "Return the Tabulated List entry at POS. +The value is a vector of column descriptors, or nil if there is +no entry at POS. POS, if omitted or nil, defaults to point." + (get-text-property (or pos (point)) 'tabulated-list-entry)) + (defun tabulated-list-put-tag (tag &optional advance) "Put TAG in the padding area of the current line. TAG should be a string, with length <= `tabulated-list-padding'. @@ -111,16 +125,16 @@ (error "Unable to tag the current line")) (save-excursion (beginning-of-line) - (when (get-text-property (point) 'tabulated-list-id) + (when (tabulated-list-get-entry) (let ((beg (point)) (inhibit-read-only t)) (forward-char tabulated-list-padding) (insert-and-inherit - (if (<= (length tag) tabulated-list-padding) - (concat tag - (make-string (- tabulated-list-padding (length tag)) - ?\s)) - (substring tag 0 tabulated-list-padding))) + (let ((width (string-width tag))) + (if (<= width tabulated-list-padding) + (concat tag + (make-string (- tabulated-list-padding width) ?\s)) + (truncate-string-to-width tag tabulated-list-padding)))) (delete-region beg (+ beg tabulated-list-padding))))) (if advance (forward-line))) @@ -130,6 +144,7 @@ (set-keymap-parent map button-buffer-map) (define-key map "n" 'next-line) (define-key map "p" 'previous-line) + (define-key map "S" 'tabulated-list-sort-column) (define-key map [follow-link] 'mouse-face) (define-key map [mouse-2] 'mouse-select-window) map) @@ -154,7 +169,7 @@ (defun tabulated-list-init-header () "Set up header line for the Tabulated List buffer." - (let ((x tabulated-list-padding) + (let ((x (max tabulated-list-padding 0)) (button-props `(help-echo "Click to sort by column" mouse-face highlight keymap ,tabulated-list-sort-button-map)) @@ -163,9 +178,11 @@ (push (propertize " " 'display `(space :align-to ,x)) cols)) (dotimes (n (length tabulated-list-format)) (let* ((col (aref tabulated-list-format n)) + (label (nth 0 col)) (width (nth 1 col)) - (label (car col))) - (setq x (+ x 1 width)) + (props (nthcdr 3 col)) + (pad-right (or (plist-get props :pad-right) 1))) + (setq x (+ x pad-right width)) (and (<= tabulated-list-padding 0) (= n 0) (setq label (concat " " label))) @@ -190,11 +207,12 @@ (t (apply 'propertize label 'tabulated-list-column-name (car col) button-props))) - cols)) - (push (propertize " " - 'display (list 'space :align-to x) - 'face 'fixed-pitch) - cols)) + cols) + (if (> pad-right 0) + (push (propertize " " + 'display `(space :align-to ,x) + 'face 'fixed-pitch) + cols)))) (setq header-line-format (mapconcat 'identity (nreverse cols) "")))) (defun tabulated-list-revert (&rest ignored) @@ -206,6 +224,17 @@ (run-hooks 'tabulated-list-revert-hook) (tabulated-list-print t)) +(defun tabulated-list--column-number (name) + (let ((len (length tabulated-list-format)) + (n 0) + found) + (while (and (< n len) (null found)) + (if (equal (car (aref tabulated-list-format n)) name) + (setq found n)) + (setq n (1+ n))) + (or found + (error "No column named %s" name)))) + (defun tabulated-list-print (&optional remember-pos) "Populate the current Tabulated List mode buffer. This sorts the `tabulated-list-entries' list if sorting is @@ -224,18 +253,13 @@ (setq saved-col (current-column))) (erase-buffer) ;; Sort the buffers, if necessary. - (when tabulated-list-sort-key - (let ((sort-column (car tabulated-list-sort-key)) - (len (length tabulated-list-format)) - (n 0) - sorter) - ;; Which column is to be sorted? - (while (and (< n len) - (not (equal (car (aref tabulated-list-format n)) - sort-column))) - (setq n (1+ n))) - (when (< n len) - (setq sorter (nth 2 (aref tabulated-list-format n))) + (when (and tabulated-list-sort-key + (car tabulated-list-sort-key)) + (let* ((sort-column (car tabulated-list-sort-key)) + (n (tabulated-list--column-number sort-column)) + (sorter (nth 2 (aref tabulated-list-format n)))) + ;; Is the specified column sortable? + (when sorter (when (eq sorter t) (setq sorter ; Default sorter checks column N: (lambda (A B) @@ -267,31 +291,105 @@ This is the default `tabulated-list-printer' function. ID is a Lisp object identifying the entry to print, and COLS is a vector of column descriptors." - (let ((beg (point)) - (x (max tabulated-list-padding 0)) - (len (length tabulated-list-format))) + (let ((beg (point)) + (x (max tabulated-list-padding 0)) + (ncols (length tabulated-list-format)) + (inhibit-read-only t)) (if (> tabulated-list-padding 0) (insert (make-string x ?\s))) - (dotimes (n len) - (let* ((format (aref tabulated-list-format n)) - (desc (aref cols n)) - (width (nth 1 format)) - (label (if (stringp desc) desc (car desc))) - (help-echo (concat (car format) ": " label))) - ;; Truncate labels if necessary (except last column). - (and (< (1+ n) len) - (> (string-width label) width) - (setq label (truncate-string-to-width label width nil nil t))) - (setq label (bidi-string-mark-left-to-right label)) - (if (stringp desc) - (insert (propertize label 'help-echo help-echo)) - (apply 'insert-text-button label (cdr desc))) - (setq x (+ x 1 width))) - ;; No need to append any spaces if this is the last column. - (if (< (1+ n) len) - (indent-to x 1))) + (dotimes (n ncols) + (setq x (tabulated-list-print-col n (aref cols n) x))) (insert ?\n) - (put-text-property beg (point) 'tabulated-list-id id))) + (put-text-property beg (point) 'tabulated-list-id id) + (put-text-property beg (point) 'tabulated-list-entry cols))) + +(defun tabulated-list-print-col (n col-desc x) + "Insert a specified Tabulated List entry at point. +N is the column number, COL-DESC is a column descriptor \(see +`tabulated-list-entries'), and X is the column number at point. +Return the column number after insertion." + (let* ((format (aref tabulated-list-format n)) + (name (nth 0 format)) + (width (nth 1 format)) + (props (nthcdr 3 format)) + (pad-right (or (plist-get props :pad-right) 1)) + (label (if (stringp col-desc) col-desc (car col-desc))) + (help-echo (concat (car format) ": " label)) + (opoint (point)) + (not-last-col (< (1+ n) (length tabulated-list-format)))) + ;; Truncate labels if necessary (except last column). + (and not-last-col + (> (string-width label) width) + (setq label (truncate-string-to-width label width nil nil t))) + (setq label (bidi-string-mark-left-to-right label)) + (if (stringp col-desc) + (insert (propertize label 'help-echo help-echo)) + (apply 'insert-text-button label (cdr col-desc))) + (setq x (+ x pad-right width)) + ;; No need to append any spaces if this is the last column. + (if not-last-col + (indent-to x pad-right)) + (put-text-property opoint (point) 'tabulated-list-column-name name) + x)) + +(defun tabulated-list-delete-entry () + "Delete the Tabulated List entry at point. +Return a list (ID COLS), where ID is the ID of the deleted entry +and COLS is a vector of its column descriptors. Move point to +the beginning of the deleted entry. Return nil if there is no +entry at point. + +This function only changes the buffer contents; it does not alter +`tabulated-list-entries'." + ;; Assume that each entry occupies one line. + (let* ((id (tabulated-list-get-id)) + (cols (tabulated-list-get-entry)) + (inhibit-read-only t)) + (when cols + (delete-region (line-beginning-position) (1+ (line-end-position))) + (list id cols)))) + +(defun tabulated-list-set-col (col desc &optional change-entry-data) + "Change the Tabulated List entry at point, setting COL to DESC. +COL is the column number to change, or the name of the column to change. +DESC is the new column descriptor, which is inserted via +`tabulated-list-print-col'. + +If CHANGE-ENTRY-DATA is non-nil, modify the underlying entry data +by setting the appropriate slot of the vector originally used to +print this entry. If `tabulated-list-entries' has a list value, +this is the vector stored within it." + (let* ((opoint (point)) + (eol (line-end-position)) + (pos (line-beginning-position)) + (id (tabulated-list-get-id pos)) + (entry (tabulated-list-get-entry pos)) + (prop 'tabulated-list-column-name) + (inhibit-read-only t) + name) + (cond ((numberp col) + (setq name (car (aref tabulated-list-format col)))) + ((stringp col) + (setq name col + col (tabulated-list--column-number col))) + (t + (error "Invalid column %s" col))) + (unless entry + (error "No Tabulated List entry at position %s" opoint)) + (unless (equal (get-text-property pos prop) name) + (while (and (setq pos + (next-single-property-change pos prop nil eol)) + (< pos eol) + (not (equal (get-text-property pos prop) name))))) + (when (< pos eol) + (delete-region pos (next-single-property-change pos prop nil eol)) + (goto-char pos) + (tabulated-list-print-col col desc (current-column)) + (if change-entry-data + (aset entry col desc)) + (put-text-property pos (point) 'tabulated-list-id id) + (put-text-property pos (point) 'tabulated-list-entry entry) + (goto-char opoint)))) (defun tabulated-list-col-sort (&optional e) "Sort Tabulated List entries by the column of the mouse click E." @@ -302,14 +400,27 @@ 'tabulated-list-column-name (car obj)))) (with-current-buffer (window-buffer (posn-window pos)) - (when (derived-mode-p 'tabulated-list-mode) - ;; Flip the sort order on a second click. - (if (equal name (car tabulated-list-sort-key)) - (setcdr tabulated-list-sort-key - (not (cdr tabulated-list-sort-key))) - (setq tabulated-list-sort-key (cons name nil))) - (tabulated-list-init-header) - (tabulated-list-print t))))) + (tabulated-list--sort-by-column-name name)))) + +(defun tabulated-list-sort-column (&optional n) + "Sort Tabulated List entries by the column at point. +With a numeric prefix argument N, sort the Nth column." + (interactive "P") + (let ((name (if n + (car (aref tabulated-list-format n)) + (get-text-property (point) + 'tabulated-list-column-name)))) + (tabulated-list--sort-by-column-name name))) + +(defun tabulated-list--sort-by-column-name (name) + (when (derived-mode-p 'tabulated-list-mode) + ;; Flip the sort order on a second click. + (if (equal name (car tabulated-list-sort-key)) + (setcdr tabulated-list-sort-key + (not (cdr tabulated-list-sort-key))) + (setq tabulated-list-sort-key (cons name nil))) + (tabulated-list-init-header) + (tabulated-list-print t))) ;;; The mode definition: ------------------------------------------------------------ revno: 108138 fixes bug(s): http://debbugs.gnu.org/11382 author: Troels Nielsen committer: Chong Yidong branch nick: trunk timestamp: Sun 2012-05-06 12:52:58 +0800 message: Fix match highlighting in compilation buffers. * progmodes/compile.el (compilation-internal-error-properties): Calculate start position correctly when end-col is set but end-line is not. diff: === modified file 'lisp/ChangeLog' --- lisp/ChangeLog 2012-05-06 04:19:11 +0000 +++ lisp/ChangeLog 2012-05-06 04:52:58 +0000 @@ -1,3 +1,9 @@ +2012-05-06 Troels Nielsen (tiny change) + + * progmodes/compile.el (compilation-internal-error-properties): + Calculate start position correctly when end-col is set but + end-line is not (Bug#11382). + 2012-05-06 Wolfgang Jenkner * man.el (Man-unindent): Use text-property-default-nonsticky to === modified file 'lisp/progmodes/compile.el' --- lisp/progmodes/compile.el 2012-05-04 23:16:47 +0000 +++ lisp/progmodes/compile.el 2012-05-06 04:52:58 +0000 @@ -1068,14 +1068,14 @@ end-marker loc end-loc) (if (not (and marker (marker-buffer marker))) (setq marker nil) ; no valid marker for this file - (setq loc (or line 1)) ; normalize no linenumber to line 1 + (unless line (setq line 1)) ; normalize no linenumber to line 1 (catch 'marker ; find nearest loc, at least one exists (dolist (x (cddr (compilation--file-struct->loc-tree file-struct))) ; Loop over remaining lines. - (if (> (car x) loc) ; Still bigger. + (if (> (car x) line) ; Still bigger. (setq marker-line x) - (if (> (- (or (car marker-line) 1) loc) - (- loc (car x))) ; Current line is nearer. + (if (> (- (or (car marker-line) 1) line) + (- line (car x))) ; Current line is nearer. (setq marker-line x)) (throw 'marker t)))) (setq marker (compilation--loc->marker (cadr marker-line)) @@ -1093,15 +1093,15 @@ (save-restriction (widen) (goto-char (marker-position marker)) - (when (or end-col end-line) + ;; Set end-marker if appropriate and go to line. + (if (not (or end-col end-line)) + (beginning-of-line (- line marker-line -1)) (beginning-of-line (- (or end-line line) marker-line -1)) (if (or (null end-col) (< end-col 0)) (end-of-line) (compilation-move-to-column end-col screen-columns)) - (setq end-marker (point-marker))) - (beginning-of-line (if end-line - (- line end-line -1) - (- loc marker-line -1))) + (setq end-marker (point-marker)) + (when end-line (beginning-of-line (- line end-line -1)))) (if col (compilation-move-to-column col screen-columns) (forward-to-indentation 0))