X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/98284ef51c67fa69796946466337d426ab81f9ee..7b45cc583c4f16cc070a9925431ca944f510a685:/lisp/emacs-lisp/tabulated-list.el diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 15a0914cb1..00b029d8f3 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -1,6 +1,6 @@ ;;; tabulated-list.el --- generic major mode for tabulated lists -*- lexical-binding: t -*- -;; Copyright (C) 2011-2015 Free Software Foundation, Inc. +;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ;; Author: Chong Yidong ;; Keywords: extensions, lisp @@ -179,7 +179,9 @@ If ADVANCE is non-nil, move forward by one line afterwards." table) "The `glyphless-char-display' table in Tabulated List buffers.") -(defvar tabulated-list--header-string nil) +(defvar tabulated-list--header-string nil + "Holds the header if `tabulated-list-use-header-line' is nil. +Populated by `tabulated-list-init-header'.") (defvar tabulated-list--header-overlay nil) (defun tabulated-list-init-header () @@ -243,15 +245,17 @@ If ADVANCE is non-nil, move forward by one line afterwards." (setq-local 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)) - (setq-local tabulated-list--header-overlay - (make-overlay (point-min) (point)))) - (overlay-put tabulated-list--header-overlay 'face 'underline))) + "Insert a fake Tabulated List \"header line\" at the start of the buffer. +Do nothing if `tabulated-list--header-string' is nil." + (when tabulated-list--header-string + (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)) + (setq-local 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'. @@ -273,58 +277,105 @@ It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'." (or found (error "No column named %s" name)))) -(defun tabulated-list-print (&optional remember-pos) +(defun tabulated-list--get-sorter () + "Return a sorting predicate for the current tabulated-list. +Return nil if `tabulated-list-sort-key' specifies an unsortable +column. Negate the predicate that would be returned if +`tabulated-list-sort-key' has a non-nil cdr." + (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)))) + (when (eq sorter t); Default sorter checks column N: + (setq sorter (lambda (A B) + (let ((a (aref (cadr A) n)) + (b (aref (cadr B) n))) + (string< (if (stringp a) a (car a)) + (if (stringp b) b (car b))))))) + ;; Reversed order. + (if (cdr tabulated-list-sort-key) + (lambda (a b) (not (funcall sorter a b))) + sorter)))) + +(defun tabulated-list-print (&optional remember-pos update) "Populate the current Tabulated List mode buffer. This sorts the `tabulated-list-entries' list if sorting is specified by `tabulated-list-sort-key'. It then erases the buffer and inserts the entries with `tabulated-list-printer'. Optional argument REMEMBER-POS, if non-nil, means to move point -to the entry with the same ID element as the current line." +to the entry with the same ID element as the current line and +recenter window line accordingly. + +Non-nil UPDATE argument means to use an alternative printing +method which is faster if most entries haven't changed since the +last print. The only difference in outcome is that tags will not +be removed from entries that haven't changed (see +`tabulated-list-put-tag'). Don't use this immediately after +changing `tabulated-list-sort-key'." (let ((inhibit-read-only t) (entries (if (functionp tabulated-list-entries) (funcall tabulated-list-entries) tabulated-list-entries)) - entry-id saved-pt saved-col) + (sorter (tabulated-list--get-sorter)) + entry-id saved-pt saved-col window-line) (and remember-pos (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)) + (setq saved-col (current-column)) + (when (eq (window-buffer) (current-buffer)) + (setq window-line + (count-screen-lines (window-start) (point))))) ;; Sort the entries, if necessary. - (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) - (setq A (aref (cadr A) n)) - (setq B (aref (cadr B) n)) - (string< (if (stringp A) A (car A)) - (if (stringp B) B (car B)))))) - (setq entries (sort entries sorter)) - (if (cdr tabulated-list-sort-key) - (setq entries (nreverse entries))) - (unless (functionp tabulated-list-entries) - (setq tabulated-list-entries entries))))) - ;; Print the resulting list. + (when sorter + (setq entries (sort entries sorter))) + (unless (functionp tabulated-list-entries) + (setq tabulated-list-entries entries)) + ;; Without a sorter, we have no way to just update. + (when (and update (not sorter)) + (setq update nil)) + (if update (goto-char (point-min)) + ;; Redo the buffer, unless we're just updating. + (erase-buffer) + (unless tabulated-list-use-header-line + (tabulated-list-print-fake-header))) + ;; Finally, print the resulting list. (dolist (elt entries) - (and entry-id - (equal entry-id (car elt)) - (setq saved-pt (point))) - (apply tabulated-list-printer elt)) + (let ((id (car elt))) + (and entry-id + (equal entry-id id) + (setq entry-id nil + saved-pt (point))) + ;; If the buffer this empty, simply print each elt. + (if (or (not update) (eobp)) + (apply tabulated-list-printer elt) + (while (let ((local-id (tabulated-list-get-id))) + ;; If we find id, then nothing to update. + (cond ((equal id local-id) + (forward-line 1) + nil) + ;; If this entry sorts after id (or it's the + ;; end), then just insert id and move on. + ((or (not local-id) + (funcall sorter elt + ;; FIXME: Might be faster if + ;; don't construct this list. + (list local-id (tabulated-list-get-entry)))) + (apply tabulated-list-printer elt) + nil) + ;; We find an entry that sorts before id, + ;; it needs to be deleted. + (t t))) + (let ((old (point))) + (forward-line 1) + (delete-region old (point))))))) (set-buffer-modified-p nil) ;; If REMEMBER-POS was specified, move to the "old" location. (if saved-pt (progn (goto-char saved-pt) (move-to-column saved-col) - (when (eq (window-buffer) (current-buffer)) - (recenter))) + (when window-line + (recenter window-line))) (goto-char (point-min))))) (defun tabulated-list-print-entry (id cols) @@ -341,8 +392,10 @@ of column descriptors." (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-entry cols))) + ;; Ever so slightly faster than calling `put-text-property' twice. + (add-text-properties + beg (point) + `(tabulated-list-id ,id tabulated-list-entry ,cols)))) (defun tabulated-list-print-col (n col-desc x) "Insert a specified Tabulated List entry at point. @@ -467,7 +520,9 @@ With a numeric prefix argument N, sort the Nth column." (car (aref tabulated-list-format n)) (get-text-property (point) 'tabulated-list-column-name)))) - (tabulated-list--sort-by-column-name name))) + (if (nth 2 (assoc name (append tabulated-list-format nil))) + (tabulated-list--sort-by-column-name name) + (user-error "Cannot sort by %s" name)))) (defun tabulated-list--sort-by-column-name (name) (when (and name (derived-mode-p 'tabulated-list-mode)) @@ -516,7 +571,6 @@ data in an ewoc may instead specify a printer function (e.g., one that calls `ewoc-enter-last'), with `tabulated-list-print-entry' as the ewoc pretty-printer." (setq-local truncate-lines t) - (setq-local buffer-read-only t) (setq-local buffer-undo-list t) (setq-local revert-buffer-function #'tabulated-list-revert) (setq-local glyphless-char-display tabulated-list-glyphless-char-display) @@ -528,8 +582,4 @@ as the ewoc pretty-printer." (provide 'tabulated-list) -;; Local Variables: -;; coding: utf-8 -;; End: - ;;; tabulated-list.el ends here