1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
|
;;; tabulated-list.el --- generic major mode for tabulated lists.
;; Copyright (C) 2011 Free Software Foundation, Inc.
;; Author: Chong Yidong <cyd@stupidchicken.com>
;; Keywords: extensions, lisp
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; 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.
;; 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.
;;; 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:
- NAME is a string describing the column.
- 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.
If nil, this column cannot be used for sorting.
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'.")
(make-variable-buffer-local 'tabulated-list-format)
(defvar tabulated-list-entries nil
"Entries displayed in the current Tabulated List buffer.
This should be either a function, or a list.
If a list, each element has the form (ID [DESC1 ... DESCN]),
where:
- ID is nil, or a Lisp object uniquely identifying this entry,
which is used to keep the cursor on the \"same\" entry when
rearranging the list. Comparison is done with `equal'.
- Each DESC is a column descriptor, one for each column
specified in `tabulated-list-format'. A descriptor is either
a string, which is printed as-is, or a list (LABEL . PROPS),
which means to use `insert-text-button' to insert a text
button with label LABEL and button properties PROPS.
The string, or button label, must not contain any newline.
If `tabulated-list-entries' is a function, it is called with no
arguments and must return a list of the above form.")
(make-variable-buffer-local 'tabulated-list-entries)
(defvar tabulated-list-padding 0
"Number of characters preceding each Tabulated List mode entry.
By default, lines are padded with spaces, but you can use the
function `tabulated-list-put-tag' to change this.")
(make-variable-buffer-local 'tabulated-list-padding)
(defvar tabulated-list-revert-hook nil
"Hook run before reverting a Tabulated List buffer.
This is commonly used to recompute `tabulated-list-entries'.")
(defvar tabulated-list-printer 'tabulated-list-print-entry
"Function for inserting a Tabulated List entry at point.
It is called with two arguments, ID and COLS. ID is a Lisp
object identifying the entry, and COLS is a vector of column
descriptors, as documented in `tabulated-list-entries'.")
(make-variable-buffer-local 'tabulated-list-printer)
(defvar tabulated-list-sort-key nil
"Sort key for the current Tabulated List mode buffer.
If nil, no additional sorting is performed.
Otherwise, this should be a cons cell (NAME . FLIP).
NAME is a string matching one of the column names in
`tabulated-list-format' (the corresponding SORT entry in
`tabulated-list-format' then specifies how to sort). FLIP, if
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.
POS, if omitted or nil, defaults to point."
(get-text-property (or pos (point)) 'tabulated-list-id))
(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'.
If ADVANCE is non-nil, move forward by one line afterwards."
(unless (stringp tag)
(error "Invalid argument to `tabulated-list-put-tag'"))
(unless (> tabulated-list-padding 0)
(error "Unable to tag the current line"))
(save-excursion
(beginning-of-line)
(when (get-text-property (point) 'tabulated-list-id)
(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)))
(delete-region beg (+ beg tabulated-list-padding)))))
(if advance
(forward-line)))
(defvar tabulated-list-mode-map
(let ((map (copy-keymap special-mode-map)))
(set-keymap-parent map button-buffer-map)
(define-key map "n" 'next-line)
(define-key map "p" 'previous-line)
(define-key map [follow-link] 'mouse-face)
(define-key map [mouse-2] 'mouse-select-window)
map)
"Local keymap for `tabulated-list-mode' buffers.")
(defvar tabulated-list-sort-button-map
(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 [follow-link] 'mouse-face)
map)
"Local keymap for `tabulated-list-mode' sort buttons.")
(defvar tabulated-list-glyphless-char-display
(let ((table (make-char-table 'glyphless-char-display nil)))
(set-char-table-parent table glyphless-char-display)
;; Some text terminals can't display the Unicode arrows; be safe.
(aset table 9650 (cons nil "^"))
(aset table 9660 (cons nil "v"))
table)
"The `glyphless-char-display' table in Tabulated List buffers.")
(defun tabulated-list-init-header ()
"Set up header line for the Tabulated List buffer."
(let ((x tabulated-list-padding)
(button-props `(help-echo "Click to sort by column"
mouse-face highlight
keymap ,tabulated-list-sort-button-map))
(cols nil))
(if (> tabulated-list-padding 0)
(push (propertize " " 'display `(space :align-to ,x)) cols))
(dotimes (n (length tabulated-list-format))
(let* ((col (aref tabulated-list-format n))
(width (nth 1 col))
(label (car col)))
(setq x (+ x 1 width))
(and (<= tabulated-list-padding 0)
(= n 0)
(setq label (concat " " label)))
(push
(cond
;; An unsortable column
((not (nth 2 col)) label)
;; The selected sort column
((equal (car col) (car tabulated-list-sort-key))
(apply 'propertize
(concat label
(cond
((> (+ 2 (length label)) width)
"")
((cdr tabulated-list-sort-key)
" ▲")
(t " ▼")))
'face 'bold
'tabulated-list-column-name (car col)
button-props))
;; Unselected sortable column.
(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))
(setq header-line-format (mapconcat 'identity (nreverse cols) ""))))
(defun tabulated-list-revert (&rest ignored)
"The `revert-buffer-function' for `tabulated-list-mode'.
It runs `tabulated-list-revert-hook', then calls `tabulated-list-print'."
(interactive)
(unless (derived-mode-p 'tabulated-list-mode)
(error "The current buffer is not in Tabulated List mode"))
(run-hooks 'tabulated-list-revert-hook)
(tabulated-list-print t))
(defun tabulated-list-print (&optional remember-pos)
"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."
(let ((inhibit-read-only t)
(entries (if (functionp 'tabulated-list-entries)
(funcall tabulated-list-entries)
tabulated-list-entries))
entry-id saved-pt saved-col)
(and remember-pos
(setq entry-id (tabulated-list-get-id))
(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 (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.
(dolist (elt entries)
(and entry-id
(equal entry-id (car elt))
(setq saved-pt (point)))
(apply tabulated-list-printer elt))
(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)
(recenter))
(goto-char (point-min)))))
(defun tabulated-list-print-entry (id cols)
"Insert a Tabulated List entry at point.
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)))
(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.
(and (> width 6)
(> (length label) width)
(setq label (concat (substring label 0 (- width 3))
"...")))
(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)))
(insert ?\n)
(put-text-property beg (point) 'tabulated-list-id id)))
(defun tabulated-list-col-sort (&optional e)
"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))))
(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)))))
;;; 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
modes are derived from it, using `define-derived-mode'.
In this major mode, the buffer is divided into multiple columns,
which are labeled using the header line. Each non-empty line
belongs to one \"entry\", and the entries can be sorted according
to their column values.
An inheriting mode should usually do the following in their body:
- Set `tabulated-list-format', specifying the column format.
- Set `tabulated-list-revert-hook', if the buffer contents need
to be specially recomputed prior to `revert-buffer'.
- Maybe set a `tabulated-list-entries' function (see below).
- Maybe set `tabulated-list-printer' (see below).
- Maybe set `tabulated-list-padding'.
- Call `tabulated-list-init-header' to initialize `header-line-format'
according to `tabulated-list-format'.
An inheriting mode is usually accompanied by a \"list-FOO\"
command (e.g. `list-packages', `list-processes'). This command
creates or switches to a buffer and enables the major mode in
that buffer. If `tabulated-list-entries' is not a function, the
command should initialize it to a list of entries for displaying.
Finally, it should call `tabulated-list-print'.
`tabulated-list-print' calls the printer function specified by
`tabulated-list-printer', once for each entry. The default
printer is `tabulated-list-print-entry', but a mode that keeps
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 truncate-lines t)
(setq buffer-read-only t)
(set (make-local-variable 'revert-buffer-function)
'tabulated-list-revert)
(set (make-local-variable 'glyphless-char-display)
tabulated-list-glyphless-char-display))
(put 'tabulated-list-mode 'mode-class 'special)
(provide 'tabulated-list)
;; Local Variables:
;; coding: utf-8
;; lexical-binding: t
;; End:
;;; tabulated-list.el ends here
|