Line data Source code
1 : ;;; tabulated-list.el --- generic major mode for tabulated lists -*- lexical-binding: t -*-
2 :
3 : ;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
4 :
5 : ;; Author: Chong Yidong <cyd@stupidchicken.com>
6 : ;; Keywords: extensions, lisp
7 : ;; Version: 1.0
8 :
9 : ;; This file is part of GNU Emacs.
10 :
11 : ;; GNU Emacs is free software: you can redistribute it and/or modify
12 : ;; it under the terms of the GNU General Public License as published by
13 : ;; the Free Software Foundation, either version 3 of the License, or
14 : ;; (at your option) any later version.
15 :
16 : ;; GNU Emacs is distributed in the hope that it will be useful,
17 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 : ;; GNU General Public License for more details.
20 :
21 : ;; You should have received a copy of the GNU General Public License
22 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 :
24 : ;;; Commentary:
25 :
26 : ;; This file defines Tabulated List mode, a generic major mode for
27 : ;; displaying lists of tabulated data, intended for other major modes
28 : ;; to inherit from. It provides several utility routines, e.g. for
29 : ;; pretty-printing lines of tabulated data to fit into the appropriate
30 : ;; columns.
31 :
32 : ;; For usage information, see the documentation of `tabulated-list-mode'.
33 :
34 : ;; This package originated from Tom Tromey's Package Menu mode,
35 : ;; extended and generalized to be used by other modes.
36 :
37 : ;;; Code:
38 :
39 : ;; The reason `tabulated-list-format' and other variables are
40 : ;; permanent-local is to make it convenient to switch to a different
41 : ;; major mode, switch back, and have the original Tabulated List data
42 : ;; still valid. See, for example, ebuff-menu.el.
43 :
44 : (defvar-local tabulated-list-format nil
45 : "The format of the current Tabulated List mode buffer.
46 : This should be a vector of elements (NAME WIDTH SORT . PROPS),
47 : where:
48 : - NAME is a string describing the column.
49 : This is the label for the column in the header line.
50 : Different columns must have non-`equal' names.
51 : - WIDTH is the width to reserve for the column.
52 : For the final element, its numerical value is ignored.
53 : - SORT specifies how to sort entries by this column.
54 : If nil, this column cannot be used for sorting.
55 : If t, sort by comparing the string value printed in the column.
56 : Otherwise, it should be a predicate function suitable for
57 : `sort', accepting arguments with the same form as the elements
58 : of `tabulated-list-entries'.
59 : - PROPS is a plist of additional column properties.
60 : Currently supported properties are:
61 : - `:right-align': If non-nil, the column should be right-aligned.
62 : - `:pad-right': Number of additional padding spaces to the
63 : right of the column (defaults to 1 if omitted).")
64 : (put 'tabulated-list-format 'permanent-local t)
65 :
66 : (defvar-local tabulated-list-use-header-line t
67 : "Whether the Tabulated List buffer should use a header line.")
68 :
69 : (defvar-local tabulated-list-entries nil
70 : "Entries displayed in the current Tabulated List buffer.
71 : This should be either a function, or a list.
72 : If a list, each element has the form (ID [DESC1 ... DESCN]),
73 : where:
74 : - ID is nil, or a Lisp object uniquely identifying this entry,
75 : which is used to keep the cursor on the \"same\" entry when
76 : rearranging the list. Comparison is done with `equal'.
77 :
78 : - Each DESC is a column descriptor, one for each column
79 : specified in `tabulated-list-format'. A descriptor is either
80 : a string, which is printed as-is, or a list (LABEL . PROPS),
81 : which means to use `insert-text-button' to insert a text
82 : button with label LABEL and button properties PROPS.
83 : The string, or button label, must not contain any newline.
84 :
85 : If `tabulated-list-entries' is a function, it is called with no
86 : arguments and must return a list of the above form.")
87 : (put 'tabulated-list-entries 'permanent-local t)
88 :
89 : (defvar-local tabulated-list-padding 0
90 : "Number of characters preceding each Tabulated List mode entry.
91 : By default, lines are padded with spaces, but you can use the
92 : function `tabulated-list-put-tag' to change this.")
93 : (put 'tabulated-list-padding 'permanent-local t)
94 :
95 : (defvar tabulated-list-revert-hook nil
96 : "Hook run before reverting a Tabulated List buffer.
97 : This is commonly used to recompute `tabulated-list-entries'.")
98 :
99 : (defvar-local tabulated-list-printer 'tabulated-list-print-entry
100 : "Function for inserting a Tabulated List entry at point.
101 : It is called with two arguments, ID and COLS. ID is a Lisp
102 : object identifying the entry, and COLS is a vector of column
103 : descriptors, as documented in `tabulated-list-entries'.")
104 :
105 : (defvar tabulated-list--near-rows)
106 :
107 : (defvar-local tabulated-list-sort-key nil
108 : "Sort key for the current Tabulated List mode buffer.
109 : If nil, no additional sorting is performed.
110 : Otherwise, this should be a cons cell (NAME . FLIP).
111 : NAME is a string matching one of the column names in
112 : `tabulated-list-format' (the corresponding SORT entry in
113 : `tabulated-list-format' then specifies how to sort). FLIP, if
114 : non-nil, means to invert the resulting sort.")
115 : (put 'tabulated-list-sort-key 'permanent-local t)
116 :
117 : (defsubst tabulated-list-get-id (&optional pos)
118 : "Return the entry ID of the Tabulated List entry at POS.
119 : The value is an ID object from `tabulated-list-entries', or nil.
120 : POS, if omitted or nil, defaults to point."
121 0 : (get-text-property (or pos (point)) 'tabulated-list-id))
122 :
123 : (defsubst tabulated-list-get-entry (&optional pos)
124 : "Return the Tabulated List entry at POS.
125 : The value is a vector of column descriptors, or nil if there is
126 : no entry at POS. POS, if omitted or nil, defaults to point."
127 0 : (get-text-property (or pos (point)) 'tabulated-list-entry))
128 :
129 : (defun tabulated-list-put-tag (tag &optional advance)
130 : "Put TAG in the padding area of the current line.
131 : TAG should be a string, with length <= `tabulated-list-padding'.
132 : If ADVANCE is non-nil, move forward by one line afterwards."
133 0 : (unless (stringp tag)
134 0 : (error "Invalid argument to `tabulated-list-put-tag'"))
135 0 : (unless (> tabulated-list-padding 0)
136 0 : (error "Unable to tag the current line"))
137 0 : (save-excursion
138 0 : (beginning-of-line)
139 0 : (when (tabulated-list-get-entry)
140 0 : (let ((beg (point))
141 : (inhibit-read-only t))
142 0 : (forward-char tabulated-list-padding)
143 0 : (insert-and-inherit
144 0 : (let ((width (string-width tag)))
145 0 : (if (<= width tabulated-list-padding)
146 0 : (concat tag
147 0 : (make-string (- tabulated-list-padding width) ?\s))
148 0 : (truncate-string-to-width tag tabulated-list-padding))))
149 0 : (delete-region beg (+ beg tabulated-list-padding)))))
150 0 : (if advance
151 0 : (forward-line)))
152 :
153 : (defvar tabulated-list-mode-map
154 : (let ((map (copy-keymap special-mode-map)))
155 : (set-keymap-parent map button-buffer-map)
156 : (define-key map "n" 'next-line)
157 : (define-key map "p" 'previous-line)
158 : (define-key map "S" 'tabulated-list-sort)
159 : (define-key map [follow-link] 'mouse-face)
160 : (define-key map [mouse-2] 'mouse-select-window)
161 : map)
162 : "Local keymap for `tabulated-list-mode' buffers.")
163 :
164 : (defvar tabulated-list-sort-button-map
165 : (let ((map (make-sparse-keymap)))
166 : (define-key map [header-line mouse-1] 'tabulated-list-col-sort)
167 : (define-key map [header-line mouse-2] 'tabulated-list-col-sort)
168 : (define-key map [mouse-1] 'tabulated-list-col-sort)
169 : (define-key map [mouse-2] 'tabulated-list-col-sort)
170 : (define-key map "\C-m" 'tabulated-list-sort)
171 : (define-key map [follow-link] 'mouse-face)
172 : map)
173 : "Local keymap for `tabulated-list-mode' sort buttons.")
174 :
175 : (defvar tabulated-list-glyphless-char-display
176 : (let ((table (make-char-table 'glyphless-char-display nil)))
177 : (set-char-table-parent table glyphless-char-display)
178 : ;; Some text terminals can't display the Unicode arrows; be safe.
179 : (aset table 9650 (cons nil "^"))
180 : (aset table 9660 (cons nil "v"))
181 : table)
182 : "The `glyphless-char-display' table in Tabulated List buffers.")
183 :
184 : (defvar tabulated-list--header-string nil
185 : "Holds the header if `tabulated-list-use-header-line' is nil.
186 : Populated by `tabulated-list-init-header'.")
187 : (defvar tabulated-list--header-overlay nil)
188 :
189 : (defun tabulated-list-line-number-width ()
190 : "Return the width taken by display-line-numbers in the current buffer."
191 : ;; line-number-display-width returns the value for the selected
192 : ;; window, which might not be the window in which the current buffer
193 : ;; is displayed.
194 0 : (if (not display-line-numbers)
195 : 0
196 0 : (let ((cbuf-window (get-buffer-window (current-buffer))))
197 0 : (if (window-live-p cbuf-window)
198 0 : (with-selected-window cbuf-window
199 0 : (+ (line-number-display-width) 2))
200 0 : 4))))
201 :
202 : (defun tabulated-list-init-header ()
203 : "Set up header line for the Tabulated List buffer."
204 : ;; FIXME: Should share code with tabulated-list-print-col!
205 0 : (let ((x (max tabulated-list-padding 0))
206 0 : (button-props `(help-echo "Click to sort by column"
207 : mouse-face header-line-highlight
208 0 : keymap ,tabulated-list-sort-button-map))
209 : (cols nil))
210 0 : (if display-line-numbers
211 0 : (setq x (+ x (tabulated-list-line-number-width))))
212 0 : (push (propertize " " 'display `(space :align-to ,x)) cols)
213 0 : (dotimes (n (length tabulated-list-format))
214 0 : (let* ((col (aref tabulated-list-format n))
215 0 : (label (nth 0 col))
216 0 : (width (nth 1 col))
217 0 : (props (nthcdr 3 col))
218 0 : (pad-right (or (plist-get props :pad-right) 1))
219 0 : (right-align (plist-get props :right-align))
220 0 : (next-x (+ x pad-right width)))
221 0 : (push
222 0 : (cond
223 : ;; An unsortable column
224 0 : ((not (nth 2 col))
225 0 : (propertize label 'tabulated-list-column-name label))
226 : ;; The selected sort column
227 0 : ((equal (car col) (car tabulated-list-sort-key))
228 0 : (apply 'propertize
229 0 : (concat label
230 0 : (cond
231 0 : ((> (+ 2 (length label)) width) "")
232 0 : ((cdr tabulated-list-sort-key) " ▲")
233 0 : (t " ▼")))
234 : 'face 'bold
235 0 : 'tabulated-list-column-name label
236 0 : button-props))
237 : ;; Unselected sortable column.
238 0 : (t (apply 'propertize label
239 0 : 'tabulated-list-column-name label
240 0 : button-props)))
241 0 : cols)
242 0 : (when right-align
243 0 : (let ((shift (- width (string-width (car cols)))))
244 0 : (when (> shift 0)
245 0 : (setq cols
246 0 : (cons (car cols)
247 0 : (cons (propertize (make-string shift ?\s)
248 : 'display
249 0 : `(space :align-to ,(+ x shift)))
250 0 : (cdr cols))))
251 0 : (setq x (+ x shift)))))
252 0 : (if (>= pad-right 0)
253 0 : (push (propertize " "
254 0 : 'display `(space :align-to ,next-x)
255 0 : 'face 'fixed-pitch)
256 0 : cols))
257 0 : (setq x next-x)))
258 0 : (setq cols (apply 'concat (nreverse cols)))
259 0 : (if tabulated-list-use-header-line
260 0 : (setq header-line-format cols)
261 0 : (setq header-line-format nil)
262 0 : (setq-local tabulated-list--header-string cols))))
263 :
264 : (defun tabulated-list-print-fake-header ()
265 : "Insert a fake Tabulated List \"header line\" at the start of the buffer.
266 : Do nothing if `tabulated-list--header-string' is nil."
267 0 : (when tabulated-list--header-string
268 0 : (goto-char (point-min))
269 0 : (let ((inhibit-read-only t))
270 0 : (insert tabulated-list--header-string "\n")
271 0 : (if tabulated-list--header-overlay
272 0 : (move-overlay tabulated-list--header-overlay (point-min) (point))
273 0 : (setq-local tabulated-list--header-overlay
274 0 : (make-overlay (point-min) (point))))
275 0 : (overlay-put tabulated-list--header-overlay 'face 'underline))))
276 :
277 : (defsubst tabulated-list-header-overlay-p (&optional pos)
278 : "Return non-nil if there is a fake header.
279 : Optional arg POS is a buffer position where to look for a fake header;
280 : defaults to `point-min'."
281 0 : (overlays-at (or pos (point-min))))
282 :
283 : (defun tabulated-list-revert (&rest ignored)
284 : "The `revert-buffer-function' for `tabulated-list-mode'.
285 : It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'."
286 : (interactive)
287 0 : (unless (derived-mode-p 'tabulated-list-mode)
288 0 : (error "The current buffer is not in Tabulated List mode"))
289 0 : (run-hooks 'tabulated-list-revert-hook)
290 0 : (tabulated-list-print t))
291 :
292 : (defun tabulated-list--column-number (name)
293 0 : (let ((len (length tabulated-list-format))
294 : (n 0)
295 : found)
296 0 : (while (and (< n len) (null found))
297 0 : (if (equal (car (aref tabulated-list-format n)) name)
298 0 : (setq found n))
299 0 : (setq n (1+ n)))
300 0 : (or found
301 0 : (error "No column named %s" name))))
302 :
303 : (defun tabulated-list--get-sorter ()
304 : "Return a sorting predicate for the current tabulated-list.
305 : Return nil if `tabulated-list-sort-key' specifies an unsortable
306 : column. Negate the predicate that would be returned if
307 : `tabulated-list-sort-key' has a non-nil cdr."
308 0 : (when (and tabulated-list-sort-key
309 0 : (car tabulated-list-sort-key))
310 0 : (let* ((sort-column (car tabulated-list-sort-key))
311 0 : (n (tabulated-list--column-number sort-column))
312 0 : (sorter (nth 2 (aref tabulated-list-format n))))
313 0 : (when (eq sorter t); Default sorter checks column N:
314 0 : (setq sorter (lambda (A B)
315 0 : (let ((a (aref (cadr A) n))
316 0 : (b (aref (cadr B) n)))
317 0 : (string< (if (stringp a) a (car a))
318 0 : (if (stringp b) b (car b)))))))
319 : ;; Reversed order.
320 0 : (if (cdr tabulated-list-sort-key)
321 0 : (lambda (a b) (not (funcall sorter a b)))
322 0 : sorter))))
323 :
324 : (defsubst tabulated-list--col-local-max-widths (col)
325 : "Return maximum entry widths at column COL around current row.
326 : Check the current row, the previous one and the next row."
327 0 : (apply #'max (mapcar (lambda (x)
328 0 : (let ((nt (elt x col)))
329 0 : (string-width (if (stringp nt) nt (car nt)))))
330 0 : tabulated-list--near-rows)))
331 :
332 : (defun tabulated-list-print (&optional remember-pos update)
333 : "Populate the current Tabulated List mode buffer.
334 : This sorts the `tabulated-list-entries' list if sorting is
335 : specified by `tabulated-list-sort-key'. It then erases the
336 : buffer and inserts the entries with `tabulated-list-printer'.
337 :
338 : Optional argument REMEMBER-POS, if non-nil, means to move point
339 : to the entry with the same ID element as the current line and
340 : recenter window line accordingly.
341 :
342 : Non-nil UPDATE argument means to use an alternative printing
343 : method which is faster if most entries haven't changed since the
344 : last print. The only difference in outcome is that tags will not
345 : be removed from entries that haven't changed (see
346 : `tabulated-list-put-tag'). Don't use this immediately after
347 : changing `tabulated-list-sort-key'."
348 0 : (let ((inhibit-read-only t)
349 0 : (entries (if (functionp tabulated-list-entries)
350 0 : (funcall tabulated-list-entries)
351 0 : tabulated-list-entries))
352 0 : (sorter (tabulated-list--get-sorter))
353 : entry-id saved-pt saved-col window-line)
354 0 : (and remember-pos
355 0 : (setq entry-id (tabulated-list-get-id))
356 0 : (setq saved-col (current-column))
357 0 : (when (eq (window-buffer) (current-buffer))
358 0 : (setq window-line
359 0 : (count-screen-lines (window-start) (point)))))
360 : ;; Sort the entries, if necessary.
361 0 : (when sorter
362 0 : (setq entries (sort entries sorter)))
363 0 : (unless (functionp tabulated-list-entries)
364 0 : (setq tabulated-list-entries entries))
365 : ;; Without a sorter, we have no way to just update.
366 0 : (when (and update (not sorter))
367 0 : (setq update nil))
368 0 : (if update (goto-char (point-min))
369 : ;; Redo the buffer, unless we're just updating.
370 0 : (erase-buffer)
371 0 : (unless tabulated-list-use-header-line
372 0 : (tabulated-list-print-fake-header)))
373 : ;; Finally, print the resulting list.
374 0 : (while entries
375 0 : (let* ((elt (car entries))
376 : (tabulated-list--near-rows
377 0 : (list
378 0 : (or (tabulated-list-get-entry (point-at-bol 0)) (cadr elt))
379 0 : (cadr elt)
380 0 : (or (cadr (cadr entries)) (cadr elt))))
381 0 : (id (car elt)))
382 0 : (and entry-id
383 0 : (equal entry-id id)
384 0 : (setq entry-id nil
385 0 : saved-pt (point)))
386 : ;; If the buffer this empty, simply print each elt.
387 0 : (if (or (not update) (eobp))
388 0 : (apply tabulated-list-printer elt)
389 0 : (while (let ((local-id (tabulated-list-get-id)))
390 : ;; If we find id, then nothing to update.
391 0 : (cond ((equal id local-id)
392 0 : (forward-line 1)
393 : nil)
394 : ;; If this entry sorts after id (or it's the
395 : ;; end), then just insert id and move on.
396 0 : ((or (not local-id)
397 0 : (funcall sorter elt
398 : ;; FIXME: Might be faster if
399 : ;; don't construct this list.
400 0 : (list local-id (tabulated-list-get-entry))))
401 0 : (apply tabulated-list-printer elt)
402 : nil)
403 : ;; We find an entry that sorts before id,
404 : ;; it needs to be deleted.
405 0 : (t t)))
406 0 : (let ((old (point)))
407 0 : (forward-line 1)
408 0 : (delete-region old (point))))))
409 0 : (setq entries (cdr entries)))
410 0 : (set-buffer-modified-p nil)
411 : ;; If REMEMBER-POS was specified, move to the "old" location.
412 0 : (if saved-pt
413 0 : (progn (goto-char saved-pt)
414 0 : (move-to-column saved-col)
415 0 : (when window-line
416 0 : (recenter window-line)))
417 0 : (goto-char (point-min)))))
418 :
419 : (defun tabulated-list-print-entry (id cols)
420 : "Insert a Tabulated List entry at point.
421 : This is the default `tabulated-list-printer' function. ID is a
422 : Lisp object identifying the entry to print, and COLS is a vector
423 : of column descriptors."
424 0 : (let ((beg (point))
425 0 : (x (max tabulated-list-padding 0))
426 0 : (ncols (length tabulated-list-format))
427 0 : (lnum-width (tabulated-list-line-number-width))
428 : (inhibit-read-only t))
429 0 : (if display-line-numbers
430 0 : (setq x (+ x lnum-width)))
431 0 : (if (> tabulated-list-padding 0)
432 0 : (insert (make-string (- x lnum-width) ?\s)))
433 0 : (let ((tabulated-list--near-rows ; Bind it if not bound yet (Bug#25506).
434 0 : (or (bound-and-true-p tabulated-list--near-rows)
435 0 : (list (or (tabulated-list-get-entry (point-at-bol 0))
436 0 : cols)
437 0 : cols))))
438 0 : (dotimes (n ncols)
439 0 : (setq x (tabulated-list-print-col n (aref cols n) x))))
440 0 : (insert ?\n)
441 : ;; Ever so slightly faster than calling `put-text-property' twice.
442 0 : (add-text-properties
443 0 : beg (point)
444 0 : `(tabulated-list-id ,id tabulated-list-entry ,cols))))
445 :
446 : (defun tabulated-list-print-col (n col-desc x)
447 : "Insert a specified Tabulated List entry at point.
448 : N is the column number, COL-DESC is a column descriptor (see
449 : `tabulated-list-entries'), and X is the column number at point.
450 : Return the column number after insertion."
451 0 : (let* ((format (aref tabulated-list-format n))
452 0 : (name (nth 0 format))
453 0 : (width (nth 1 format))
454 0 : (props (nthcdr 3 format))
455 0 : (pad-right (or (plist-get props :pad-right) 1))
456 0 : (right-align (plist-get props :right-align))
457 0 : (label (if (stringp col-desc) col-desc (car col-desc)))
458 0 : (label-width (string-width label))
459 0 : (help-echo (concat (car format) ": " label))
460 0 : (opoint (point))
461 0 : (not-last-col (< (1+ n) (length tabulated-list-format)))
462 : available-space)
463 0 : (when not-last-col
464 0 : (let* ((next-col-format (aref tabulated-list-format (1+ n)))
465 0 : (next-col-right-align (plist-get (nthcdr 3 next-col-format)
466 0 : :right-align))
467 0 : (next-col-width (nth 1 next-col-format)))
468 0 : (setq available-space
469 0 : (if (and (not right-align)
470 0 : next-col-right-align)
471 0 : (-
472 0 : (+ width next-col-width)
473 0 : (min next-col-width
474 0 : (tabulated-list--col-local-max-widths (1+ n))))
475 0 : width))))
476 : ;; Truncate labels if necessary (except last column).
477 : ;; Don't truncate to `width' if the next column is align-right
478 : ;; and has some space left, truncate to `available-space' instead.
479 0 : (when (and not-last-col
480 0 : (> label-width available-space)
481 0 : (setq label (truncate-string-to-width
482 0 : label available-space nil nil t)
483 0 : label-width available-space)))
484 0 : (setq label (bidi-string-mark-left-to-right label))
485 0 : (when (and right-align (> width label-width))
486 0 : (let ((shift (- width label-width)))
487 0 : (insert (propertize (make-string shift ?\s)
488 0 : 'display `(space :align-to ,(+ x shift))))
489 0 : (setq width (- width shift))
490 0 : (setq x (+ x shift))))
491 0 : (if (stringp col-desc)
492 0 : (insert (if (get-text-property 0 'help-echo label)
493 0 : label
494 0 : (propertize label 'help-echo help-echo)))
495 0 : (apply 'insert-text-button label (cdr col-desc)))
496 0 : (let ((next-x (+ x pad-right width)))
497 : ;; No need to append any spaces if this is the last column.
498 0 : (when not-last-col
499 0 : (when (> pad-right 0) (insert (make-string pad-right ?\s)))
500 0 : (insert (propertize
501 0 : (make-string (- width (min width label-width)) ?\s)
502 0 : 'display `(space :align-to ,next-x))))
503 0 : (put-text-property opoint (point) 'tabulated-list-column-name name)
504 0 : next-x)))
505 :
506 : (defun tabulated-list-delete-entry ()
507 : "Delete the Tabulated List entry at point.
508 : Return a list (ID COLS), where ID is the ID of the deleted entry
509 : and COLS is a vector of its column descriptors. Move point to
510 : the beginning of the deleted entry. Return nil if there is no
511 : entry at point.
512 :
513 : This function only changes the buffer contents; it does not alter
514 : `tabulated-list-entries'."
515 : ;; Assume that each entry occupies one line.
516 0 : (let* ((id (tabulated-list-get-id))
517 0 : (cols (tabulated-list-get-entry))
518 : (inhibit-read-only t))
519 0 : (when cols
520 0 : (delete-region (line-beginning-position) (1+ (line-end-position)))
521 0 : (list id cols))))
522 :
523 : (defun tabulated-list-set-col (col desc &optional change-entry-data)
524 : "Change the Tabulated List entry at point, setting COL to DESC.
525 : COL is the column number to change, or the name of the column to change.
526 : DESC is the new column descriptor, which is inserted via
527 : `tabulated-list-print-col'.
528 :
529 : If CHANGE-ENTRY-DATA is non-nil, modify the underlying entry data
530 : by setting the appropriate slot of the vector originally used to
531 : print this entry. If `tabulated-list-entries' has a list value,
532 : this is the vector stored within it."
533 0 : (let* ((opoint (point))
534 0 : (eol (line-end-position))
535 0 : (pos (line-beginning-position))
536 0 : (id (tabulated-list-get-id pos))
537 0 : (entry (tabulated-list-get-entry pos))
538 : (prop 'tabulated-list-column-name)
539 : (inhibit-read-only t)
540 : name)
541 0 : (cond ((numberp col)
542 0 : (setq name (car (aref tabulated-list-format col))))
543 0 : ((stringp col)
544 0 : (setq name col
545 0 : col (tabulated-list--column-number col)))
546 : (t
547 0 : (error "Invalid column %s" col)))
548 0 : (unless entry
549 0 : (error "No Tabulated List entry at position %s" opoint))
550 0 : (unless (equal (get-text-property pos prop) name)
551 0 : (while (and (setq pos
552 0 : (next-single-property-change pos prop nil eol))
553 0 : (< pos eol)
554 0 : (not (equal (get-text-property pos prop) name)))))
555 0 : (when (< pos eol)
556 0 : (delete-region pos (next-single-property-change pos prop nil eol))
557 0 : (goto-char pos)
558 0 : (let ((tabulated-list--near-rows
559 0 : (list
560 0 : (tabulated-list-get-entry (point-at-bol 0))
561 0 : entry
562 0 : (or (tabulated-list-get-entry (point-at-bol 2)) entry))))
563 0 : (tabulated-list-print-col col desc (current-column)))
564 0 : (if change-entry-data
565 0 : (aset entry col desc))
566 0 : (put-text-property pos (point) 'tabulated-list-id id)
567 0 : (put-text-property pos (point) 'tabulated-list-entry entry)
568 0 : (goto-char opoint))))
569 :
570 : (defun tabulated-list-col-sort (&optional e)
571 : "Sort Tabulated List entries by the column of the mouse click E."
572 : (interactive "e")
573 0 : (let* ((pos (event-start e))
574 0 : (obj (posn-object pos)))
575 0 : (with-current-buffer (window-buffer (posn-window pos))
576 0 : (tabulated-list--sort-by-column-name
577 0 : (get-text-property (if obj (cdr obj) (posn-point pos))
578 : 'tabulated-list-column-name
579 0 : (car obj))))))
580 :
581 : (defun tabulated-list-sort (&optional n)
582 : "Sort Tabulated List entries by the column at point.
583 : With a numeric prefix argument N, sort the Nth column."
584 : (interactive "P")
585 0 : (let ((name (if n
586 0 : (car (aref tabulated-list-format n))
587 0 : (get-text-property (point)
588 0 : 'tabulated-list-column-name))))
589 0 : (if (nth 2 (assoc name (append tabulated-list-format nil)))
590 0 : (tabulated-list--sort-by-column-name name)
591 0 : (user-error "Cannot sort by %s" name))))
592 :
593 : (defun tabulated-list--sort-by-column-name (name)
594 0 : (when (and name (derived-mode-p 'tabulated-list-mode))
595 : ;; Flip the sort order on a second click.
596 0 : (if (equal name (car tabulated-list-sort-key))
597 0 : (setcdr tabulated-list-sort-key
598 0 : (not (cdr tabulated-list-sort-key)))
599 0 : (setq tabulated-list-sort-key (cons name nil)))
600 0 : (tabulated-list-init-header)
601 0 : (tabulated-list-print t)))
602 :
603 : ;;; The mode definition:
604 :
605 : (define-derived-mode tabulated-list-mode special-mode "Tabulated"
606 : "Generic major mode for browsing a list of items.
607 : This mode is usually not used directly; instead, other major
608 : modes are derived from it, using `define-derived-mode'.
609 :
610 : In this major mode, the buffer is divided into multiple columns,
611 : which are labeled using the header line. Each non-empty line
612 : belongs to one \"entry\", and the entries can be sorted according
613 : to their column values.
614 :
615 : An inheriting mode should usually do the following in their body:
616 :
617 : - Set `tabulated-list-format', specifying the column format.
618 : - Set `tabulated-list-revert-hook', if the buffer contents need
619 : to be specially recomputed prior to `revert-buffer'.
620 : - Maybe set a `tabulated-list-entries' function (see below).
621 : - Maybe set `tabulated-list-printer' (see below).
622 : - Maybe set `tabulated-list-padding'.
623 : - Call `tabulated-list-init-header' to initialize `header-line-format'
624 : according to `tabulated-list-format'.
625 :
626 : An inheriting mode is usually accompanied by a \"list-FOO\"
627 : command (e.g. `list-packages', `list-processes'). This command
628 : creates or switches to a buffer and enables the major mode in
629 : that buffer. If `tabulated-list-entries' is not a function, the
630 : command should initialize it to a list of entries for displaying.
631 : Finally, it should call `tabulated-list-print'.
632 :
633 : `tabulated-list-print' calls the printer function specified by
634 : `tabulated-list-printer', once for each entry. The default
635 : printer is `tabulated-list-print-entry', but a mode that keeps
636 : data in an ewoc may instead specify a printer function (e.g., one
637 : that calls `ewoc-enter-last'), with `tabulated-list-print-entry'
638 : as the ewoc pretty-printer."
639 0 : (setq-local truncate-lines t)
640 0 : (setq-local buffer-undo-list t)
641 0 : (setq-local revert-buffer-function #'tabulated-list-revert)
642 0 : (setq-local glyphless-char-display tabulated-list-glyphless-char-display)
643 : ;; Avoid messing up the entries' display just because the first
644 : ;; column of the first entry happens to begin with a R2L letter.
645 0 : (setq bidi-paragraph-direction 'left-to-right)
646 : ;; This is for if/when they turn on display-line-numbers
647 0 : (add-hook 'display-line-numbers-mode-hook #'tabulated-list-revert nil t))
648 :
649 : (put 'tabulated-list-mode 'mode-class 'special)
650 :
651 : (provide 'tabulated-list)
652 :
653 : ;;; tabulated-list.el ends here
|