LCOV - code coverage report
Current view: top level - lisp/emacs-lisp - tabulated-list.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 0 300 0.0 %
Date: 2017-08-30 10:12:24 Functions: 0 23 0.0 %

          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

Generated by: LCOV version 1.12