+++ /dev/null
-;;; tablist-autoloads.el --- automatically extracted autoloads
-;;
-;;; Code:
-(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
-\f
-;;;### (autoloads nil "tablist" "tablist.el" (23994 46395 211954
-;;;;;; 236000))
-;;; Generated autoloads from tablist.el
-
-(autoload 'tablist-minor-mode "tablist" "\
-Toggle Tablist minor mode on or off.
-With a prefix argument ARG, enable Tablist minor mode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil, and toggle it if ARG is `toggle'.
-\\{tablist-minor-mode-map}
-
-\(fn &optional ARG)" t nil)
-
-(autoload 'tablist-mode "tablist" "\
-
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil nil ("tablist-filter.el" "tablist-pkg.el")
-;;;;;; (23994 46395 210438 171000))
-
-;;;***
-\f
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; End:
-;;; tablist-autoloads.el ends here
+++ /dev/null
-;;; tablist-filter.el --- Filter expressions for tablists. -*- lexical-binding:t -*-
-
-;; Copyright (C) 2013, 2014 Andreas Politz
-
-;; Author: Andreas Politz <politzaNOSPAMfh-trier.de>
-;; Keywords: extensions, lisp
-
-;; This program 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 of the License, or
-;; (at your option) any later version.
-
-;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;
-
-(defvar python-mode-hook)
-(let (python-mode-hook) ;FIXME: Why?
-(require 'semantic/wisent/comp)
-(require 'semantic/wisent/wisent))
-
-;;; Code:
-
-(defvar wisent-eoi-term)
-(declare-function wisent-parse "semantic/wisent/wisent.el")
-
-(defvar tablist-filter-binary-operator
- '((== . tablist-filter-op-equal)
- (=~ . tablist-filter-op-regexp)
- (< . tablist-filter-op-<)
- (> . tablist-filter-op->)
- (<= . tablist-filter-op-<=)
- (>= . tablist-filter-op->=)
- (= . tablist-filter-op-=)))
-
-(defvar tablist-filter-unary-operator nil)
-
-(defvar tablist-filter-wisent-parser nil)
-
-(defvar tablist-filter-lexer-regexps nil)
-
-(defvar tablist-filter-wisent-grammar
- '(
- ;; terminals
- ;; Use lowercase for better looking error messages.
- (operand unary-operator binary-operator or and not)
-
- ;; terminal associativity & precedence
- ((left binary-operator)
- (left unary-operator)
- (left or)
- (left and)
- (left not))
-
- ;; rules
- (filter-or-empty
- ((nil))
- ((?\( ?\)) nil)
- ((filter) $1))
- (filter
- ((operand) $1) ;;Named filter
- ((operand binary-operator operand) `(,(intern $2) ,$1 ,$3))
- ((unary-operator operand) `(,(intern $1) ,$2))
- ((not filter) `(not ,$2))
- ((filter and filter) `(and ,$1 ,$3))
- ((filter or filter) `(or ,$1 ,$3))
- ((?\( filter ?\)) $2))))
-
-(defun tablist-filter-parser-init (&optional reinitialize interactive)
- (interactive (list t t))
- (unless (and tablist-filter-lexer-regexps
- (not reinitialize))
- (let ((re (mapcar
- (lambda (l)
- (let ((re (regexp-opt
- (mapcar 'symbol-name
- (mapcar 'car l)) t)))
- (if (= (length re) 0)
- ".\\`" ;;matches nothing
- re)))
- (list tablist-filter-binary-operator
- tablist-filter-unary-operator))))
- (setq tablist-filter-lexer-regexps
- (nreverse
- (cons (concat "\\(?:" (car re) "\\|" (cadr re)
- "\\|[ \t\f\r\n\"!()]\\|&&\\|||\\)")
- re)))))
- (unless (and tablist-filter-wisent-parser
- (not reinitialize))
- (let ((wisent-compile-grammar*
- (symbol-function
- 'wisent-compile-grammar)))
- (setq tablist-filter-wisent-parser
- ;; Trick the byte-compile into not using the byte-compile
- ;; handler in semantic/wisent/comp.el, since it does not
- ;; always work (wisent-context-compile-grammar n/a).
- (funcall wisent-compile-grammar*
- tablist-filter-wisent-grammar))))
- (when interactive
- (message "Parser reinitialized."))
- nil)
-
-(defun tablist-filter-wisent-lexer ()
- (cl-destructuring-bind (unary-op binary-op keywords)
- tablist-filter-lexer-regexps
- (skip-chars-forward " \t\f\r\n")
- (cond
- ((eobp) (list wisent-eoi-term))
- ((= ?\" (char-after))
- `(operand , (condition-case err
- (read (current-buffer))
- (error (signal (car err) (cons
- "invalid lisp string"
- (cdr err)))))))
- ((looking-at unary-op)
- (goto-char (match-end 0))
- `(unary-operator ,(match-string-no-properties 0)))
- ((looking-at binary-op)
- (goto-char (match-end 0))
- `(binary-operator ,(match-string-no-properties 0)))
- ((looking-at "&&")
- (forward-char 2)
- `(and "&&"))
- ((looking-at "||")
- (forward-char 2)
- `(or "||"))
- ((= ?! (char-after))
- (forward-char)
- `(not "!"))
- ((= ?\( (char-after))
- (forward-char)
- `(?\( "("))
- ((= ?\) (char-after))
- (forward-char)
- `(?\) ")"))
- (t
- (let ((beg (point)))
- (when (re-search-forward keywords nil 'move)
- (goto-char (match-beginning 0)))
- `(operand ,(buffer-substring-no-properties
- beg
- (point))))))))
-
-(defun tablist-filter-parse (filter)
- (interactive "sFilter: ")
- (tablist-filter-parser-init)
- (with-temp-buffer
- (save-excursion (insert filter))
- (condition-case error
- (wisent-parse tablist-filter-wisent-parser
- 'tablist-filter-wisent-lexer
- (lambda (msg)
- (signal 'error
- (replace-regexp-in-string
- "\\$EOI" "end of input"
- msg t t))))
- (error
- (signal 'error
- (append (if (consp (cdr error))
- (cdr error)
- (list (cdr error)))
- (list (point))))))))
-
-(defun tablist-filter-unparse (filter &optional noerror)
- (cl-labels
- ((unparse (filter &optional noerror)
- (cond
- ((stringp filter)
- (if (or (string-match (nth 2 tablist-filter-lexer-regexps)
- filter)
- (= 0 (length filter)))
- (format "%S" filter)
- filter))
- ((and (eq (car-safe filter) 'not)
- (= (length filter) 2))
- (let ((paren (memq (car-safe (nth 1 filter)) '(or and))))
- (format "!%s%s%s"
- (if paren "(" "")
- (unparse (cadr filter) noerror)
- (if paren ")" ""))))
- ((and (memq (car-safe filter) '(and or))
- (= (length filter) 3))
- (let ((lparen (and (eq (car filter) 'and)
- (eq 'or (car-safe (car-safe (cdr filter))))))
- (rparen (and (eq (car filter) 'and)
- (eq 'or (car-safe (car-safe (cddr filter)))))))
- (format "%s%s%s %s %s%s%s"
- (if lparen "(" "")
- (unparse (cadr filter) noerror)
- (if lparen ")" "")
- (cl-case (car filter)
- (and "&&") (or "||"))
- (if rparen "(" "")
- (unparse (car (cddr filter)) noerror)
- (if rparen ")" ""))))
- ((and (assq (car-safe filter) tablist-filter-binary-operator)
- (= (length filter) 3))
- (format "%s %s %s"
- (unparse (cadr filter) noerror)
- (car filter)
- (unparse (car (cddr filter)) noerror)))
- ((and (assq (car-safe filter) tablist-filter-unary-operator)
- (= (length filter) 2))
- (format "%s %s"
- (car filter)
- (unparse (cadr filter) noerror)))
- ((not filter) "")
- (t (funcall (if noerror 'format 'error)
- "Invalid filter: %s" filter)))))
- (tablist-filter-parser-init)
- (unparse filter noerror)))
-
-(defun tablist-filter-eval (filter id entry &optional named-alist)
- (cl-labels
- ((feval (filter)
- (pcase filter
- (`(not . ,(and operand (guard (not (cdr operand)))))
- (not (feval (car operand))))
- (`(and . ,(and operands (guard (= 2 (length operands)))))
- (and
- (feval (nth 0 operands))
- (feval (nth 1 operands))))
- (`(or . ,(and operands (guard (= 2 (length operands)))))
- (or
- (feval (nth 0 operands))
- (feval (nth 1 operands))))
- (`(,op . ,(and operands (guard (= (length operands) 1))))
- (let ((fn (assq op tablist-filter-unary-operator)))
- (unless fn
- (error "Undefined unary operator: %s" op))
- (funcall fn id entry (car operands))))
- (`(,op . ,(and operands (guard (= (length operands) 2))))
- (let ((fn (cdr (assq op tablist-filter-binary-operator))))
- (unless fn
- (error "Undefined binary operator: %s" op))
- (funcall fn id entry (car operands)
- (cadr operands))))
- ((guard (stringp filter))
- (let ((fn (cdr (assoc filter named-alist))))
- (unless fn
- (error "Undefined named filter: %s" filter))
- (if (functionp fn)
- (funcall fn id entry))
- (feval
- (if (stringp fn) (tablist-filter-unparse fn) fn))))
- (`nil t)
- (_ (error "Invalid filter: %s" filter)))))
- (feval filter)))
-
-(defun tablist-filter-get-item-by-name (entry col-name)
- (let* ((col (cl-position col-name tabulated-list-format
- :key 'car
- :test
- (lambda (s1 s2)
- (eq t (compare-strings
- s1 nil nil s2 nil nil t)))))
- (item (and col (elt entry col))))
- (unless col
- (error "No such column: %s" col-name))
- (if (consp item) ;(LABEL . PROPS)
- (car item)
- item)))
-
-(defun tablist-filter-op-equal (_id entry op1 op2)
- "COLUMN == STRING : Matches if COLUMN's entry is equal to STRING."
- (let ((item (tablist-filter-get-item-by-name entry op1)))
- (string= item op2)))
-
-(defun tablist-filter-op-regexp (_id entry op1 op2)
- "COLUMN =~ REGEXP : Matches if COLUMN's entry matches REGEXP."
- (let ((item (tablist-filter-get-item-by-name entry op1)))
- (string-match op2 item)))
-
-(defun tablist-filter-op-< (id entry op1 op2)
- "COLUMN < NUMBER : Matches if COLUMN's entry is less than NUMBER."
- (tablist-filter-op-numeric '< id entry op1 op2))
-
-(defun tablist-filter-op-> (id entry op1 op2)
- "COLUMN > NUMBER : Matches if COLUMN's entry is greater than NUMBER."
- (tablist-filter-op-numeric '> id entry op1 op2))
-
-(defun tablist-filter-op-<= (id entry op1 op2)
- "COLUMN <= NUMBER : Matches if COLUMN's entry is less than or equal to NUMBER."
- (tablist-filter-op-numeric '<= id entry op1 op2))
-
-(defun tablist-filter-op->= (id entry op1 op2)
- "COLUMN >= NUMBER : Matches if COLUMN's entry is greater than or equal to NUMBER."
- (tablist-filter-op-numeric '>= id entry op1 op2))
-
-(defun tablist-filter-op-= (id entry op1 op2)
- "COLUMN = NUMBER : Matches if COLUMN's entry as a number is equal to NUMBER."
- (tablist-filter-op-numeric '= id entry op1 op2))
-
-(defun tablist-filter-op-numeric (op _id entry op1 op2)
- (let ((item (tablist-filter-get-item-by-name entry op1)))
- (funcall op (string-to-number item)
- (string-to-number op2))))
-
-(defun tablist-filter-help (&optional temporary)
- (interactive)
- (cl-labels
- ((princ-op (op)
- (princ (car op))
- (princ (concat (make-string (max 0 (- 4 (length (symbol-name (car op)))))
- ?\s)
- "- "
- (car (split-string
- (or (documentation (cdr op))
- (format "FIXME: Not documented: %s"
- (cdr op)))
- "\n" t))
- "\n"))))
- (with-temp-buffer-window
- "*Help*"
- (if temporary
- '((lambda (buf alist)
- (let ((win
- (or (display-buffer-reuse-window buf alist)
- (display-buffer-in-side-window buf alist))))
- (fit-window-to-buffer win)
- win))
- (side . bottom)))
- nil
- (princ "Filter entries with the following operators.\n\n")
- (princ "&& - FILTER1 && FILTER2 : Locical and.\n")
- (princ "|| - FILTER1 || FILTER2 : Locical or.\n")
- (dolist (op tablist-filter-binary-operator)
- (princ-op op))
- (princ "! - ! FILTER : Locical not.\n\n")
- (dolist (op tablist-filter-unary-operator)
- (princ-op op))
- (princ "\"...\" may be used to quote names and values if necessary,
-and \(...\) to group expressions.")
- (with-current-buffer standard-output
- (help-mode)))))
-
-;;
-;; **Filter Functions
-;;
-
-;; filter ::= nil | named | fn | (OP OP1 [OP2])
-
-(defun tablist-filter-negate (filter)
- "Return a filter not matching filter."
- (cond
- ((eq (car-safe filter) 'not)
- (cadr filter))
- (filter
- (list 'not filter))))
-
-(defun tablist-filter-push (filter new-filter &optional or-p)
- "Return a filter combining FILTER and NEW-FILTER.
-
-By default the filters are and'ed, unless OR-P is non-nil."
- (if (or (null filter)
- (null new-filter))
- (or filter
- new-filter)
- (list (if or-p 'or 'and)
- filter new-filter)))
-
-(defun tablist-filter-pop (filter)
- "Remove the first operator or operand from filter.
-
-If filter starts with a negation, return filter unnegated,
-if filter starts with a dis- or conjuction, remove the first operand,
-if filter is nil, raise an error,
-else return nil."
- (pcase filter
- (`(,(or `and `or) . ,tail)
- (car (cdr tail)))
- (`(not . ,op1)
- (car op1))
- (_ (unless filter
- (error "Filter is empty")))))
-
-(defun tablist-filter-map (fn filter)
- (pcase filter
- (`(,(or `and `or `not) . ,tail)
- (cons (car filter)
- (mapcar (lambda (f)
- (tablist-filter-map fn f))
- tail)))
- (_ (funcall fn filter))))
-
-;;
-;; Reading filter
-;;
-
-(defvar tablist-filter-edit-history nil)
-(defvar tablist-filter-edit-display-help t)
-
-(defun tablist-filter-edit-filter (prompt &optional
- initial-filter history
- validate-fn)
- (let* ((str (tablist-filter-unparse initial-filter))
- (filter initial-filter)
- (validate-fn (or validate-fn 'identity))
- error done)
- (save-window-excursion
- (when tablist-filter-edit-display-help
- (tablist-filter-help t))
- (while (not done)
- (minibuffer-with-setup-hook
- (lambda ()
- (when error
- (when (car error)
- (goto-char (+ (field-beginning)
- (car error)))
- (skip-chars-backward " \t\n"))
- (minibuffer-message "%s" (cdr error))
- (setq error nil)))
- (setq str (propertize
- (read-string prompt str
- (or history 'tablist-filter-edit-history)))
- done t))
- (condition-case err
- (progn
- (setq filter (tablist-filter-parse str))
- (funcall validate-fn filter))
- (error
- (setq done nil)
- (setq error (cons (car-safe (cddr err)) nil))
- (when (car error)
- (setq str (with-temp-buffer
- (insert str)
- (goto-char (car error))
- (set-text-properties
- (progn
- (skip-chars-backward " \t\n")
- (backward-char)
- (point))
- (min (car error) (point-max))
- '(face error rear-nonsticky t))
- (buffer-string))))
- (setcdr error (error-message-string err)))))
- filter)))
-
-(provide 'tablist-filter)
-;;; tablist-filter.el ends here
+++ /dev/null
-(define-package "tablist" "20190414.643" "Extended tabulated-list-mode"
- '((emacs "24.3"))
- :keywords
- '("extensions" "lisp")
- :authors
- '(("Andreas Politz" . "politzaNOSPAMfh-trier.de"))
- :maintainer
- '("Andreas Politz" . "politzaNOSPAMfh-trier.de"))
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
+++ /dev/null
-;;; tablist.el --- Extended tabulated-list-mode -*- lexical-binding: t -*-
-
-;; Copyright (C) 2013, 2014 Andreas Politz
-
-;; Author: Andreas Politz <politzaNOSPAMfh-trier.de>
-;; Keywords: extensions, lisp
-;; Package: tablist
-;; Version: 1.0
-;; Package-Requires: ((emacs "24.3"))
-
-;; This program 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 of the License, or
-;; (at your option) any later version.
-
-;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This package adds marks and filters to tabulated-list-mode. It
-;; also kind of puts a dired face on tabulated list buffers.
-;;
-;; It can be used by deriving from tablist-mode and some features by
-;; using tablist-minor-mode inside a tabulated-list-mode buffer.
-;;
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'ring)
-(require 'tabulated-list)
-(require 'dired)
-(require 'tablist-filter)
-
-;;
-;; *Macros
-;;
-
-(defmacro tablist-save-marks (&rest body)
- "Eval body, while preserving all marks."
- (let ((marks (make-symbol "marks")))
- `(let (,marks)
- (save-excursion
- (goto-char (point-min))
- (let ((re "^\\([^ ]\\)"))
- (while (re-search-forward re nil t)
- (push (cons (tabulated-list-get-id)
- (tablist-get-mark-state))
- ,marks))))
- (unwind-protect
- (progn ,@body)
- (save-excursion
- (dolist (m ,marks)
- (let ((id (pop m)))
- (goto-char (point-min))
- (while (and id (not (eobp)))
- (when (equal id (tabulated-list-get-id))
- (tablist-put-mark-state m)
- (setq id nil))
- (forward-line)))))))))
-
-(defmacro tablist-with-remembering-entry (&rest body)
- "Remember where body left of and restore previous position.
-
-If the current entry is still visible, move to it. Otherwise move
-to the next visible one after it. If that also fails, goto to
-the beginning of the buffer. Finally move point to the major
-column."
- (declare (indent 0) (debug t))
- (let ((re (make-symbol "re"))
- (id (make-symbol "id"))
- (col (make-symbol "col")))
- `(let ((,re
- (replace-regexp-in-string
- "[\t ]+" "[\t ]*" (regexp-quote
- (or (thing-at-point 'line) ""))
- t t))
- (,id (tabulated-list-get-id))
- (,col (tablist-current-column)))
- (progn
- ,@body
- (let (success pos)
- (goto-char (point-min))
- (setq pos (point))
- (while (and (setq success (re-search-forward ,re nil t))
- (> (point) (prog1 pos (setq pos (point))))
- (forward-line -1)
- (not (equal ,id (tabulated-list-get-id))))
- (forward-line))
- (unless success
- (goto-char (point-min))
- (while (and (not (eobp))
- (not success))
- (if (equal (tabulated-list-get-id) ,id)
- (setq success t)
- (forward-line))))
- (unless (and success (not (invisible-p (point))))
- (goto-char (point-min)))
- (tablist-skip-invisible-entries)
- (tablist-move-to-column
- (or ,col (car (tablist-major-columns))))
- (dolist (win (get-buffer-window-list))
- (set-window-point win (point))))))))
-
-(defmacro tablist-with-filter-displayed (&rest body)
- "Display the current filter in the mode while evalling BODY."
- (let ((state (make-symbol "state")))
- `(let ((,state (tablist-display-filter 'state)))
- (tablist-display-filter t)
- (unwind-protect
- (progn ,@body)
- (tablist-display-filter ,state)))))
-
-;;
-;; *Mode Maps
-;;
-
-(defvar tablist-mode-filter-map
- (let ((kmap (make-sparse-keymap)))
- (define-key kmap "p" 'tablist-pop-filter)
- (define-key kmap "r" 'tablist-push-regexp-filter)
- (define-key kmap "=" 'tablist-push-equal-filter)
- (define-key kmap "n" 'tablist-push-numeric-filter)
- (define-key kmap "!" 'tablist-negate-filter)
- (define-key kmap "t" 'tablist-toggle-first-filter-logic)
- (define-key kmap "/" 'tablist-display-filter)
- (define-key kmap "z" 'tablist-suspend-filter)
-
- (define-key kmap "a" 'tablist-push-named-filter)
- (define-key kmap "s" 'tablist-name-current-filter)
- (define-key kmap "D" 'tablist-delete-named-filter)
- (define-key kmap "d" 'tablist-deconstruct-named-filter)
- (define-key kmap "e" 'tablist-edit-filter)
- (define-key kmap "C" 'tablist-clear-filter)
- kmap))
-
-(defvar tablist-mode-mark-map
- (let ((kmap (make-sparse-keymap)))
- (define-key kmap "c" 'tablist-change-marks)
- (define-key kmap "!" 'tablist-unmark-all-marks)
- (define-key kmap "r" 'tablist-mark-items-regexp)
- (define-key kmap "n" 'tablist-mark-items-numeric)
- (define-key kmap "m" 'tablist-mark-forward)
- kmap))
-
-(defvar tablist-mode-regexp-map
- (let ((kmap (make-sparse-keymap)))
- ;; (define-key kmap "&" 'tablist-flag-gargabe-items)
- (define-key kmap "m" 'tablist-mark-items-regexp)
- kmap))
-
-(defvar tablist-minor-mode-map
- (let ((kmap (make-sparse-keymap)))
- (define-key kmap "m" 'tablist-mark-forward)
- (define-key kmap (kbd "DEL") 'tablist-unmark-backward)
- (define-key kmap "k" 'tablist-do-kill-lines)
- (define-key kmap "U" 'tablist-unmark-all-marks)
- (define-key kmap "u" 'tablist-unmark-forward)
- (define-key kmap "t" 'tablist-toggle-marks)
-
- (define-key kmap (kbd "TAB") 'tablist-forward-column)
- (define-key kmap "\t" 'tablist-forward-column)
- (define-key kmap [backtab] 'tablist-backward-column)
-
- (define-key kmap "%" tablist-mode-regexp-map)
- (define-key kmap "*" tablist-mode-mark-map)
- (define-key kmap "/" tablist-mode-filter-map)
-
- ;; (define-key kmap "e" 'tablist-edit-column)
- ;; (define-key kmap "i" 'tablist-insert-entry)
- (define-key kmap "s" 'tablist-sort)
- (define-key kmap [remap back-to-indentation] 'tablist-move-to-major-column)
- (define-key kmap [remap next-line] 'tablist-next-line)
- (define-key kmap [remap previous-line] 'tablist-previous-line)
- (define-key kmap "<" 'tablist-shrink-column)
- (define-key kmap ">" 'tablist-enlarge-column)
- (define-key kmap "q" 'tablist-quit)
- (define-key kmap "G" 'tablist-revert)
- (define-key kmap (kbd "C-c C-e") 'tablist-export-csv)
- kmap))
-
-(defvar tablist-mode-map
- (let ((kmap (copy-keymap tablist-minor-mode-map)))
- (set-keymap-parent kmap tabulated-list-mode-map)
- (define-key kmap "d" 'tablist-flag-forward)
- (define-key kmap (kbd "RET") 'tablist-find-entry)
- (define-key kmap "f" 'tablist-find-entry)
- ;; (define-key kmap "~" 'tablist-flag-gargabe-items)
- (define-key kmap "D" 'tablist-do-delete)
- (define-key kmap "C" 'tablist-do-copy)
- (define-key kmap "R" 'tablist-do-rename)
- (define-key kmap "x" 'tablist-do-flagged-delete)
- ;; (define-key kmap "F" 'tablist-find-marked-items)
- ;; (define-key kmap (kbd "C-o") 'tablist-display-item)
- kmap))
-
-;;
-;; *Variables
-;;
-
-;; Marking
-(defvar tablist-umark-filtered-entries t)
-(defvar tablist-marker-char dired-marker-char
- "The character used for marking.")
-(defvar tablist-marker-face 'dired-mark
- "The face used for the mark character.")
-(defvar tablist-marked-face 'dired-marked
- "The face used for marked major columns.")
-
-;; Operations
-(defvar-local tablist-operations-function nil
- "A function for handling operations on the entries.
-
-The function is called with varying number of arguments, while
-the first one is always a symbol describing one of the following
-operations.
-
-`supported-operations'
-
-This is the only mandatory operation. There are no other
-arguments and the function should return a list of symbols of
-supported operations.
-
-`delete'
-
-The 2nd argument will be a list of entry ID's. The function
-should somehow delete these entries and update
-`tabulated-list-entries'.
-
-`find-entry'
-
-The 2nd argument is the ID of an entry. The function should
-somehow find/display this entry, i.e. a kind of default
-operation.
-
-`edit-column'
-
-The function is called with 3 further arguments: ID, INDEX and
-NEW-COLUMN, where ID represents the entry to edit, INDEX is the index
-of the column and NEW-COLUMN is the proposed new value for this
-column. It should either
-
-i. return a new edited complete entry and update
-`tabulated-list-entries', or
-
-ii. throw an error, if NEW-COLUMN is not a valid value for this
-column.
-
-`complete'
-
-The function is called with 4 further arguments: ID, INDEX,
-STRING and POS, where ID represents an entry, INDEX is the index
-of the column to complete, STRING it's current value and POS an
-offset of the current position of point into STRING.
-
-The function should return a collection for this column, suitable
-as argument for the function `completion-in-region'.")
-
-;; Differentiating columns
-(defvar-local tablist-major-columns nil
- "Columns used to mark and when querying.")
-
-;; Filter
-(defvar-local tablist-current-filter nil)
-(defvar-local tablist-filter-suspended nil)
-(defvar tablist-named-filter nil)
-
-;; History variables
-(defvar tablist-column-name-history nil)
-
-;; Hooks
-(defvar tablist-selection-changed-functions nil
- "A hook run when ever point moves to a different entry.")
-
-;; Context Window
-(defvar-local tablist-context-window nil)
-(defvar-local tablist-context-window-function nil)
-(defvar tablist-context-window-display-action
- `((display-buffer-reuse-window
- tablist-display-buffer-split-below-and-attach)
- (window-height . 0.25)
- (inhibit-same-window . t)))
-
-;;
-;; *Setup
-;;
-
-(defvar savehist-additional-variables)
-(add-hook 'savehist-save-hook
- (lambda nil
- (add-to-list 'savehist-additional-variables 'tablist-named-filter)))
-
-;;;###autoload
-(define-minor-mode tablist-minor-mode
- nil nil nil nil
- (unless (derived-mode-p 'tabulated-list-mode)
- (error "Buffer is not in Tabulated List Mode"))
- (tablist-init (not tablist-minor-mode)))
-
-;;;###autoload
-(define-derived-mode tablist-mode tabulated-list-mode "TL"
- (tablist-init))
-
-(defun tablist-init (&optional disable)
- (let ((cleaned-misc (cl-remove 'tablist-current-filter
- mode-line-misc-info :key 'car)))
- (cond
- ((not disable)
- (set (make-local-variable 'mode-line-misc-info)
- (append
- (list
- (list 'tablist-current-filter
- '(:eval (format " [%s]"
- (if tablist-filter-suspended
- "suspended"
- "filtered")))))))
- (add-hook 'post-command-hook
- 'tablist-selection-changed-handler nil t)
- (add-hook 'tablist-selection-changed-functions
- 'tablist-context-window-update nil t))
- (t
- (setq mode-line-misc-info cleaned-misc)
- (remove-hook 'post-command-hook
- 'tablist-selection-changed-handler t)
- (remove-hook 'tablist-selection-changed-functions
- 'tablist-context-window-update t)))))
-
-(defun tablist-quit ()
- (interactive)
- (tablist-hide-context-window)
- (quit-window))
-
-(defvar-local tablist-selected-id nil)
-(defvar tablist-edit-column-minor-mode)
-
-(defun tablist-selection-changed-handler ()
- (unless tablist-edit-column-minor-mode
- (let ((id tablist-selected-id)
- (selected (tabulated-list-get-id)))
- (unless (eq selected id)
- (setq tablist-selected-id selected)
- (run-hook-with-args
- 'tablist-selection-changed-functions
- tablist-selected-id)))))
-
-(defvar tablist-context-window-update--timer nil)
-
-(defun tablist-context-window-update (&optional id)
- (when (and tablist-context-window-function
- (window-live-p tablist-context-window)
- (not tablist-edit-column-minor-mode))
- (unless id
- (setq id (tabulated-list-get-id)))
- (when (timerp tablist-context-window-update--timer)
- (cancel-timer tablist-context-window-update--timer))
- (setq tablist-context-window-update--timer
- (run-with-idle-timer 0.1 nil
- (lambda (fn window)
- (when (window-live-p window)
- (with-selected-window window
- (set-window-dedicated-p nil nil)
- (save-selected-window
- (funcall fn id))
- (when (window-live-p (selected-window))
- (set-window-dedicated-p nil t)))))
- tablist-context-window-function
- tablist-context-window))))
-
-(defun tablist-display-context-window ()
- (interactive)
- (unless tablist-context-window-function
- (error "No function for handling a context is defined"))
- (unless (window-live-p tablist-context-window)
- (setq tablist-context-window
- (display-buffer
- (current-buffer)
- tablist-context-window-display-action)))
- (prog1
- tablist-context-window
- (tablist-context-window-update)))
-
-(defun tablist-hide-context-window ()
- (interactive)
- (when (window-live-p tablist-context-window)
- (let ((ignore-window-parameters t))
- (delete-window tablist-context-window)))
- (setq tablist-context-window nil))
-
-(defun tablist-toggle-context-window ()
- (interactive)
- (if (window-live-p tablist-context-window)
- (tablist-hide-context-window)
- (tablist-display-context-window)))
-
-;;
-;; *Marking
-;;
-
-(defun tablist-revert ()
- "Revert the list with marks preserved, position kept."
- (interactive)
- (tablist-save-marks
- (tablist-with-remembering-entry
- (tabulated-list-revert))))
-
-(defun tablist-major-columns ()
- (if (null tablist-major-columns)
- (number-sequence 0 (1- (length tabulated-list-format)))
- (if (numberp tablist-major-columns)
- (list tablist-major-columns)
- tablist-major-columns)))
-
-(defun tablist-put-mark (&optional pos)
- "Put a mark before the entry at POS.
-
-POS defaults to point. Use `tablist-marker-char',
-`tablist-marker-face', `tablist-marked-face' and
-`tablist-major-columns' to determine how to mark and what to put
-a face on."
- (when (or (null tabulated-list-padding)
- (< tabulated-list-padding 1))
- (setq tabulated-list-padding 1)
- (tabulated-list-revert))
- (save-excursion
- (and pos (goto-char pos))
- (unless (tabulated-list-get-id)
- (error "No entry at this position"))
- (let ((inhibit-read-only t))
- (tabulated-list-put-tag
- (string tablist-marker-char))
- (put-text-property
- (point-at-bol)
- (1+ (point-at-bol))
- 'face tablist-marker-face)
- (let ((columns (tablist-column-offsets)))
- (dolist (c (tablist-major-columns))
- (when (and (>= c 0)
- (< c (length columns)))
- (let ((beg (+ (point-at-bol)
- (nth c columns)))
- (end (if (= c (1- (length columns)))
- (point-at-eol)
- (+ (point-at-bol)
- (nth (1+ c) columns)))))
- (cond
- ((and tablist-marked-face
- (not (eq tablist-marker-char ?\s)))
- (tablist--save-face-property beg end)
- (put-text-property
- beg end 'face tablist-marked-face))
- (t (tablist--restore-face-property beg end))))))))))
-
-(defun tablist-mark-forward (&optional arg interactive)
- "Mark ARG entries forward.
-
-ARG is interpreted as a prefix-arg. If interactive is non-nil,
-maybe use the active region instead of ARG.
-
-See `tablist-put-mark' for how entries are marked."
- (interactive (list current-prefix-arg t))
- (cond
- ;; Mark files in the active region.
- ((and interactive (use-region-p))
- (save-excursion
- (goto-char (region-beginning))
- (beginning-of-line)
- (tablist-repeat-over-lines
- (1+ (count-lines
- (point)
- (save-excursion
- (goto-char (region-end))
- (beginning-of-line)
- (point))))
- 'tablist-put-mark)))
- ;; Mark the current (or next ARG) files.
- (t
- (tablist-repeat-over-lines
- (prefix-numeric-value arg)
- 'tablist-put-mark))))
-
-(defun tablist-mark-backward (&optional arg interactive)
- "Mark ARG entries backward.
-
-See `tablist-mark-forward'."
- (interactive (list current-prefix-arg t))
- (tablist-mark-forward (- (prefix-numeric-value arg))
- interactive))
-
-(defun tablist-unmark-forward (&optional arg interactive)
- "Unmark ARG entries forward.
-
-See `tablist-mark-forward'."
- (interactive (list current-prefix-arg t))
- (let ((tablist-marker-char ?\s)
- tablist-marked-face)
- (tablist-mark-forward arg interactive)))
-
-(defun tablist-unmark-backward (&optional arg interactive)
- "Unmark ARG entries backward.
-
-See `tablist-mark-forward'."
- (interactive (list current-prefix-arg t))
- (let ((tablist-marker-char ?\s)
- tablist-marked-face)
- (tablist-mark-backward arg interactive)))
-
-(defun tablist-flag-forward (&optional arg interactive)
- "Flag ARG entries forward.
-
-See `tablist-mark-forward'."
- (interactive (list current-prefix-arg t))
- (let ((tablist-marker-char ?D)
- (tablist-marked-face 'dired-flagged))
- (tablist-mark-forward arg interactive)))
-
-(defun tablist-change-marks (old new)
- "Change all OLD marks to NEW marks.
-
-OLD and NEW are both characters used to mark files."
- (interactive
- (let* ((cursor-in-echo-area t)
- (old (progn (message "Change (old mark): ") (read-char)))
- (new (progn (message "Change %c marks to (new mark): " old)
- (read-char))))
- (list old new)))
- (when (eq new ?\n)
- (error "Mark character \\n is not allowed"))
- (let ((default-mark-p (equal tablist-marker-char new))
- (tablist-marker-char old))
- (save-excursion
- (tablist-map-over-marks
- (lambda nil
- (pcase new
- (?D
- (tablist-flag-forward 1))
- (_
- (let ((tablist-marker-char new)
- (tablist-marked-face
- (and default-mark-p
- tablist-marked-face)))
- (tablist-put-mark)))))))))
-
-(defun tablist-unmark-all-marks (&optional marks interactive)
- "Remove alls marks in MARKS.
-
-MARKS should be a string of mark characters to match and defaults
-to all marks. Interactively, remove all marks, unless a prefix
-arg was given, in which case ask about which ones to remove.
-Give a message, if interactive is non-nil.
-
-Returns the number of unmarked marks."
- (interactive
- (list (if current-prefix-arg
- (read-string "Remove marks: ")) t))
- (let ((re (if marks
- (tablist-marker-regexp marks)
- "^[^ ]"))
- (removed 0))
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward re nil t)
- (let ((tablist-marker-char ?\s)
- tablist-marker-face
- tablist-marked-face)
- (tablist-put-mark))
- (cl-incf removed)))
- (when interactive
- (message "Removed %d marks" removed))
- removed))
-
-(defun tablist-toggle-marks ()
- "Unmark all marked and mark all unmarked entries.
-
-See `tablist-put-mark'."
- (interactive)
- (let ((marked-re (tablist-marker-regexp))
- (not-marked-re
- (let ((tablist-marker-char ?\s))
- (tablist-marker-regexp))))
- (save-excursion
- (goto-char (point-min))
- (tablist-skip-invisible-entries)
- (while (not (eobp))
- (cond
- ((looking-at marked-re)
- (save-excursion (tablist-unmark-backward -1)))
- ((looking-at not-marked-re)
- (tablist-put-mark)))
- (tablist-forward-entry)))
- (tablist-move-to-major-column)))
-
-(defun tablist-get-marked-items (&optional arg distinguish-one-marked)
- "Return marked or ARG entries."
- (let ((items (save-excursion
- (tablist-map-over-marks
- (lambda () (cons (tabulated-list-get-id)
- (tabulated-list-get-entry)))
- arg nil distinguish-one-marked))))
- (if (and distinguish-one-marked
- (eq (car items) t))
- items
- (nreverse items))))
-
-(defun tablist-mark-items-regexp (column-name regexp)
- "Mark entries matching REGEXP in column COLUMN-NAME."
- (interactive
- (tablist-read-regexp-filter "Mark" current-prefix-arg ))
- (tablist-map-with-filter
- 'tablist-put-mark
- `(=~ ,column-name ,regexp)))
-
-(defun tablist-mark-items-numeric (binop column-name operand)
- "Mark items fulfilling BINOP with arg OPERAND in column COLUMN-NAME.
-
-First the column's value is coerced to a number N. Then the test
-proceeds as \(BINOP N OPERAND\)."
- (interactive
- (tablist-read-numeric-filter "Mark" current-prefix-arg))
- (tablist-map-with-filter
- 'tablist-put-mark
- `(,binop ,column-name ,operand)))
-
-(defun tablist-map-over-marks (fn &optional arg show-progress
- distinguish-one-marked)
- (prog1
- (cond
- ((and arg (integerp arg))
- (let (results)
- (tablist-repeat-over-lines
- arg
- (lambda ()
- (if show-progress (sit-for 0))
- (push (funcall fn) results)))
- (if (< arg 0)
- (nreverse results)
- results)))
- (arg
- ;; non-nil, non-integer ARG means use current item:
- (tablist-skip-invisible-entries)
- (unless (eobp)
- (list (funcall fn))))
- (t
- (cl-labels ((search (re)
- (let (sucess)
- (tablist-skip-invisible-entries)
- (while (and (setq sucess
- (re-search-forward re nil t))
- (invisible-p (point)))
- (tablist-forward-entry))
- sucess)))
- (let ((regexp (tablist-marker-regexp))
- next-position results found)
- (save-excursion
- (goto-char (point-min))
- ;; remember position of next marked file before BODY
- ;; can insert lines before the just found file,
- ;; confusing us by finding the same marked file again
- ;; and again and...
- (setq next-position (and (search regexp)
- (point-marker))
- found (not (null next-position)))
- (while next-position
- (goto-char next-position)
- (if show-progress (sit-for 0))
- (push (funcall fn) results)
- ;; move after last match
- (goto-char next-position)
- (forward-line 1)
- (set-marker next-position nil)
- (setq next-position (and (search regexp)
- (point-marker)))))
- (if (and distinguish-one-marked (= (length results) 1))
- (setq results (cons t results)))
- (if found
- results
- (unless (or (eobp) (invisible-p (point)))
- (list (funcall fn))))))))
- (tablist-move-to-major-column)))
-
-(defun tablist-marker-regexp (&optional marks)
- "Return a regexp matching marks in MARKS.
-
-MARKS should be a string of mark characters to match and defaults
-to the current value of `tablist-marker-char' as a string."
- (concat (format "^[%s]"
- (or marks (string tablist-marker-char)))))
-
-(defun tablist-get-mark-state ()
- "Return the mark state of the entry at point."
- (save-excursion
- (beginning-of-line)
- (when (looking-at "^\\([^ ]\\)")
- (let ((mark (buffer-substring
- (match-beginning 1)
- (match-end 1))))
- (tablist-move-to-major-column)
- (list (aref mark 0)
- (get-text-property 0 'face mark)
- (get-text-property (point) 'face))))))
-
-(defun tablist-put-mark-state (state)
- "Set the mark of the entry at point according to STATE.
-
-STATE is a return value of `tablist-get-mark-state'."
- (cl-destructuring-bind (tablist-marker-char
- tablist-marker-face
- tablist-marked-face)
- state
- (tablist-put-mark)))
-
-(defun tablist-mark-prompt (arg items)
- "Return a string suitable for use in a tablist prompt."
- ;; distinguish-one-marked can cause the first element to be just t.
- (if (eq (car items) t) (setq items (cdr items)))
- (let ((count (length items)))
- (if (= count 1)
- (car items)
- ;; more than 1 item:
- (if (integerp arg)
- ;; abs(arg) = count
- ;; Perhaps this is nicer, but it also takes more screen space:
- ;;(format "[%s %d items]" (if (> arg 0) "next" "previous")
- ;; count)
- (format "[next %d item%s]"
- arg (dired-plural-s arg))
- (format "%c [%d item%s]" dired-marker-char count
- (dired-plural-s count))))))
-
-;;
-;; *Movement
-;;
-
-(defun tablist-forward-entry (&optional n)
- "Move past the next N unfiltered entries."
- (unless n (setq n 1))
- (while (and (> n 0)
- (not (eobp)))
- (forward-line)
- (when (invisible-p (point))
- (tablist-skip-invisible-entries))
- (cl-decf n))
- (while (and (< n 0)
- (not (bobp)))
- (forward-line -1)
- (when (invisible-p (point))
- (tablist-skip-invisible-entries t))
- (cl-incf n))
- n)
-
-(defun tablist-next-line (&optional n)
- (interactive "p")
- (when (and (< n 0)
- (save-excursion
- (end-of-line 0)
- (tablist-skip-invisible-entries t)
- (bobp)))
- (signal 'beginning-of-buffer nil))
- (when (and (> n 0)
- (save-excursion
- (tablist-forward-entry)
- (eobp)))
- (signal 'end-of-buffer nil))
-
- (let ((col (tablist-current-column)))
- (tablist-forward-entry (or n 1))
- (if col
- (tablist-move-to-column col)
- (tablist-move-to-major-column))))
-
-(defun tablist-previous-line (&optional n)
- (interactive "p")
- (tablist-next-line (- (or n 1))))
-
-(defun tablist-repeat-over-lines (arg function)
- "Call FUNCTION for the next ARG entries."
- ;; Move out of potentially invisble area.
- (tablist-skip-invisible-entries)
- (let ((pos (make-marker)))
- (while (and (> arg 0)
- (not (eobp)))
- (cl-decf arg)
- (save-excursion
- (tablist-forward-entry)
- (move-marker pos (1+ (point))))
- (unless (eobp)
- (save-excursion (funcall function)))
- ;; Advance to the next line--actually, to the line that *was* next.
- ;; (If FUNCTION inserted some new lines in between, skip them.)
- (goto-char pos))
- (while (and (< arg 0) (not (bobp)))
- (cl-incf arg)
- (tablist-forward-entry -1)
- (save-excursion (funcall function)))
- (move-marker pos nil)
- (tablist-move-to-major-column)))
-
-(defun tablist-move-to-column (n)
- "Move to the N'th list column."
- (interactive "p")
- (when (tabulated-list-get-id)
- (let ((columns (tablist-column-offsets)))
- (when (or (< n 0)
- (>= n (length columns)))
- (error "No such column: %s" n))
- (beginning-of-line)
- (forward-char (nth n columns))
- (when (and (plist-get (nthcdr 3 (elt tabulated-list-format n))
- :right-align)
- (not (= n (1- (length columns)))))
- (forward-char (1- (car (cdr (elt tabulated-list-format n)))))))))
-
-(defun tablist-move-to-major-column (&optional first-skip-invisible-p)
- "Move to the first major column."
- (interactive (list t))
- (when first-skip-invisible-p
- (tablist-skip-invisible-entries))
- (tablist-move-to-column (car (tablist-major-columns))))
-
-(defun tablist-forward-column (n)
- "Move n columns forward, while wrapping around."
- (interactive "p")
- (unless (tabulated-list-get-id)
- (error "No entry on this line"))
- (let* ((columns (tablist-column-offsets))
- (current (1- (length columns))))
- ;; find current column
- (while (and (>= current 0)
- (> (nth current columns)
- (current-column)))
- (cl-decf current))
- ;; there may be an invisible spec here
- (when (bolp)
- (forward-char))
- ;; before any columns
- (when (< current 0)
- (goto-char (+ (point-at-bol) (if (> n 0)
- (car columns)
- (car (last columns)))))
- (setq n (* (cl-signum n) (1- (abs n)))))
- (when (/= n 0)
- (tablist-move-to-column
- (mod (+ current n) (length columns))))))
-
-(defun tablist-backward-column (n)
- "Move n columns backward, while wrapping around."
- (interactive "p")
- (tablist-forward-column (- n)))
-
-;;
-(defun tablist-skip-invisible-entries (&optional backward)
- "Skip invisible entries BACKWARD or forward.
-
-Do nothing, if the entry at point is visible. Otherwise move to
-the beginning of the next visible entry in the direction
-determined by BACKWARD.
-
-Return t, if point is now in a visible area."
-
- (cond
- ((and backward
- (not (bobp))
- (get-text-property (point) 'invisible))
- (when (get-text-property (1- (point)) 'invisible)
- (goto-char (previous-single-property-change
- (point)
- 'invisible nil (point-min))))
- (forward-line -1))
- ((and (not backward)
- (not (eobp))
- (get-text-property (point) 'invisible))
- (goto-char (next-single-property-change
- (point)
- 'invisible nil (point-max)))))
- (not (invisible-p (point))))
-
-;;
-;; *Operations
-;;
-
-(defun tablist-yes-or-no-p (operation arg items)
- "Query the user whether to proceed with some operation.
-
-Operation should be a symbol or string describing the operation,
-ARG the prefix-arg of the command used in
-`tablist-get-marked-items' or elsewhere, to get the ITEMS."
-
- (let ((pp-items (mapcar 'tablist-pretty-print-entry
- (mapcar 'cdr items)))
- dired-no-confirm
- (op-str (upcase-initials
- (if (stringp operation)
- operation
- (symbol-name operation)))))
- (dired-mark-pop-up
- (format " *%s*" op-str) nil
- pp-items
- dired-deletion-confirmer
- (format "%s %s "
- op-str
- (tablist-mark-prompt arg pp-items)))))
-
-(defun tablist-operation-available-p (op)
- (and (functionp tablist-operations-function)
- (memq op (funcall tablist-operations-function
- 'supported-operations))))
-
-(defun tablist-do-delete (&optional arg)
- "Delete ARG entries."
- (interactive "P")
- (unless (tablist-operation-available-p 'delete)
- (error "Deleting entries is not available in this buffer"))
- (let ((items (tablist-get-marked-items arg)))
- (when (tablist-yes-or-no-p 'delete arg items)
- (tablist-do-kill-lines arg)
- (funcall tablist-operations-function
- 'delete (mapcar 'car items))
- (tablist-move-to-major-column))))
-
-(defun tablist-do-flagged-delete (&optional interactive)
- "Delete all entries marked with a D."
- (interactive "p")
- (let* ((tablist-marker-char ?D))
- (if (save-excursion
- (goto-char (point-min))
- (re-search-forward (tablist-marker-regexp) nil t))
- (tablist-do-delete)
- (or (not interactive)
- (message "(No deletions requested)")))))
-
-(defun tablist-do-kill-lines (&optional arg interactive)
- "Remove ARG lines from the display."
- (interactive (list current-prefix-arg t))
- (save-excursion
- (let ((positions
- (tablist-map-over-marks 'point arg))
- (inhibit-read-only t))
- (dolist (pos positions)
- (goto-char pos)
- (tabulated-list-delete-entry))
- (when interactive
- (message (format "Killed %d line%s"
- (length positions)
- (dired-plural-s (length positions))))))))
-
-(defun tablist-do-operation (arg fn operation &optional delete-p revert-p)
- "Operate on marked items.
-
-ARG should be the `current-prefix-arg', FN is a function of two
-arguments \(ID ENTRY\) handling the operation. It gets called
-repeatly with all marked items. OPERATION is a symbol or string
-describing the operation, it is used for display.
-
-Optional non-nil DELETE-P means, remove the items from the display.
-Optional REVERT-P means, revert the display afterwards."
- (let ((items (tablist-get-marked-items arg)))
- (unless items
- (error "No items marked"))
- (when (tablist-yes-or-no-p operation arg items)
- (when delete-p
- (tablist-do-kill-lines arg))
- (dolist (item items)
- (funcall fn (car item)))
- (when revert-p
- (tablist-revert))
- (tablist-move-to-major-column))))
-
-;;
-;; *Editing
-;;
-(defvar tablist-edit-column-minor-mode-map
- (let ((kmap (make-sparse-keymap)))
- (set-keymap-parent kmap (current-global-map))
- (define-key kmap [remap self-insert-command] 'self-insert-command)
- (define-key kmap "\r" 'tablist-edit-column-commit)
- (define-key kmap (kbd "C-g") 'tablist-edit-column-quit)
- (define-key kmap (kbd "C-c C-c") 'tablist-edit-column-commit)
- (define-key kmap (kbd "C-c C-q") 'tablist-edit-column-quit)
- (define-key kmap "\t" 'tablist-edit-column-complete)
- (define-key kmap (kbd "TAB") 'tablist-edit-column-complete)
- (define-key kmap [remap end-of-buffer] 'end-of-line)
- (define-key kmap [remap beginning-of-buffer] 'beginning-of-line)
- (define-key kmap [remap mark-whole-buffer] 'tablist-edit-column-mark-field)
- kmap))
-
-(define-minor-mode tablist-edit-column-minor-mode
- "" nil nil nil
- (unless (or tablist-minor-mode
- (derived-mode-p 'tablist-mode))
- (error "Not in a tablist buffer"))
- (cond
- (tablist-edit-column-minor-mode
- (add-to-list 'mode-line-misc-info
- '(tablist-edit-column-minor-mode "[edit]"))
- (add-hook 'post-command-hook 'tablist-edit-column-constrain-point nil t)
- (read-only-mode -1))
- (t
- (remove-hook 'post-command-hook 'tablist-edit-column-constrain-point t)
- (read-only-mode 1))))
-
-(defun tablist-edit-column (&optional n)
- (interactive "P")
- (unless n (setq n (tablist-current-column)))
- (tablist-assert-column-editable n)
- (let* ((offsets (append (tablist-column-offsets)
- (list (- (point-at-eol)
- (point-at-bol)))))
- (beg (+ (point-at-bol)
- (nth n offsets)))
- (end (+ (point-at-bol)
- (nth (1+ n) offsets)))
- (entry (tabulated-list-get-entry beg))
- (inhibit-read-only t)
- (inhibit-field-text-motion t)
- (alist `((entry . ,entry)
- (column . ,n)
- (id . ,(tabulated-list-get-id beg))))
- ov)
- (goto-char beg)
- (delete-region beg end)
- (add-text-properties
- (point-at-bol) (point-at-eol)
- '(read-only t field t))
- (unless (= beg (point-at-bol))
- (put-text-property (1- beg) beg 'rear-nonsticky t))
- (save-excursion
- ;; Keep one read-only space at the end for keeping text
- ;; properties.
- (insert
- (propertize
- (concat
- (tablist-nth-entry n entry)
- (propertize " "
- 'display `(space :align-to ,(- end (point-at-bol)))))
- 'field nil
- 'front-sticky '(tablist-edit)
- 'rear-nonsticky '(read-only field)
- 'tablist-edit alist))
- (setq end (point)))
- (add-text-properties
- (1- end) end '(read-only t field 'tablist-edit-end))
- (setq ov (make-overlay beg end))
- (overlay-put ov 'priority 9999)
- (overlay-put ov 'face '(:background "deep sky blue" :foreground "white"))
- (overlay-put ov 'evaporate t)
- (overlay-put ov 'tablist-edit t)
- (tablist-edit-column-minor-mode 1)))
-
-(defun tablist-edit-column-quit ()
- (interactive)
- (tablist-edit-column-commit t))
-
-(defun tablist-edit-column-commit (&optional abandon-edit)
- (interactive (list current-prefix-arg))
- (let ((inhibit-read-only t)
- (inhibit-field-text-motion t)
- bounds)
- (condition-case nil
- (setq bounds (tablist-edit-column-bounds))
- (error
- (tablist-edit-column-minor-mode -1)
- (tabulated-list-revert)
- (put-text-property (point-min) (point-max)
- 'tablist-edit nil)
- (error "Unable to complete the edit")))
- (let* ((beg (car bounds))
- (end (cdr bounds))
- (alist (get-text-property beg 'tablist-edit))
- (column (cdr (assq 'column alist)))
- (id (cdr (assq 'id alist)))
- (entry (cdr (assq 'entry alist)))
- (item (buffer-substring-no-properties beg (1- end))))
-
- (unless abandon-edit
- ;; Throws an error, if item is invalid.
- (setq entry (funcall tablist-operations-function
- 'edit-column id column item)))
- (tablist-edit-column-minor-mode -1)
- (remove-overlays beg end 'tablist-edit t)
- (put-text-property beg end 'tablist-edit nil)
- (delete-region (point-at-bol) (1+ (point-at-eol)))
- (save-excursion
- (tabulated-list-print-entry id entry))
- (forward-char (nth column (tablist-column-offsets))))))
-
-(defun tablist-edit-column-complete ()
- (interactive)
- (unless (tablist-operation-available-p 'complete)
- (error "Completion not available"))
- (cl-destructuring-bind (beg &rest end)
- (tablist-edit-column-bounds t)
- (let* ((string (buffer-substring-no-properties
- beg end))
- (alist (get-text-property beg 'tablist-edit))
- (completions (funcall tablist-operations-function
- 'complete
- (cdr (assq 'id alist))
- (cdr (assq 'column alist))
- string
- (- (point) beg))))
- (unless completions
- (error "No completions available"))
- (completion-in-region beg end completions))))
-
-(defun tablist-column-editable (n)
- (and (tablist-operation-available-p 'edit-column)
- (not (tablist-column-property n :read-only))))
-
-(defun tablist-assert-column-editable (n)
- (unless (and (>= n 0)
- (< n (length tabulated-list-format)))
- (error "Invalid column number: %s" n))
- (unless (tablist-operation-available-p 'edit-column)
- (error "Editing columns not enabled in this buffer"))
- (when (tablist-column-property n :read-only)
- (error "This column is read-only")))
-
-(defun tablist-edit-column-constrain-point ()
- (unless tablist-edit-column-minor-mode
- (error "Not editing a column"))
- (unless (get-text-property (point) 'tablist-edit)
- (let ((bounds (tablist-edit-column-bounds)))
- (when bounds
- (if (> (point) (cdr bounds))
- (goto-char (1- (cdr bounds)))
- (goto-char (car bounds)))
- (point)))))
-
-(defun tablist-edit-column-bounds (&optional skip-final-space)
- (unless tablist-edit-column-minor-mode
- (error "Not editing a column"))
- (let ((pos (next-single-property-change
- (point) 'tablist-edit))
- beg end)
- (cond
- ((null pos)
- (setq end (previous-single-property-change
- (point-max) 'tablist-edit)
- beg (previous-single-property-change
- end 'tablist-edit)))
- ((get-text-property pos 'tablist-edit)
- (setq beg pos
- end (next-single-property-change
- pos 'tablist-edit)))
- (pos
- (setq end pos
- beg (previous-single-property-change
- pos 'tablist-edit))))
-
- (unless (and beg end (get-text-property beg 'tablist-edit))
- (error "Unable to locate edited text"))
- (cons beg (if skip-final-space (1- end) end))))
-
-(defun tablist-edit-column-mark-field ()
- (interactive)
- (push-mark (field-beginning))
- (push-mark (field-end) nil t)
- (goto-char (field-beginning)))
-
-(defun tablist-find-entry (&optional id)
- (interactive)
- (unless (tablist-operation-available-p 'find-entry)
- (error "Finding entries not supported in this buffer"))
- (funcall tablist-operations-function
- 'find-entry
- (or id (tabulated-list-get-id))))
-
-;;
-;; *Utility
-;;
-
-(defun tablist-column-property (n prop)
- (plist-get
- (nthcdr 3 (aref tabulated-list-format n))
- prop))
-
-(defun tablist-current-column ()
- "Return the column number at point.
-
-Returns nil, if point is before the first column."
- (let ((column
- (1- (cl-position
- (current-column)
- (append (tablist-column-offsets)
- (list most-positive-fixnum))
- :test (lambda (column offset) (> offset column))))))
- (when (>= column 0)
- column)))
-
-(defun tablist-column-offsets ()
- "Return a list of column positions.
-
-This is a list of offsets from the beginning of the line."
- (let ((cc tabulated-list-padding)
- columns)
- (dotimes (i (length tabulated-list-format))
- (let* ((c (aref tabulated-list-format i))
- (len (nth 1 c))
- (pad (or (plist-get (nthcdr 3 c) :pad-right)
- 1)))
- (push cc columns)
- (when (numberp len)
- (cl-incf cc len))
- (when pad
- (cl-incf cc pad))))
- (nreverse columns)))
-
-(defun tablist-pretty-print-entry (item)
- (mapconcat (lambda (i)
- (tablist-nth-entry i item))
- (tablist-major-columns) " "))
-
-(defun tablist--save-face-property (beg end)
- ;; We need to distinguish ,,not set'' from ''no face''.
- (unless (and (text-property-not-all beg end 'face nil)
- (< beg end))
- (put-text-property beg (1+ beg) 'face 'default))
- (unless (text-property-not-all beg end 'tablist-saved-face nil)
- (tablist-copy-text-property beg end 'face 'tablist-saved-face)))
-
-(defun tablist--restore-face-property (beg end)
- (when (text-property-not-all beg end 'tablist-saved-face nil)
- (tablist-copy-text-property beg end 'tablist-saved-face 'face)))
-
-(defun tablist-copy-text-property (beg end from to)
- "Copy text property FROM to TO in region BEG to END."
- (let ((inhibit-read-only t))
- (save-excursion
- (while (< beg end)
- (goto-char beg)
- (put-text-property
- (point)
- (setq beg (next-single-property-change
- (point) from nil end))
- to
- (get-text-property (point) from))))))
-
-;;
-(defun tablist-read-column-name (arg &optional prompt default)
- "Read the name of a column using ARG.
-
-If ARG is a number, return column ARG.
-If ARG is nil, return DEFAULT or the current column.
-Else ask the user, using PROMPT and DEFAULT."
- (cond
- ((numberp arg)
- (or (tablist-column-name
- (prefix-numeric-value arg))
- (error "No such column: %d" (prefix-numeric-value arg))))
- ((null arg)
- (or default
- (tablist-column-name
- (or (tablist-current-column)
- (car (tablist-major-columns))
- 0))))
- (t
- (let* ((default (or default
- (tablist-column-name
- (car (tablist-major-columns)))))
- (result
- (completing-read
- (format "%s %s: "
- (or prompt "Use column")
- (if default
- (format "(default %s)"
- default)
- ""))
- (tablist-column-names)
- nil t nil 'tablist-column-name-history)))
- (if (> (length result) 0)
- result
- (if (not default)
- (error "No column selected")
- default))))))
-
-(defun tablist-column-name (n)
- "Return the name of column N."
- (when (and n
- (>= n 0)
- (< n (length tabulated-list-format)))
- (substring-no-properties
- (car (elt tabulated-list-format n)) 0)))
-
-(defun tablist-column-names ()
- "Return a list of all column-names."
- (mapcar 'tablist-column-name
- (number-sequence 0 (1- (length tabulated-list-format)))))
-
-(defun tablist-nth-entry (n &optional entry)
- (unless entry (setq entry (tabulated-list-get-entry)))
- (when (and entry
- (>= n 0)
- (< n (length entry)))
- (let ((str (elt entry n)))
- (if (stringp str)
- str
- (car str)))))
-
-(defun tablist-major-column-name ()
- "Return a list of the major column names."
- (tablist-column-name (car (tablist-major-columns))))
-
-(defun tablist-export-csv (&optional separator always-quote-p
- invisible-p out-buffer display-p)
- "Export a tabulated list to a CSV format.
-
-Use SEPARATOR (or ;) and quote if necessary (or always if
-ALWAYS-QUOTE-P is non-nil). Only consider non-filtered entries,
-unless invisible-p is non-nil. Create a buffer for the output or
-insert it after point in OUT-BUFFER. Finally if DISPLAY-P is
-non-nil, display this buffer.
-
-Return the output buffer."
-
- (interactive (list nil t nil nil t))
- (unless (derived-mode-p 'tabulated-list-mode)
- (error "Not in Tabulated List Mode"))
- (unless (stringp separator)
- (setq separator (string (or separator ?\;))))
- (let* ((outb (or out-buffer
- (get-buffer-create
- (format "%s.csv" (buffer-name)))))
- (escape-re (format "[%s\"\n]" separator))
- (header (tablist-column-names)))
- (unless (buffer-live-p outb)
- (error "Expected a live buffer: %s" outb))
- (cl-labels
- ((printit (entry)
- (insert
- (mapconcat
- (lambda (e)
- (unless (stringp e)
- (setq e (car e)))
- (if (or always-quote-p
- (string-match escape-re e))
- (concat "\""
- (replace-regexp-in-string "\"" "\"\"" e t t)
- "\"")
- e))
- entry separator))
- (insert ?\n)))
- (with-current-buffer outb
- (let ((inhibit-read-only t))
- (erase-buffer)
- (printit header)))
- (save-excursion
- (goto-char (point-min))
- (unless invisible-p
- (tablist-skip-invisible-entries))
- (while (not (eobp))
- (let* ((entry (tabulated-list-get-entry)))
- (with-current-buffer outb
- (let ((inhibit-read-only t))
- (printit entry)))
- (if invisible-p
- (forward-line)
- (tablist-forward-entry)))))
- (if display-p
- (display-buffer outb))
- outb)))
-
-;;
-
-(defun tablist-enlarge-column (&optional column width)
- "Enlarge column COLUMN by WIDTH.
-
-This function is lazy and therfore pretty slow."
- (interactive
- (list nil (* (prefix-numeric-value current-prefix-arg)
- 3)))
- (unless column (setq column (tablist-current-column)))
- (unless column
- (error "No column given and no entry at point"))
- (unless width (setq width 1))
- (when (or (not (numberp column))
- (< column 0)
- (>= column (length tabulated-list-format)))
- (error "No such column: %d" column))
- (when (= column (1- (length tabulated-list-format)))
- (error "Can't resize last column"))
-
- (let* ((cur-width (cadr (elt tabulated-list-format column))))
- (setcar (cdr (elt tabulated-list-format column))
- (max 3 (+ cur-width width)))
- (tablist-with-remembering-entry
- (tablist-save-marks
- (tabulated-list-init-header)
- (tabulated-list-print)))))
-
-(defun tablist-shrink-column (&optional column width)
- (interactive
- (list nil (* (prefix-numeric-value current-prefix-arg)
- 3)))
- (tablist-enlarge-column column (- (or width 1))))
-
-;; *Sorting
-;;
-
-(defun tablist-sort (&optional column)
- "Sort the tabulated-list by COLUMN.
-
-COLUMN may be either a name or an index. The default compare
-function is given by the `tabulated-list-format', which see.
-
-This function saves the current sort column and the inverse
-sort-direction in the variable `tabulated-list-sort-key', which
-also determines the default COLUMN and direction.
-
-The main difference to `tabulated-list-sort' is, that this
-function sorts the buffer in-place and it ignores a nil sort
-entry in `tabulated-list-format' and sorts on the column
-anyway (why not ?)."
-
- (interactive
- (list
- (if (null current-prefix-arg)
- (tablist-column-name
- (or (tablist-current-column)
- (car (tablist-major-columns))
- 0))
- (tablist-read-column-name
- '(4) "Sort by column"
- (tablist-column-name (car (tablist-major-columns)))))))
-
- (unless column
- (setq column (or (car tabulated-list-sort-key)
- (tablist-column-name (car (tablist-major-columns)))
- (tablist-column-name 0))))
- (when (numberp column)
- (let ((column-name (tablist-column-name column)))
- (unless column-name
- (error "No such column: %d" column))
- (setq column column-name)))
-
- (setq tabulated-list-sort-key
- (cons column
- (if (equal column (car tabulated-list-sort-key))
- (cdr tabulated-list-sort-key))))
-
- (let* ((entries (if (functionp tabulated-list-entries)
- (funcall tabulated-list-entries)
- tabulated-list-entries))
- (reverse (cdr tabulated-list-sort-key))
- (n (tabulated-list--column-number ;;errors if column is n/a
- (car tabulated-list-sort-key)))
- (compare-fn (nth 2 (aref tabulated-list-format n))))
-
- (when (or (null compare-fn)
- (eq compare-fn t))
- (setq compare-fn
- (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))))))
-
- (unless compare-fn
- (error "This column cannot be sorted: %s" column))
-
- (setcdr tabulated-list-sort-key (not reverse))
- ;; Presort the entries and hash the result and sort the buffer.
- (setq entries (sort (copy-sequence entries) compare-fn))
- (let ((hash (make-hash-table :test 'equal)))
- (dotimes (i (length entries))
- (puthash (caar entries) i hash)
- (setq entries (cdr entries)))
- (tablist-with-remembering-entry
- (goto-char (point-min))
- (tablist-skip-invisible-entries)
- (let ((inhibit-read-only t))
- (sort-subr
- nil 'tablist-forward-entry 'end-of-line
- (lambda ()
- (gethash (tabulated-list-get-id) hash 0))
- nil (if reverse '< '>))))
- (tablist-move-to-column n)
- ;; Make the sort arrows display.
- (tabulated-list-init-header))))
-
-;;
-;; *Filter
-;;
-
-(defun tablist-read-filter-name (prompt)
- (let ((filter (cdr (assq major-mode tablist-named-filter))))
- (unless filter
- (error "No filter defined for %s mode" mode-name))
- (let ((name (completing-read
- (format "%s: " prompt)
- filter
- nil t)))
- (unless (> (length name) 0)
- (error "No filter selected"))
- name)))
-
-(defun tablist-apply-filter (&optional filter)
- "Apply FILTER to the current tabulated list.
-
-FILTER defaults to `tablist-current-filter'."
- (unless filter (setq filter tablist-current-filter))
- (tablist-filter-unhide-buffer)
- (when (and filter
- (null tablist-filter-suspended))
- (tablist-with-remembering-entry
- (tablist-map-with-filter
- (lambda nil
- (if tablist-umark-filtered-entries
- (save-excursion (tablist-unmark-forward)))
- (tablist-filter-hide-entry))
- (tablist-filter-negate filter))))
- (force-mode-line-update))
-
-(defadvice tabulated-list-print (after tabulated-list activate)
- "Reapply the filter."
- (when (or tablist-minor-mode
- (derived-mode-p 'tablist-mode))
- (tablist-apply-filter)))
-
-(defun tablist-eval-filter (filter)
- (tablist-filter-eval
- filter
- (tabulated-list-get-id)
- (tabulated-list-get-entry)
- (cdr (assq major-mode tablist-named-filter))))
-
-(defun tablist-map-with-filter (fn filter &optional show-progress
- distinguish-one-marked)
- "Call FN for every unfiltered entry matching FILTER."
- (prog1
- (cl-labels ((search ()
- (tablist-skip-invisible-entries)
- (while (and (not (eobp))
- (not (tablist-eval-filter filter)))
- (tablist-forward-entry))
- (unless (eobp)
- (point-marker))))
- (let (next-position results)
- (save-excursion
- (goto-char (point-min))
- (setq next-position (search))
- (while next-position
- (goto-char next-position)
- (if show-progress (sit-for 0))
- (push (funcall fn) results)
- ;; move after last match
- (goto-char next-position)
- (forward-line 1)
- (set-marker next-position nil)
- (setq next-position (search)))
- (if (and distinguish-one-marked (= (length results) 1))
- (setq results (cons t results))))))))
-
-;;
-;; **Filter Commands
-;;
-(defun tablist-push-filter (filter &optional interactive or-p)
- (setq tablist-current-filter
- (tablist-filter-push
- tablist-current-filter
- filter or-p))
- (tablist-apply-filter)
- (when interactive
- (tablist-display-filter-temporarily)))
-
-(defun tablist-pop-filter (&optional n interactive)
- "Remove the first N filter components."
- (interactive (list (prefix-numeric-value current-prefix-arg) t))
- (while (and tablist-current-filter
- (> n 0))
- (setq tablist-current-filter
- (tablist-filter-pop
- tablist-current-filter))
- (cl-decf n))
- (tablist-apply-filter)
- (when interactive
- (when (> n 0)
- (message "The filter is empty."))
- (tablist-display-filter-temporarily))
- n)
-
-(defun tablist-negate-filter (&optional interactive)
- "Negate the current filter."
- (interactive (list t))
- (setq tablist-current-filter
- (tablist-filter-negate
- tablist-current-filter))
- (tablist-apply-filter)
- (when interactive
- (tablist-display-filter-temporarily)))
-
-(defun tablist-toggle-first-filter-logic ()
- "Toggle between and/or for the first filter operand."
- (interactive)
- (setq tablist-current-filter
- (pcase tablist-current-filter
- (`(or ,x1 ,x2)
- `(and ,x1 ,x2))
- (`(and ,x1 ,x2)
- `(or ,x1 ,x2))
- (`(not ,x) x)
- (x `(not ,x))))
- (tablist-apply-filter)
- (tablist-display-filter-temporarily))
-
-(defun tablist-suspend-filter (&optional flag)
- "Temporarily disable filtering according to FLAG.
-
-Interactively, this command toggles filtering."
- (interactive
- (list (not tablist-filter-suspended)))
- (let ((state tablist-filter-suspended))
- (unless (eq (not (not state))
- (not (not flag)))
- (set (make-local-variable 'tablist-filter-suspended) flag)
- (tablist-apply-filter))))
-
-(defun tablist-read-regexp-filter (operation arg)
- (let ((column-name (tablist-read-column-name arg)))
- (list
- column-name
- (let ((re
- (read-regexp (format "%s where %s matches: " operation column-name))))
- (unless (> (length re) 0)
- (error "No regexp given"))
- re))))
-
-(defun tablist-read-equal-filter (operation arg)
- (let ((column-name (tablist-read-column-name arg)))
- (list
- column-name
- (read-string (format "%s where %s equals: " operation column-name)))))
-
-(defun tablist-read-numeric-filter (operation arg)
- (let* ((entry (tabulated-list-get-entry 1))
- (default (cl-some
- (lambda (idx)
- (let ((value (tablist-nth-entry idx entry)))
- (when (or (not (eq 0 (string-to-number value)))
- (equal "0" value))
- (tablist-column-name idx))))
- (number-sequence 0 (length entry))))
- (column-name (tablist-read-column-name arg nil default))
- (op (completing-read
- (format "%s %s matching binary op: " operation column-name)
- '("=" "<" ">" "<=" ">=") nil t))
- oper)
-
- (when (equal "" op)
- (error "No operation selected"))
- (setq op (intern op))
- (setq oper (number-to-string
- (read-number
- (format "%s where %s %s " operation column-name op))))
-
- (list op column-name oper)))
-
-(defun tablist-push-regexp-filter (column-name regexp)
- "Add a new filter matching REGEXP in COLUMN-NAME.
-
-The filter is and'ed with the current filter. Use
-`tablist-toggle-first-filter-logic' to change this."
- (interactive
- (tablist-with-filter-displayed
- (tablist-read-regexp-filter "Filter" current-prefix-arg)))
- (tablist-push-filter
- `(=~ ,column-name ,regexp)
- (called-interactively-p 'any)))
-
-(defun tablist-push-equal-filter (column-name string)
- "Add a new filter whre string equals COLUMN-NAME's value.
-
-The filter is and'ed with the current filter. Use
-`tablist-toggle-first-filter-logic' to change this."
- (interactive
- (tablist-with-filter-displayed
- (tablist-read-equal-filter "Filter" current-prefix-arg)))
- (tablist-push-filter
- `(== ,column-name ,string)
- (called-interactively-p 'any)))
-
-(defun tablist-push-numeric-filter (op column-name 2nd-arg)
- "Add a new filter matching a numeric predicate.
-
-The filter is and'ed with the current filter. Use
-`tablist-toggle-first-filter-logic' to change this."
- (interactive
- (tablist-with-filter-displayed
- (tablist-read-numeric-filter "Filter" current-prefix-arg)))
- (tablist-push-filter
- `(,op ,column-name ,2nd-arg)
- (called-interactively-p 'any)))
-
-(defun tablist-push-named-filter (name)
- "Add a named filter called NAME.
-
-Named filter are saved in the variable `tablist-named-filter'."
- (interactive
- (tablist-with-filter-displayed
- (list
- (tablist-read-filter-name "Add filter"))))
- (when (and name (symbolp name))
- (setq name (symbol-name name)))
- (tablist-push-filter name (called-interactively-p 'any)))
-
-(defun tablist-delete-named-filter (name &optional mode)
- (interactive
- (tablist-with-filter-displayed
- (list
- (tablist-read-filter-name "Delete filter"))))
- (setq tablist-current-filter
- (tablist-filter-map
- (lambda (f)
- (when (equal f name)
- (setq f (tablist-get-named-filter f)))
- f)
- tablist-current-filter))
- (unless mode (setq mode major-mode))
- (let ((mode-filter
- (assq mode tablist-named-filter)))
- (when mode-filter
- (setcdr mode-filter
- (cl-remove name (cdr mode-filter)
- :test 'equal :key 'car)))))
-
-(defun tablist-name-current-filter (name)
- (interactive
- (list (tablist-with-filter-displayed
- (read-string
- "Add name for current filter: "))))
- (unless tablist-current-filter
- (error "Filter is empty"))
- (unless (> (length name) 0)
- (error "No name given"))
- (tablist-put-named-filter
- name (if (stringp tablist-current-filter)
- (tablist-get-named-filter
- tablist-current-filter)
- tablist-current-filter))
- (setq tablist-current-filter name)
- (force-mode-line-update))
-
-(defun tablist-deconstruct-named-filter ()
- (interactive)
- (let (found)
- (setq tablist-current-filter
- (tablist-filter-map
- (lambda (f)
- (when (and (not found)
- (stringp f))
- (setq found t)
- (let ((df (tablist-get-named-filter f)))
- (unless df
- (error "Filter is not defined: %s" f))
- (setq f df)))
- f)
- tablist-current-filter))
- (unless found
- (error "No named filter found"))
- (force-mode-line-update)))
-
-(defun tablist-filter-names (&optional mode)
- (mapcar 'car (cdr (assq (or mode major-mode)
- tablist-named-filter))))
-
-(defun tablist-get-named-filter (name &optional mode)
- (cdr (assoc name
- (cdr (assq (or mode major-mode)
- tablist-named-filter)))))
-
-(defun tablist-put-named-filter (name filter &optional mode)
- (unless mode (setq mode major-mode))
- (let ((mode-filter
- (assq mode tablist-named-filter)))
- (unless mode-filter
- (setq mode-filter (cons mode nil))
- (push mode-filter tablist-named-filter))
- (let ((entry (assoc name mode-filter)))
- (if entry
- (setcdr entry filter)
- (setcdr mode-filter
- (list (cons name filter)))))))
-
-(defun tablist-validate-named-filter (filter)
- (tablist-filter-map
- (lambda (f)
- (when (and (stringp f)
- (null (tablist-get-named-filter f)))
- (error "Undefined named filter: %s (defined: %s)" f
- (mapconcat 'identity (tablist-filter-names) ","))))
- filter))
-
-(defun tablist-edit-filter ()
- (interactive)
- (setq tablist-current-filter
- (tablist-with-filter-displayed
- (tablist-filter-edit-filter
- "Edit filter: "
- tablist-current-filter
- nil
- 'tablist-validate-named-filter)))
- (tablist-apply-filter))
-
-(defun tablist-clear-filter ()
- (interactive)
- (setq tablist-current-filter nil)
- (tablist-apply-filter))
-
-;; **Displaying filter
-;;
-
-(defconst tablist-display-filter-mode-line-tag nil)
-
-(defun tablist-display-filter (&optional flag)
- "Display the current filter according to FLAG.
-
-If FLAG has the value 'toggle, toggle it's visibility.
-If FLAG has the 'state, then do nothing but return the current
-visibility."
- (interactive (list 'toggle))
- (let* ((tag 'tablist-display-filter-mode-line-tag)
- (displayed-p (not (not (assq tag mode-line-format)))))
- (if (eq flag 'state)
- displayed-p
- (let ((display-p (not (not (if (eq flag 'toggle)
- (not displayed-p)
- flag)))))
- (unless (eq displayed-p display-p)
- (setq mode-line-format
- (if display-p
- (list (cons tag mode-line-format)
- '(:eval
- (replace-regexp-in-string
- "%" "%%"
- (concat
- (propertize "Filter: " 'face 'minibuffer-prompt)
- (and tablist-filter-suspended
- "[suspended] ")
- (if tablist-current-filter
- (tablist-filter-unparse
- tablist-current-filter t)
- "[none]")))))
- (cdr (assq tag mode-line-format)))))
- (force-mode-line-update)
- display-p))))
-
-(defun tablist-display-filter-temporarily ()
- (tablist-with-filter-displayed
- (sit-for 9999)))
-
-;;
-;; **Hiding/Unhiding Entries
-;;
-(defun tablist-filter-set-entry-hidden (flag &optional pos)
- (save-excursion
- (when pos (goto-char pos))
- (beginning-of-line)
- (let ((inhibit-read-only t))
- (add-text-properties
- (point-at-bol)
- (1+ (point-at-eol))
- `(invisible ,flag)))))
-
-(defun tablist-filter-hide-entry (&optional pos)
- (interactive)
- (tablist-filter-set-entry-hidden t pos))
-
-(defun tablist-filter-unhide-entry (&optional pos)
- (tablist-filter-set-entry-hidden nil pos))
-
-(defun tablist-filter-unhide-buffer ()
- (let ((inhibit-read-only t))
- (remove-text-properties
- (point-min) (point-max)
- '(invisible))))
-
-(defun tablist-window-attach (awindow &optional window)
- "Attach AWINDOW to WINDOW.
-
-This has the following effect. Whenever WINDOW, defaulting to
-the selected window, stops displaying the buffer it currently
-displays (e.g., by switching buffers or because it was deleted)
-AWINDOW is deleted."
- (unless window (setq window (selected-window)))
- (let ((buffer (window-buffer window))
- (hook (make-symbol "window-attach-hook")))
- (fset hook
- (lambda ()
- (when (or (not (window-live-p window))
- (not (eq buffer (window-buffer window))))
- (remove-hook 'window-configuration-change-hook
- hook)
- ;; Deleting windows inside wcch may cause errors in
- ;; windows.el .
- (run-with-timer
- 0 nil (lambda (win)
- (when (and (window-live-p win)
- (not (eq win (selected-window))))
- (delete-window win)))
- awindow))))
- (add-hook 'window-configuration-change-hook hook)))
-
-(defun tablist-display-buffer-split-below-and-attach (buf alist)
- "Display buffer action using `tablist-window-attach'."
- (let ((window (selected-window))
- (height (cdr (assq 'window-height alist)))
- newwin)
- (when height
- (when (floatp height)
- (setq height (round (* height (frame-height)))))
- (setq height (- (max height window-min-height))))
- (setq newwin (window--display-buffer
- buf
- (split-window-below height)
- 'window alist))
- (tablist-window-attach newwin window)
- newwin))
-
-(defun tablist-generate-sorter (column compare-fn &optional read-fn)
- "Generate a sort function for `tabulated-list' entries.
-
-Example:
-
- \(tablist-generate-sorter 0 '< 'string-to-number\)
-
-would create a sort function sorting `tabulated-list-entries' on
-the 0-th column as numbers by the less-than relation."
-
- (lambda (e1 e2)
- (funcall compare-fn
- (funcall (or read-fn 'identity)
- (aref (cadr e1) column))
- (funcall (or read-fn 'identity)
- (aref (cadr e2) column)))))
-
-(provide 'tablist)
-;;; tablist.el ends here
--- /dev/null
+;;; tablist-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
+;;
+;;; Code:
+
+(add-to-list 'load-path (directory-file-name
+ (or (file-name-directory #$) (car load-path))))
+
+\f
+;;;### (autoloads nil "tablist" "tablist.el" (0 0 0 0))
+;;; Generated autoloads from tablist.el
+
+(autoload 'tablist-minor-mode "tablist" "\
+Toggle tablist minor mode.
+
+This is a minor mode. If called interactively, toggle the
+`Tablist minor mode' mode. If the prefix argument is positive,
+enable the mode, and if it is zero or negative, disable the mode.
+
+If called from Lisp, toggle the mode if ARG is `toggle'. Enable
+the mode if ARG is nil, omitted, or is a positive number.
+Disable the mode if ARG is a negative number.
+
+To check whether the minor mode is enabled in the current buffer,
+evaluate `tablist-minor-mode'.
+
+The mode's hook is called both when the mode is enabled and when
+it is disabled.
+
+\(fn &optional ARG)" t nil)
+
+(autoload 'tablist-mode "tablist" "\
+
+
+\(fn)" t nil)
+
+(register-definition-prefixes "tablist" '("tablist-"))
+
+;;;***
+\f
+;;;### (autoloads nil "tablist-filter" "tablist-filter.el" (0 0 0
+;;;;;; 0))
+;;; Generated autoloads from tablist-filter.el
+
+(register-definition-prefixes "tablist-filter" '("tablist-filter-"))
+
+;;;***
+\f
+;;;### (autoloads nil nil ("tablist-pkg.el") (0 0 0 0))
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; coding: utf-8
+;; End:
+;;; tablist-autoloads.el ends here
--- /dev/null
+;;; tablist-filter.el --- Filter expressions for tablists. -*- lexical-binding:t -*-
+
+;; Copyright (C) 2013, 2014 Andreas Politz
+
+;; Author: Andreas Politz <politzaNOSPAMfh-trier.de>
+;; Keywords: extensions, lisp
+
+;; This program 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 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+(defvar python-mode-hook)
+(let (python-mode-hook) ;FIXME: Why?
+(require 'semantic/wisent/comp)
+(require 'semantic/wisent/wisent))
+
+;;; Code:
+
+(defvar wisent-eoi-term)
+(declare-function wisent-parse "semantic/wisent/wisent.el")
+
+;;
+;; *Variables
+;;
+
+(defvar tablist-filter-binary-operator
+ '((== . tablist-filter-op-equal)
+ (=~ . tablist-filter-op-regexp)
+ (< . tablist-filter-op-<)
+ (> . tablist-filter-op->)
+ (<= . tablist-filter-op-<=)
+ (>= . tablist-filter-op->=)
+ (= . tablist-filter-op-=)))
+
+(defvar tablist-filter-unary-operator nil)
+
+(defvar tablist-filter-wisent-parser nil)
+
+(defvar tablist-filter-lexer-regexps nil)
+
+(defvar tablist-filter-wisent-grammar
+ '(
+ ;; terminals
+ ;; Use lowercase for better looking error messages.
+ (operand unary-operator binary-operator or and not)
+
+ ;; terminal associativity & precedence
+ ((left binary-operator)
+ (left unary-operator)
+ (left or)
+ (left and)
+ (left not))
+
+ ;; rules
+ (filter-or-empty
+ ((nil))
+ ((?\( ?\)) nil)
+ ((filter) $1))
+ (filter
+ ((operand) $1) ;;Named filter
+ ((operand binary-operator operand) `(,(intern $2) ,$1 ,$3))
+ ((unary-operator operand) `(,(intern $1) ,$2))
+ ((not filter) `(not ,$2))
+ ((filter and filter) `(and ,$1 ,$3))
+ ((filter or filter) `(or ,$1 ,$3))
+ ((?\( filter ?\)) $2))))
+
+;;
+;; *Filter Parsing
+;;
+
+(defun tablist-filter-parser-init (&optional reinitialize interactive)
+ (interactive (list t t))
+ (unless (and tablist-filter-lexer-regexps
+ (not reinitialize))
+ (let ((re (mapcar
+ (lambda (l)
+ (let ((re (regexp-opt
+ (mapcar 'symbol-name
+ (mapcar 'car l)) t)))
+ (if (= (length re) 0)
+ ".\\`" ;;matches nothing
+ re)))
+ (list tablist-filter-binary-operator
+ tablist-filter-unary-operator))))
+ (setq tablist-filter-lexer-regexps
+ (nreverse
+ (cons (concat "\\(?:" (car re) "\\|" (cadr re)
+ "\\|[ \t\f\r\n\"!()]\\|&&\\|||\\)")
+ re)))))
+ (unless (and tablist-filter-wisent-parser
+ (not reinitialize))
+ (let ((wisent-compile-grammar*
+ (symbol-function
+ 'wisent-compile-grammar)))
+ (setq tablist-filter-wisent-parser
+ ;; Trick the byte-compile into not using the byte-compile
+ ;; handler in semantic/wisent/comp.el, since it does not
+ ;; always work (wisent-context-compile-grammar n/a).
+ (funcall wisent-compile-grammar*
+ tablist-filter-wisent-grammar))))
+ (when interactive
+ (message "Parser reinitialized."))
+ nil)
+
+(defun tablist-filter-wisent-lexer ()
+ (cl-destructuring-bind (unary-op binary-op keywords)
+ tablist-filter-lexer-regexps
+ (skip-chars-forward " \t\f\r\n")
+ (cond
+ ((eobp) (list wisent-eoi-term))
+ ((= ?\" (char-after))
+ `(operand , (condition-case err
+ (read (current-buffer))
+ (error (signal (car err) (cons
+ "invalid lisp string"
+ (cdr err)))))))
+ ((looking-at unary-op)
+ (goto-char (match-end 0))
+ `(unary-operator ,(match-string-no-properties 0)))
+ ((looking-at binary-op)
+ (goto-char (match-end 0))
+ `(binary-operator ,(match-string-no-properties 0)))
+ ((looking-at "&&")
+ (forward-char 2)
+ `(and "&&"))
+ ((looking-at "||")
+ (forward-char 2)
+ `(or "||"))
+ ((= ?! (char-after))
+ (forward-char)
+ `(not "!"))
+ ((= ?\( (char-after))
+ (forward-char)
+ `(?\( "("))
+ ((= ?\) (char-after))
+ (forward-char)
+ `(?\) ")"))
+ (t
+ (let ((beg (point)))
+ (when (re-search-forward keywords nil 'move)
+ (goto-char (match-beginning 0)))
+ `(operand ,(buffer-substring-no-properties
+ beg
+ (point))))))))
+
+(defun tablist-filter-parse (filter)
+ (interactive "sFilter: ")
+ (tablist-filter-parser-init)
+ (with-temp-buffer
+ (save-excursion (insert filter))
+ (condition-case error
+ (wisent-parse tablist-filter-wisent-parser
+ 'tablist-filter-wisent-lexer
+ (lambda (msg)
+ (signal 'error
+ (replace-regexp-in-string
+ "\\$EOI" "end of input"
+ msg t t))))
+ (error
+ (signal 'error
+ (append (if (consp (cdr error))
+ (cdr error)
+ (list (cdr error)))
+ (list (point))))))))
+
+(defun tablist-filter-unparse (filter &optional noerror)
+ (cl-labels
+ ((unparse (filter &optional noerror)
+ (cond
+ ((stringp filter)
+ (if (or (string-match (nth 2 tablist-filter-lexer-regexps)
+ filter)
+ (= 0 (length filter)))
+ (format "%S" filter)
+ filter))
+ ((and (eq (car-safe filter) 'not)
+ (= (length filter) 2))
+ (let ((paren (memq (car-safe (nth 1 filter)) '(or and))))
+ (format "!%s%s%s"
+ (if paren "(" "")
+ (unparse (cadr filter) noerror)
+ (if paren ")" ""))))
+ ((and (memq (car-safe filter) '(and or))
+ (= (length filter) 3))
+ (let ((lparen (and (eq (car filter) 'and)
+ (eq 'or (car-safe (car-safe (cdr filter))))))
+ (rparen (and (eq (car filter) 'and)
+ (eq 'or (car-safe (car-safe (cddr filter)))))))
+ (format "%s%s%s %s %s%s%s"
+ (if lparen "(" "")
+ (unparse (cadr filter) noerror)
+ (if lparen ")" "")
+ (cl-case (car filter)
+ (and "&&") (or "||"))
+ (if rparen "(" "")
+ (unparse (car (cddr filter)) noerror)
+ (if rparen ")" ""))))
+ ((and (assq (car-safe filter) tablist-filter-binary-operator)
+ (= (length filter) 3))
+ (format "%s %s %s"
+ (unparse (cadr filter) noerror)
+ (car filter)
+ (unparse (car (cddr filter)) noerror)))
+ ((and (assq (car-safe filter) tablist-filter-unary-operator)
+ (= (length filter) 2))
+ (format "%s %s"
+ (car filter)
+ (unparse (cadr filter) noerror)))
+ ((not filter) "")
+ (t (funcall (if noerror 'format 'error)
+ "Invalid filter: %s" filter)))))
+ (tablist-filter-parser-init)
+ (unparse filter noerror)))
+
+(defun tablist-filter-eval (filter id entry &optional named-alist)
+ (cl-labels
+ ((feval (filter)
+ (pcase filter
+ (`(not . ,(and operand (guard (not (cdr operand)))))
+ (not (feval (car operand))))
+ (`(and . ,(and operands (guard (= 2 (length operands)))))
+ (and
+ (feval (nth 0 operands))
+ (feval (nth 1 operands))))
+ (`(or . ,(and operands (guard (= 2 (length operands)))))
+ (or
+ (feval (nth 0 operands))
+ (feval (nth 1 operands))))
+ (`(,op . ,(and operands (guard (= (length operands) 1))))
+ (let ((fn (assq op tablist-filter-unary-operator)))
+ (unless fn
+ (error "Undefined unary operator: %s" op))
+ (funcall fn id entry (car operands))))
+ (`(,op . ,(and operands (guard (= (length operands) 2))))
+ (let ((fn (cdr (assq op tablist-filter-binary-operator))))
+ (unless fn
+ (error "Undefined binary operator: %s" op))
+ (funcall fn id entry (car operands)
+ (cadr operands))))
+ ((guard (stringp filter))
+ (let ((fn (cdr (assoc filter named-alist))))
+ (unless fn
+ (error "Undefined named filter: %s" filter))
+ (if (functionp fn)
+ (funcall fn id entry))
+ (feval
+ (if (stringp fn) (tablist-filter-unparse fn) fn))))
+ (`nil t)
+ (_ (error "Invalid filter: %s" filter)))))
+ (feval filter)))
+
+;;
+;; *Filter Operators
+;;
+
+(defun tablist-filter-get-item-by-name (entry col-name)
+ (let* ((col (cl-position col-name tabulated-list-format
+ :key 'car
+ :test
+ (lambda (s1 s2)
+ (eq t (compare-strings
+ s1 nil nil s2 nil nil t)))))
+ (item (and col (elt entry col))))
+ (unless col
+ (error "No such column: %s" col-name))
+ (if (consp item) ;(LABEL . PROPS)
+ (car item)
+ item)))
+
+(defun tablist-filter-op-equal (_id entry op1 op2)
+ "COLUMN == STRING : Matches if COLUMN's entry is equal to STRING."
+ (let ((item (tablist-filter-get-item-by-name entry op1)))
+ (string= item op2)))
+
+(defun tablist-filter-op-regexp (_id entry op1 op2)
+ "COLUMN =~ REGEXP : Matches if COLUMN's entry matches REGEXP."
+ (let ((item (tablist-filter-get-item-by-name entry op1)))
+ (string-match op2 item)))
+
+(defun tablist-filter-op-< (id entry op1 op2)
+ "COLUMN < NUMBER : Matches if COLUMN's entry is less than NUMBER."
+ (tablist-filter-op-numeric '< id entry op1 op2))
+
+(defun tablist-filter-op-> (id entry op1 op2)
+ "COLUMN > NUMBER : Matches if COLUMN's entry is greater than NUMBER."
+ (tablist-filter-op-numeric '> id entry op1 op2))
+
+(defun tablist-filter-op-<= (id entry op1 op2)
+ "COLUMN <= NUMBER : Matches if COLUMN's entry is less than or equal to NUMBER."
+ (tablist-filter-op-numeric '<= id entry op1 op2))
+
+(defun tablist-filter-op->= (id entry op1 op2)
+ "COLUMN >= NUMBER : Matches if COLUMN's entry is greater than or equal to NUMBER."
+ (tablist-filter-op-numeric '>= id entry op1 op2))
+
+(defun tablist-filter-op-= (id entry op1 op2)
+ "COLUMN = NUMBER : Matches if COLUMN's entry as a number is equal to NUMBER."
+ (tablist-filter-op-numeric '= id entry op1 op2))
+
+(defun tablist-filter-op-numeric (op _id entry op1 op2)
+ (let ((item (tablist-filter-get-item-by-name entry op1)))
+ (funcall op (string-to-number item)
+ (string-to-number op2))))
+
+(defun tablist-filter-help (&optional temporary)
+ (interactive)
+ (cl-labels
+ ((princ-op (op)
+ (princ (car op))
+ (princ (concat (make-string (max 0 (- 4 (length (symbol-name (car op)))))
+ ?\s)
+ "- "
+ (car (split-string
+ (or (documentation (cdr op))
+ (format "FIXME: Not documented: %s"
+ (cdr op)))
+ "\n" t))
+ "\n"))))
+ (with-temp-buffer-window
+ "*Help*"
+ (if temporary
+ '((lambda (buf alist)
+ (let ((win
+ (or (display-buffer-reuse-window buf alist)
+ (display-buffer-in-side-window buf alist))))
+ (fit-window-to-buffer win)
+ win))
+ (side . bottom)))
+ nil
+ (princ "Filter entries with the following operators.\n\n")
+ (princ "&& - FILTER1 && FILTER2 : Locical and.\n")
+ (princ "|| - FILTER1 || FILTER2 : Locical or.\n")
+ (dolist (op tablist-filter-binary-operator)
+ (princ-op op))
+ (princ "! - ! FILTER : Locical not.\n\n")
+ (dolist (op tablist-filter-unary-operator)
+ (princ-op op))
+ (princ "\"...\" may be used to quote names and values if necessary,
+and \(...\) to group expressions.")
+ (with-current-buffer standard-output
+ (help-mode)))))
+
+;;
+;; *Filter Functions
+;;
+
+;; filter ::= nil | named | fn | (OP OP1 [OP2])
+
+(defun tablist-filter-negate (filter)
+ "Return a filter not matching filter."
+ (cond
+ ((eq (car-safe filter) 'not)
+ (cadr filter))
+ (filter
+ (list 'not filter))))
+
+(defun tablist-filter-push (filter new-filter &optional or-p)
+ "Return a filter combining FILTER and NEW-FILTER.
+
+By default the filters are and'ed, unless OR-P is non-nil."
+ (if (or (null filter)
+ (null new-filter))
+ (or filter
+ new-filter)
+ (list (if or-p 'or 'and)
+ filter new-filter)))
+
+(defun tablist-filter-pop (filter)
+ "Remove the first operator or operand from filter.
+
+If filter starts with a negation, return filter unnegated,
+if filter starts with a dis- or conjunction, remove the first operand,
+if filter is nil, raise an error,
+else return nil."
+ (pcase filter
+ (`(,(or `and `or) . ,tail)
+ (car (cdr tail)))
+ (`(not . ,op1)
+ (car op1))
+ (_ (unless filter
+ (error "Filter is empty")))))
+
+(defun tablist-filter-map (fn filter)
+ (pcase filter
+ (`(,(or `and `or `not) . ,tail)
+ (cons (car filter)
+ (mapcar (lambda (f)
+ (tablist-filter-map fn f))
+ tail)))
+ (_ (funcall fn filter))))
+
+;;
+;; *Reading Filter
+;;
+
+(defvar tablist-filter-edit-history nil)
+(defvar tablist-filter-edit-display-help t)
+
+(defun tablist-filter-edit-filter (prompt &optional
+ initial-filter history
+ validate-fn)
+ (let* ((str (tablist-filter-unparse initial-filter))
+ (filter initial-filter)
+ (validate-fn (or validate-fn 'identity))
+ error done)
+ (save-window-excursion
+ (when tablist-filter-edit-display-help
+ (tablist-filter-help t))
+ (while (not done)
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (when error
+ (when (car error)
+ (goto-char (+ (field-beginning)
+ (car error)))
+ (skip-chars-backward " \t\n"))
+ (minibuffer-message "%s" (cdr error))
+ (setq error nil)))
+ (setq str (propertize
+ (read-string prompt str
+ (or history 'tablist-filter-edit-history)))
+ done t))
+ (condition-case err
+ (progn
+ (setq filter (tablist-filter-parse str))
+ (funcall validate-fn filter))
+ (error
+ (setq done nil)
+ (setq error (cons (car-safe (cddr err)) nil))
+ (when (car error)
+ (setq str (with-temp-buffer
+ (insert str)
+ (goto-char (car error))
+ (set-text-properties
+ (progn
+ (skip-chars-backward " \t\n")
+ (backward-char)
+ (point))
+ (min (car error) (point-max))
+ '(face error rear-nonsticky t))
+ (buffer-string))))
+ (setcdr error (error-message-string err)))))
+ filter)))
+
+(provide 'tablist-filter)
+;; Local Variables:
+;; outline-regexp: ";;\\(\\(?:[;*]+ \\| \\*+\\)[^\s\t\n]\\|###autoload\\)\\|("
+;; indent-tabs-mode: nil
+;; End:
+;;; tablist-filter.el ends here
--- /dev/null
+(define-package "tablist" "20230321.705" "Extended tabulated-list-mode"
+ '((emacs "24.3"))
+ :commit "5f7b71a92bfb25418d7da86ad9c45f14b149496f" :authors
+ '(("Andreas Politz" . "politzaNOSPAMfh-trier.de"))
+ :maintainers
+ '(("Andreas Politz" . "politzaNOSPAMfh-trier.de"))
+ :maintainer
+ '("Andreas Politz" . "politzaNOSPAMfh-trier.de")
+ :keywords
+ '("extensions" "lisp"))
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
--- /dev/null
+;;; tablist.el --- Extended tabulated-list-mode -*- lexical-binding: t -*-
+
+;; Copyright (C) 2013, 2014 Andreas Politz
+
+;; Author: Andreas Politz <politzaNOSPAMfh-trier.de>
+;; Keywords: extensions, lisp
+;; Package: tablist
+;; Version: 1.0
+;; Package-Requires: ((emacs "24.3"))
+
+;; This program 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 of the License, or
+;; (at your option) any later version.
+
+;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This package adds marks and filters to tabulated-list-mode. It
+;; also kind of puts a dired face on tabulated list buffers.
+;;
+;; It can be used by deriving from tablist-mode and some features by
+;; using tablist-minor-mode inside a tabulated-list-mode buffer.
+;;
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'ring)
+(require 'tabulated-list)
+(require 'dired)
+(require 'tablist-filter)
+
+;;
+;; *Macros
+;;
+
+(defmacro tablist-save-marks (&rest body)
+ "Eval body, while preserving all marks."
+ (let ((marks (make-symbol "marks")))
+ `(let (,marks)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((re "^\\([^ ]\\)"))
+ (while (re-search-forward re nil t)
+ (push (cons (tabulated-list-get-id)
+ (tablist-get-mark-state))
+ ,marks))))
+ (unwind-protect
+ (progn ,@body)
+ (save-excursion
+ (dolist (m ,marks)
+ (let ((id (pop m)))
+ (goto-char (point-min))
+ (while (and id (not (eobp)))
+ (when (equal id (tabulated-list-get-id))
+ (tablist-put-mark-state m)
+ (setq id nil))
+ (forward-line)))))))))
+
+(defmacro tablist-with-remembering-entry (&rest body)
+ "Remember where body left of and restore previous position.
+
+If the current entry is still visible, move to it. Otherwise move
+to the next visible one after it. If that also fails, goto to
+the beginning of the buffer. Finally move point to the major
+column."
+ (declare (indent 0) (debug t))
+ (let ((re (make-symbol "re"))
+ (id (make-symbol "id"))
+ (col (make-symbol "col")))
+ `(let ((,re
+ (replace-regexp-in-string
+ "[\t ]+" "[\t ]*" (regexp-quote
+ (or (thing-at-point 'line) ""))
+ t t))
+ (,id (tabulated-list-get-id))
+ (,col (tablist-current-column)))
+ (progn
+ ,@body
+ (let (success pos)
+ (goto-char (point-min))
+ (setq pos (point))
+ (while (and (setq success (re-search-forward ,re nil t))
+ (> (point) (prog1 pos (setq pos (point))))
+ (forward-line -1)
+ (not (equal ,id (tabulated-list-get-id))))
+ (forward-line))
+ (unless success
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (not success))
+ (if (equal (tabulated-list-get-id) ,id)
+ (setq success t)
+ (forward-line))))
+ (unless (and success (not (invisible-p (point))))
+ (goto-char (point-min)))
+ (tablist-skip-invisible-entries)
+ (tablist-move-to-column
+ (or ,col (car (tablist-major-columns))))
+ (dolist (win (get-buffer-window-list))
+ (set-window-point win (point))))))))
+
+(defmacro tablist-with-filter-displayed (&rest body)
+ "Display the current filter in the mode while evalling BODY."
+ (let ((state (make-symbol "state")))
+ `(let ((,state (tablist-display-filter 'state)))
+ (tablist-display-filter t)
+ (unwind-protect
+ (progn ,@body)
+ (tablist-display-filter ,state)))))
+
+;;
+;; *Mode Maps
+;;
+
+(defvar tablist-mode-filter-map
+ (let ((kmap (make-sparse-keymap)))
+ (define-key kmap "p" #'tablist-pop-filter)
+ (define-key kmap "r" #'tablist-push-regexp-filter)
+ (define-key kmap "=" #'tablist-push-equal-filter)
+ (define-key kmap "n" #'tablist-push-numeric-filter)
+ (define-key kmap "!" #'tablist-negate-filter)
+ (define-key kmap "t" #'tablist-toggle-first-filter-logic)
+ (define-key kmap "/" #'tablist-display-filter)
+ (define-key kmap "z" #'tablist-suspend-filter)
+
+ (define-key kmap "a" #'tablist-push-named-filter)
+ (define-key kmap "s" #'tablist-name-current-filter)
+ (define-key kmap "D" #'tablist-delete-named-filter)
+ (define-key kmap "d" #'tablist-deconstruct-named-filter)
+ (define-key kmap "e" #'tablist-edit-filter)
+ (define-key kmap "C" #'tablist-clear-filter)
+ kmap))
+
+(defvar tablist-mode-mark-map
+ (let ((kmap (make-sparse-keymap)))
+ (define-key kmap "c" #'tablist-change-marks)
+ (define-key kmap "!" #'tablist-unmark-all-marks)
+ (define-key kmap "r" #'tablist-mark-items-regexp)
+ (define-key kmap "n" #'tablist-mark-items-numeric)
+ (define-key kmap "m" #'tablist-mark-forward)
+ kmap))
+
+(defvar tablist-mode-regexp-map
+ (let ((kmap (make-sparse-keymap)))
+ ;; (define-key kmap "&" #'tablist-flag-gargabe-items)
+ (define-key kmap "m" #'tablist-mark-items-regexp)
+ kmap))
+
+(defvar tablist-minor-mode-map
+ (let ((kmap (make-sparse-keymap)))
+ (define-key kmap "m" #'tablist-mark-forward)
+ (define-key kmap (kbd "DEL") #'tablist-unmark-backward)
+ (define-key kmap "k" #'tablist-do-kill-lines)
+ (define-key kmap "U" #'tablist-unmark-all-marks)
+ (define-key kmap "u" #'tablist-unmark-forward)
+ (define-key kmap "t" #'tablist-toggle-marks)
+
+ (define-key kmap (kbd "TAB") #'tablist-forward-column)
+ (define-key kmap "\t" #'tablist-forward-column)
+ (define-key kmap [backtab] #'tablist-backward-column)
+
+ (define-key kmap "%" tablist-mode-regexp-map)
+ (define-key kmap "*" tablist-mode-mark-map)
+ (define-key kmap "/" tablist-mode-filter-map)
+
+ ;; (define-key kmap "e" #'tablist-edit-column)
+ ;; (define-key kmap "i" #'tablist-insert-entry)
+ (define-key kmap "s" #'tablist-sort)
+ (define-key kmap [remap back-to-indentation] #'tablist-move-to-major-column)
+ (define-key kmap [remap next-line] #'tablist-next-line)
+ (define-key kmap [remap previous-line] #'tablist-previous-line)
+ (define-key kmap "<" #'tablist-shrink-column)
+ (define-key kmap ">" #'tablist-enlarge-column)
+ (define-key kmap "q" #'tablist-quit)
+ (define-key kmap "G" #'tablist-revert)
+ (define-key kmap (kbd "C-c C-e") #'tablist-export-csv)
+ kmap))
+
+(defvar tablist-mode-map
+ (let ((kmap (copy-keymap tablist-minor-mode-map)))
+ (set-keymap-parent kmap tabulated-list-mode-map)
+ (define-key kmap "d" #'tablist-flag-forward)
+ (define-key kmap (kbd "RET") #'tablist-find-entry)
+ (define-key kmap "f" #'tablist-find-entry)
+ ;; (define-key kmap "~" #'tablist-flag-gargabe-items)
+ (define-key kmap "D" #'tablist-do-delete)
+ ;; (define-key kmap "C" #'tablist-do-copy)
+ ;; (define-key kmap "R" #'tablist-do-rename)
+ (define-key kmap "x" #'tablist-do-flagged-delete)
+ ;; (define-key kmap "F" #'tablist-find-marked-items)
+ ;; (define-key kmap (kbd "C-o") #'tablist-display-item)
+ kmap))
+
+;;
+;; *Variables
+;;
+
+;; Marking
+(defvar tablist-umark-filtered-entries t)
+(defvar tablist-marker-char dired-marker-char
+ "The character used for marking.")
+(defvar tablist-marker-face 'dired-mark
+ "The face used for the mark character.")
+(defvar tablist-marked-face 'dired-marked
+ "The face used for marked major columns.")
+
+;; Operations
+(defvar-local tablist-operations-function nil
+ "A function for handling operations on the entries.
+
+The function is called with varying number of arguments, while
+the first one is always a symbol describing one of the following
+operations.
+
+`supported-operations'
+
+This is the only mandatory operation. There are no other
+arguments and the function should return a list of symbols of
+supported operations.
+
+`delete'
+
+The 2nd argument will be a list of entry ID's. The function
+should somehow delete these entries and update
+`tabulated-list-entries'.
+
+`find-entry'
+
+The 2nd argument is the ID of an entry. The function should
+somehow find/display this entry, i.e. a kind of default
+operation.
+
+`edit-column'
+
+The function is called with 3 further arguments: ID, INDEX and
+NEW-COLUMN, where ID represents the entry to edit, INDEX is the index
+of the column and NEW-COLUMN is the proposed new value for this
+column. It should either
+
+i. return a new edited complete entry and update
+`tabulated-list-entries', or
+
+ii. throw an error, if NEW-COLUMN is not a valid value for this
+column.
+
+`complete'
+
+The function is called with 4 further arguments: ID, INDEX,
+STRING and POS, where ID represents an entry, INDEX is the index
+of the column to complete, STRING it's current value and POS an
+offset of the current position of point into STRING.
+
+The function should return a collection for this column, suitable
+as argument for the function `completion-in-region'.")
+
+;; Differentiating columns
+(defvar-local tablist-major-columns nil
+ "Columns used to mark and when querying.")
+
+;; Filter
+(defvar-local tablist-current-filter nil)
+(defvar-local tablist-filter-suspended nil)
+(defvar tablist-named-filter nil)
+
+;; History variables
+(defvar tablist-column-name-history nil)
+
+;; Hooks
+(defvar tablist-selection-changed-functions nil
+ "A hook run when ever point moves to a different entry.")
+
+;; Context Window
+(defvar-local tablist-context-window nil)
+(defvar-local tablist-context-window-function nil)
+(defvar tablist-context-window-display-action
+ `((display-buffer-reuse-window
+ tablist-display-buffer-split-below-and-attach)
+ (window-height . 0.25)
+ (inhibit-same-window . t)))
+
+;;
+;; *Setup
+;;
+
+(defvar savehist-additional-variables)
+(add-hook 'savehist-save-hook
+ (lambda nil
+ (add-to-list 'savehist-additional-variables 'tablist-named-filter)))
+
+;;;###autoload
+(define-minor-mode tablist-minor-mode
+ "Toggle tablist minor mode."
+ :global nil
+ (unless (derived-mode-p 'tabulated-list-mode)
+ (error "Buffer is not in Tabulated List Mode"))
+ (tablist-init (not tablist-minor-mode)))
+
+;;;###autoload
+(define-derived-mode tablist-mode tabulated-list-mode "TL"
+ (tablist-init))
+
+(defun tablist-init (&optional disable)
+ (let ((cleaned-misc (cl-remove 'tablist-current-filter
+ mode-line-misc-info :key #'car-safe)))
+ (cond
+ ((not disable)
+ (set (make-local-variable 'mode-line-misc-info)
+ (append
+ (list
+ (list 'tablist-current-filter
+ '(:eval (format " [%s]"
+ (if tablist-filter-suspended
+ "suspended"
+ "filtered")))))))
+ (add-hook 'post-command-hook
+ 'tablist-selection-changed-handler nil t)
+ (add-hook 'tablist-selection-changed-functions
+ 'tablist-context-window-update nil t))
+ (t
+ (setq mode-line-misc-info cleaned-misc)
+ (remove-hook 'post-command-hook
+ 'tablist-selection-changed-handler t)
+ (remove-hook 'tablist-selection-changed-functions
+ 'tablist-context-window-update t)))))
+
+(defun tablist-quit ()
+ (interactive)
+ (tablist-hide-context-window)
+ (quit-window))
+
+(defvar-local tablist-selected-id nil)
+(defvar tablist-edit-column-minor-mode)
+
+(defun tablist-selection-changed-handler ()
+ (unless tablist-edit-column-minor-mode
+ (let ((id tablist-selected-id)
+ (selected (tabulated-list-get-id)))
+ (unless (eq selected id)
+ (setq tablist-selected-id selected)
+ (run-hook-with-args
+ 'tablist-selection-changed-functions
+ tablist-selected-id)))))
+
+(defvar tablist-context-window-update--timer nil)
+
+(defun tablist-context-window-update (&optional id)
+ (when (and tablist-context-window-function
+ (window-live-p tablist-context-window)
+ (not tablist-edit-column-minor-mode))
+ (unless id
+ (setq id (tabulated-list-get-id)))
+ (when (timerp tablist-context-window-update--timer)
+ (cancel-timer tablist-context-window-update--timer))
+ (setq tablist-context-window-update--timer
+ (run-with-idle-timer 0.1 nil
+ (lambda (fn window)
+ (when (window-live-p window)
+ (with-selected-window window
+ (set-window-dedicated-p nil nil)
+ (save-selected-window
+ (funcall fn id))
+ (when (window-live-p (selected-window))
+ (set-window-dedicated-p nil t)))))
+ tablist-context-window-function
+ tablist-context-window))))
+
+(defun tablist-display-context-window ()
+ (interactive)
+ (unless tablist-context-window-function
+ (error "No function for handling a context is defined"))
+ (unless (window-live-p tablist-context-window)
+ (setq tablist-context-window
+ (display-buffer
+ (current-buffer)
+ tablist-context-window-display-action)))
+ (prog1
+ tablist-context-window
+ (tablist-context-window-update)))
+
+(defun tablist-hide-context-window ()
+ (interactive)
+ (when (window-live-p tablist-context-window)
+ (let ((ignore-window-parameters t))
+ (delete-window tablist-context-window)))
+ (setq tablist-context-window nil))
+
+(defun tablist-toggle-context-window ()
+ (interactive)
+ (if (window-live-p tablist-context-window)
+ (tablist-hide-context-window)
+ (tablist-display-context-window)))
+
+;;
+;; *Marking
+;;
+
+(defun tablist-revert ()
+ "Revert the list with marks preserved, position kept."
+ (interactive)
+ (tablist-save-marks
+ (tablist-with-remembering-entry
+ (tabulated-list-revert))))
+
+(defun tablist-major-columns ()
+ (if (null tablist-major-columns)
+ (number-sequence 0 (1- (length tabulated-list-format)))
+ (if (numberp tablist-major-columns)
+ (list tablist-major-columns)
+ tablist-major-columns)))
+
+(defun tablist-put-mark (&optional pos)
+ "Put a mark before the entry at POS.
+
+POS defaults to point. Use `tablist-marker-char',
+`tablist-marker-face', `tablist-marked-face' and
+`tablist-major-columns' to determine how to mark and what to put
+a face on."
+ (when (or (null tabulated-list-padding)
+ (< tabulated-list-padding 1))
+ (setq tabulated-list-padding 1)
+ (tabulated-list-revert))
+ (save-excursion
+ (and pos (goto-char pos))
+ (unless (tabulated-list-get-id)
+ (error "No entry at this position"))
+ (let ((inhibit-read-only t))
+ (tabulated-list-put-tag
+ (string tablist-marker-char))
+ (put-text-property
+ (point-at-bol)
+ (1+ (point-at-bol))
+ 'face tablist-marker-face)
+ (let ((columns (tablist-column-offsets)))
+ (dolist (c (tablist-major-columns))
+ (when (and (>= c 0)
+ (< c (length columns)))
+ (let ((beg (+ (point-at-bol)
+ (nth c columns)))
+ (end (if (= c (1- (length columns)))
+ (point-at-eol)
+ (+ (point-at-bol)
+ (nth (1+ c) columns)))))
+ (cond
+ ((and tablist-marked-face
+ (not (eq tablist-marker-char ?\s)))
+ (tablist--save-face-property beg end)
+ (put-text-property
+ beg end 'face tablist-marked-face))
+ (t (tablist--restore-face-property beg end))))))))))
+
+(defun tablist-mark-forward (&optional arg interactive)
+ "Mark ARG entries forward.
+
+ARG is interpreted as a prefix-arg. If interactive is non-nil,
+maybe use the active region instead of ARG.
+
+See `tablist-put-mark' for how entries are marked."
+ (interactive (list current-prefix-arg t))
+ (cond
+ ;; Mark files in the active region.
+ ((and interactive (use-region-p))
+ (save-excursion
+ (goto-char (region-beginning))
+ (beginning-of-line)
+ (tablist-repeat-over-lines
+ (1+ (count-lines
+ (point)
+ (save-excursion
+ (goto-char (region-end))
+ (beginning-of-line)
+ (point))))
+ 'tablist-put-mark)))
+ ;; Mark the current (or next ARG) files.
+ (t
+ (tablist-repeat-over-lines
+ (prefix-numeric-value arg)
+ 'tablist-put-mark))))
+
+(defun tablist-mark-backward (&optional arg interactive)
+ "Mark ARG entries backward.
+
+See `tablist-mark-forward'."
+ (interactive (list current-prefix-arg t))
+ (tablist-mark-forward (- (prefix-numeric-value arg))
+ interactive))
+
+(defun tablist-unmark-forward (&optional arg interactive)
+ "Unmark ARG entries forward.
+
+See `tablist-mark-forward'."
+ (interactive (list current-prefix-arg t))
+ (let ((tablist-marker-char ?\s)
+ tablist-marked-face)
+ (tablist-mark-forward arg interactive)))
+
+(defun tablist-unmark-backward (&optional arg interactive)
+ "Unmark ARG entries backward.
+
+See `tablist-mark-forward'."
+ (interactive (list current-prefix-arg t))
+ (let ((tablist-marker-char ?\s)
+ tablist-marked-face)
+ (tablist-mark-backward arg interactive)))
+
+(defun tablist-flag-forward (&optional arg interactive)
+ "Flag ARG entries forward.
+
+See `tablist-mark-forward'."
+ (interactive (list current-prefix-arg t))
+ (let ((tablist-marker-char ?D)
+ (tablist-marked-face 'dired-flagged))
+ (tablist-mark-forward arg interactive)))
+
+(defun tablist-change-marks (old new)
+ "Change all OLD marks to NEW marks.
+
+OLD and NEW are both characters used to mark files."
+ (interactive
+ (let* ((cursor-in-echo-area t)
+ (old (progn (message "Change (old mark): ") (read-char)))
+ (new (progn (message "Change %c marks to (new mark): " old)
+ (read-char))))
+ (list old new)))
+ (when (eq new ?\n)
+ (error "Mark character \\n is not allowed"))
+ (let ((default-mark-p (equal tablist-marker-char new))
+ (tablist-marker-char old))
+ (save-excursion
+ (tablist-map-over-marks
+ (lambda nil
+ (pcase new
+ (?D
+ (tablist-flag-forward 1))
+ (_
+ (let ((tablist-marker-char new)
+ (tablist-marked-face
+ (and default-mark-p
+ tablist-marked-face)))
+ (tablist-put-mark)))))))))
+
+(defun tablist-unmark-all-marks (&optional marks interactive)
+ "Remove all marks in MARKS.
+
+MARKS should be a string of mark characters to match and defaults
+to all marks. Interactively, remove all marks, unless a prefix
+arg was given, in which case ask about which ones to remove.
+Give a message, if interactive is non-nil.
+
+Returns the number of unmarked marks."
+ (interactive
+ (list (if current-prefix-arg
+ (read-string "Remove marks: ")) t))
+ (let ((re (if marks
+ (tablist-marker-regexp marks)
+ "^[^ ]"))
+ (removed 0))
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward re nil t)
+ (let ((tablist-marker-char ?\s)
+ tablist-marker-face
+ tablist-marked-face)
+ (tablist-put-mark))
+ (cl-incf removed)))
+ (when interactive
+ (message "Removed %d marks" removed))
+ removed))
+
+(defun tablist-toggle-marks ()
+ "Unmark all marked and mark all unmarked entries.
+
+See `tablist-put-mark'."
+ (interactive)
+ (let ((marked-re (tablist-marker-regexp))
+ (not-marked-re
+ (let ((tablist-marker-char ?\s))
+ (tablist-marker-regexp))))
+ (save-excursion
+ (goto-char (point-min))
+ (tablist-skip-invisible-entries)
+ (while (not (eobp))
+ (cond
+ ((looking-at marked-re)
+ (save-excursion (tablist-unmark-backward -1)))
+ ((looking-at not-marked-re)
+ (tablist-put-mark)))
+ (tablist-forward-entry)))
+ (tablist-move-to-major-column)))
+
+(defun tablist-get-marked-items (&optional arg distinguish-one-marked)
+ "Return marked or ARG entries."
+ (let ((items (save-excursion
+ (tablist-map-over-marks
+ (lambda () (cons (tabulated-list-get-id)
+ (tabulated-list-get-entry)))
+ arg nil distinguish-one-marked))))
+ (if (and distinguish-one-marked
+ (eq (car items) t))
+ items
+ (nreverse items))))
+
+(defun tablist-mark-items-regexp (column-name regexp)
+ "Mark entries matching REGEXP in column COLUMN-NAME."
+ (interactive
+ (tablist-read-regexp-filter "Mark" current-prefix-arg ))
+ (tablist-map-with-filter
+ 'tablist-put-mark
+ `(=~ ,column-name ,regexp)))
+
+(defun tablist-mark-items-numeric (binop column-name operand)
+ "Mark items fulfilling BINOP with arg OPERAND in column COLUMN-NAME.
+
+First the column's value is coerced to a number N. Then the test
+proceeds as \(BINOP N OPERAND\)."
+ (interactive
+ (tablist-read-numeric-filter "Mark" current-prefix-arg))
+ (tablist-map-with-filter
+ 'tablist-put-mark
+ `(,binop ,column-name ,operand)))
+
+(defun tablist-map-over-marks (fn &optional arg show-progress
+ distinguish-one-marked)
+ (prog1
+ (cond
+ ((and arg (integerp arg))
+ (let (results)
+ (tablist-repeat-over-lines
+ arg
+ (lambda ()
+ (if show-progress (sit-for 0))
+ (push (funcall fn) results)))
+ (if (< arg 0)
+ (nreverse results)
+ results)))
+ (arg
+ ;; non-nil, non-integer ARG means use current item:
+ (tablist-skip-invisible-entries)
+ (unless (eobp)
+ (list (funcall fn))))
+ (t
+ (cl-labels ((search (re)
+ (let (success)
+ (tablist-skip-invisible-entries)
+ (while (and (setq success
+ (re-search-forward re nil t))
+ (invisible-p (point)))
+ (tablist-forward-entry))
+ success)))
+ (let ((regexp (tablist-marker-regexp))
+ next-position results found)
+ (save-excursion
+ (goto-char (point-min))
+ ;; remember position of next marked file before BODY
+ ;; can insert lines before the just found file,
+ ;; confusing us by finding the same marked file again
+ ;; and again and...
+ (setq next-position (and (search regexp)
+ (point-marker))
+ found (not (null next-position)))
+ (while next-position
+ (goto-char next-position)
+ (if show-progress (sit-for 0))
+ (push (funcall fn) results)
+ ;; move after last match
+ (goto-char next-position)
+ (forward-line 1)
+ (set-marker next-position nil)
+ (setq next-position (and (search regexp)
+ (point-marker)))))
+ (if (and distinguish-one-marked (= (length results) 1))
+ (setq results (cons t results)))
+ (if found
+ results
+ (unless (or (eobp) (invisible-p (point)))
+ (list (funcall fn))))))))
+ (tablist-move-to-major-column)))
+
+(defun tablist-marker-regexp (&optional marks)
+ "Return a regexp matching marks in MARKS.
+
+MARKS should be a string of mark characters to match and defaults
+to the current value of `tablist-marker-char' as a string."
+ (concat (format "^[%s]"
+ (or marks (string tablist-marker-char)))))
+
+(defun tablist-get-mark-state ()
+ "Return the mark state of the entry at point."
+ (save-excursion
+ (beginning-of-line)
+ (when (looking-at "^\\([^ ]\\)")
+ (let ((mark (buffer-substring
+ (match-beginning 1)
+ (match-end 1))))
+ (tablist-move-to-major-column)
+ (list (aref mark 0)
+ (get-text-property 0 'face mark)
+ (get-text-property (point) 'face))))))
+
+(defun tablist-put-mark-state (state)
+ "Set the mark of the entry at point according to STATE.
+
+STATE is a return value of `tablist-get-mark-state'."
+ (cl-destructuring-bind (tablist-marker-char
+ tablist-marker-face
+ tablist-marked-face)
+ state
+ (tablist-put-mark)))
+
+(defun tablist-mark-prompt (arg items)
+ "Return a string suitable for use in a tablist prompt."
+ ;; distinguish-one-marked can cause the first element to be just t.
+ (if (eq (car items) t) (setq items (cdr items)))
+ (let ((count (length items)))
+ (if (= count 1)
+ (car items)
+ ;; more than 1 item:
+ (if (integerp arg)
+ ;; abs(arg) = count
+ ;; Perhaps this is nicer, but it also takes more screen space:
+ ;;(format "[%s %d items]" (if (> arg 0) "next" "previous")
+ ;; count)
+ (format "[next %d item%s]"
+ arg (dired-plural-s arg))
+ (format "%c [%d item%s]" dired-marker-char count
+ (dired-plural-s count))))))
+
+;;
+;; *Movement
+;;
+
+(defun tablist-forward-entry (&optional n)
+ "Move past the next N unfiltered entries."
+ (unless n (setq n 1))
+ (while (and (> n 0)
+ (not (eobp)))
+ (forward-line)
+ (when (invisible-p (point))
+ (tablist-skip-invisible-entries))
+ (cl-decf n))
+ (while (and (< n 0)
+ (not (bobp)))
+ (forward-line -1)
+ (when (invisible-p (point))
+ (tablist-skip-invisible-entries t))
+ (cl-incf n))
+ n)
+
+(defun tablist-next-line (&optional n)
+ (interactive "p")
+ (when (and (< n 0)
+ (save-excursion
+ (end-of-line 0)
+ (tablist-skip-invisible-entries t)
+ (bobp)))
+ (signal 'beginning-of-buffer nil))
+ (when (and (> n 0)
+ (save-excursion
+ (tablist-forward-entry)
+ (eobp)))
+ (signal 'end-of-buffer nil))
+
+ (let ((col (tablist-current-column)))
+ (tablist-forward-entry (or n 1))
+ (if col
+ (tablist-move-to-column col)
+ (tablist-move-to-major-column))))
+
+(defun tablist-previous-line (&optional n)
+ (interactive "p")
+ (tablist-next-line (- (or n 1))))
+
+(defun tablist-repeat-over-lines (arg function)
+ "Call FUNCTION for the next ARG entries."
+ ;; Move out of potentially invisible area.
+ (tablist-skip-invisible-entries)
+ (let ((pos (make-marker)))
+ (while (and (> arg 0)
+ (not (eobp)))
+ (cl-decf arg)
+ (save-excursion
+ (tablist-forward-entry)
+ (move-marker pos (1+ (point))))
+ (unless (eobp)
+ (save-excursion (funcall function)))
+ ;; Advance to the next line--actually, to the line that *was* next.
+ ;; (If FUNCTION inserted some new lines in between, skip them.)
+ (goto-char pos))
+ (while (and (< arg 0) (not (bobp)))
+ (cl-incf arg)
+ (tablist-forward-entry -1)
+ (save-excursion (funcall function)))
+ (move-marker pos nil)
+ (tablist-move-to-major-column)))
+
+(defun tablist-move-to-column (n)
+ "Move to the N'th list column."
+ (interactive "p")
+ (when (tabulated-list-get-id)
+ (let ((columns (tablist-column-offsets)))
+ (when (or (< n 0)
+ (>= n (length columns)))
+ (error "No such column: %s" n))
+ (beginning-of-line)
+ (forward-char (nth n columns))
+ (when (and (plist-get (nthcdr 3 (elt tabulated-list-format n))
+ :right-align)
+ (not (= n (1- (length columns)))))
+ (forward-char (1- (car (cdr (elt tabulated-list-format n)))))))))
+
+(defun tablist-move-to-major-column (&optional first-skip-invisible-p)
+ "Move to the first major column."
+ (interactive (list t))
+ (when first-skip-invisible-p
+ (tablist-skip-invisible-entries))
+ (tablist-move-to-column (car (tablist-major-columns))))
+
+(defun tablist-forward-column (n)
+ "Move n columns forward, while wrapping around."
+ (interactive "p")
+ (unless (tabulated-list-get-id)
+ (error "No entry on this line"))
+ (let* ((columns (tablist-column-offsets))
+ (current (1- (length columns))))
+ ;; find current column
+ (while (and (>= current 0)
+ (> (nth current columns)
+ (current-column)))
+ (cl-decf current))
+ ;; there may be an invisible spec here
+ (when (bolp)
+ (forward-char))
+ ;; before any columns
+ (when (< current 0)
+ (goto-char (+ (point-at-bol) (if (> n 0)
+ (car columns)
+ (car (last columns)))))
+ (setq n (* (cl-signum n) (1- (abs n)))))
+ (when (/= n 0)
+ (tablist-move-to-column
+ (mod (+ current n) (length columns))))))
+
+(defun tablist-backward-column (n)
+ "Move n columns backward, while wrapping around."
+ (interactive "p")
+ (tablist-forward-column (- n)))
+
+;;
+(defun tablist-skip-invisible-entries (&optional backward)
+ "Skip invisible entries BACKWARD or forward.
+
+Do nothing, if the entry at point is visible. Otherwise move to
+the beginning of the next visible entry in the direction
+determined by BACKWARD.
+
+Return t, if point is now in a visible area."
+
+ (cond
+ ((and backward
+ (not (bobp))
+ (get-text-property (point) 'invisible))
+ (when (get-text-property (1- (point)) 'invisible)
+ (goto-char (previous-single-property-change
+ (point)
+ 'invisible nil (point-min))))
+ (forward-line -1))
+ ((and (not backward)
+ (not (eobp))
+ (get-text-property (point) 'invisible))
+ (goto-char (next-single-property-change
+ (point)
+ 'invisible nil (point-max)))))
+ (not (invisible-p (point))))
+
+;;
+;; *Operations
+;;
+
+(defun tablist-yes-or-no-p (operation arg items)
+ "Query the user whether to proceed with some operation.
+
+Operation should be a symbol or string describing the operation,
+ARG the prefix-arg of the command used in
+`tablist-get-marked-items' or elsewhere, to get the ITEMS."
+
+ (let ((pp-items (mapcar 'tablist-pretty-print-entry
+ (mapcar 'cdr items)))
+ dired-no-confirm
+ (op-str (upcase-initials
+ (if (stringp operation)
+ operation
+ (symbol-name operation)))))
+ (dired-mark-pop-up
+ (format " *%s*" op-str) nil
+ pp-items
+ dired-deletion-confirmer
+ (format "%s %s "
+ op-str
+ (tablist-mark-prompt arg pp-items)))))
+
+(defun tablist-operation-available-p (op)
+ (and (functionp tablist-operations-function)
+ (memq op (funcall tablist-operations-function
+ 'supported-operations))))
+
+(defun tablist-do-delete (&optional arg)
+ "Delete ARG entries."
+ (interactive "P")
+ (unless (tablist-operation-available-p 'delete)
+ (error "Deleting entries is not available in this buffer"))
+ (let ((items (tablist-get-marked-items arg)))
+ (when (tablist-yes-or-no-p 'delete arg items)
+ (tablist-do-kill-lines arg)
+ (funcall tablist-operations-function
+ 'delete (mapcar 'car items))
+ (tablist-move-to-major-column))))
+
+(defun tablist-do-flagged-delete (&optional interactive)
+ "Delete all entries marked with a D."
+ (interactive "p")
+ (let* ((tablist-marker-char ?D))
+ (if (save-excursion
+ (goto-char (point-min))
+ (re-search-forward (tablist-marker-regexp) nil t))
+ (tablist-do-delete)
+ (or (not interactive)
+ (message "(No deletions requested)")))))
+
+(defun tablist-do-kill-lines (&optional arg interactive)
+ "Remove ARG lines from the display."
+ (interactive (list current-prefix-arg t))
+ (save-excursion
+ (let ((positions
+ (tablist-map-over-marks 'point arg))
+ (inhibit-read-only t))
+ (dolist (pos positions)
+ (goto-char pos)
+ (tabulated-list-delete-entry))
+ (when interactive
+ (message (format "Killed %d line%s"
+ (length positions)
+ (dired-plural-s (length positions))))))))
+
+(defun tablist-do-operation (arg fn operation &optional delete-p revert-p)
+ "Operate on marked items.
+
+ARG should be the `current-prefix-arg', FN is a function of two
+arguments \(ID ENTRY\) handling the operation. It gets called
+repeatedly with all marked items. OPERATION is a symbol or string
+describing the operation, it is used for display.
+
+Optional non-nil DELETE-P means, remove the items from the display.
+Optional REVERT-P means, revert the display afterwards."
+ (let ((items (tablist-get-marked-items arg)))
+ (unless items
+ (error "No items marked"))
+ (when (tablist-yes-or-no-p operation arg items)
+ (when delete-p
+ (tablist-do-kill-lines arg))
+ (dolist (item items)
+ (funcall fn (car item)))
+ (when revert-p
+ (tablist-revert))
+ (tablist-move-to-major-column))))
+
+;;
+;; *Editing
+;;
+(defvar tablist-edit-column-minor-mode-map
+ (let ((kmap (make-sparse-keymap)))
+ (set-keymap-parent kmap (current-global-map))
+ (define-key kmap [remap self-insert-command] #'self-insert-command)
+ (define-key kmap "\r" #'tablist-edit-column-commit)
+ (define-key kmap (kbd "C-g") #'tablist-edit-column-quit)
+ (define-key kmap (kbd "C-c C-c") #'tablist-edit-column-commit)
+ (define-key kmap (kbd "C-c C-q") #'tablist-edit-column-quit)
+ (define-key kmap "\t" #'tablist-edit-column-complete)
+ (define-key kmap (kbd "TAB") #'tablist-edit-column-complete)
+ (define-key kmap [remap end-of-buffer] #'end-of-line)
+ (define-key kmap [remap beginning-of-buffer] #'beginning-of-line)
+ (define-key kmap [remap mark-whole-buffer] #'tablist-edit-column-mark-field)
+ kmap))
+
+(define-minor-mode tablist-edit-column-minor-mode
+ "Toggle tablist-edit-column minor mode."
+ :global nil
+ (unless (or tablist-minor-mode
+ (derived-mode-p 'tablist-mode))
+ (error "Not in a tablist buffer"))
+ (cond
+ (tablist-edit-column-minor-mode
+ (add-to-list 'mode-line-misc-info
+ '(tablist-edit-column-minor-mode "[edit]"))
+ (add-hook 'post-command-hook 'tablist-edit-column-constrain-point nil t)
+ (read-only-mode -1))
+ (t
+ (remove-hook 'post-command-hook 'tablist-edit-column-constrain-point t)
+ (read-only-mode 1))))
+
+(defun tablist-edit-column (&optional n)
+ (interactive "P")
+ (unless n (setq n (tablist-current-column)))
+ (tablist-assert-column-editable n)
+ (let* ((offsets (append (tablist-column-offsets)
+ (list (- (point-at-eol)
+ (point-at-bol)))))
+ (beg (+ (point-at-bol)
+ (nth n offsets)))
+ (end (+ (point-at-bol)
+ (nth (1+ n) offsets)))
+ (entry (tabulated-list-get-entry beg))
+ (inhibit-read-only t)
+ (inhibit-field-text-motion t)
+ (alist `((entry . ,entry)
+ (column . ,n)
+ (id . ,(tabulated-list-get-id beg))))
+ ov)
+ (goto-char beg)
+ (delete-region beg end)
+ (add-text-properties
+ (point-at-bol) (point-at-eol)
+ '(read-only t field t))
+ (unless (= beg (point-at-bol))
+ (put-text-property (1- beg) beg 'rear-nonsticky t))
+ (save-excursion
+ ;; Keep one read-only space at the end for keeping text
+ ;; properties.
+ (insert
+ (propertize
+ (concat
+ (tablist-nth-entry n entry)
+ (propertize " "
+ 'display `(space :align-to ,(- end (point-at-bol)))))
+ 'field nil
+ 'front-sticky '(tablist-edit)
+ 'rear-nonsticky '(read-only field)
+ 'tablist-edit alist))
+ (setq end (point)))
+ (add-text-properties
+ (1- end) end '(read-only t field 'tablist-edit-end))
+ (setq ov (make-overlay beg end))
+ (overlay-put ov 'priority 9999)
+ (overlay-put ov 'face '(:background "deep sky blue" :foreground "white"))
+ (overlay-put ov 'evaporate t)
+ (overlay-put ov 'tablist-edit t)
+ (tablist-edit-column-minor-mode 1)))
+
+(defun tablist-edit-column-quit ()
+ (interactive)
+ (tablist-edit-column-commit t))
+
+(defun tablist-edit-column-commit (&optional abandon-edit)
+ (interactive (list current-prefix-arg))
+ (let ((inhibit-read-only t)
+ (inhibit-field-text-motion t)
+ bounds)
+ (condition-case nil
+ (setq bounds (tablist-edit-column-bounds))
+ (error
+ (tablist-edit-column-minor-mode -1)
+ (tabulated-list-revert)
+ (put-text-property (point-min) (point-max)
+ 'tablist-edit nil)
+ (error "Unable to complete the edit")))
+ (let* ((beg (car bounds))
+ (end (cdr bounds))
+ (alist (get-text-property beg 'tablist-edit))
+ (column (cdr (assq 'column alist)))
+ (id (cdr (assq 'id alist)))
+ (entry (cdr (assq 'entry alist)))
+ (item (buffer-substring-no-properties beg (1- end))))
+
+ (unless abandon-edit
+ ;; Throws an error, if item is invalid.
+ (setq entry (funcall tablist-operations-function
+ 'edit-column id column item)))
+ (tablist-edit-column-minor-mode -1)
+ (remove-overlays beg end 'tablist-edit t)
+ (put-text-property beg end 'tablist-edit nil)
+ (delete-region (point-at-bol) (1+ (point-at-eol)))
+ (save-excursion
+ (tabulated-list-print-entry id entry))
+ (forward-char (nth column (tablist-column-offsets))))))
+
+(defun tablist-edit-column-complete ()
+ (interactive)
+ (unless (tablist-operation-available-p 'complete)
+ (error "Completion not available"))
+ (cl-destructuring-bind (beg &rest end)
+ (tablist-edit-column-bounds t)
+ (let* ((string (buffer-substring-no-properties
+ beg end))
+ (alist (get-text-property beg 'tablist-edit))
+ (completions (funcall tablist-operations-function
+ 'complete
+ (cdr (assq 'id alist))
+ (cdr (assq 'column alist))
+ string
+ (- (point) beg))))
+ (unless completions
+ (error "No completions available"))
+ (completion-in-region beg end completions))))
+
+(defun tablist-column-editable (n)
+ (and (tablist-operation-available-p 'edit-column)
+ (not (tablist-column-property n :read-only))))
+
+(defun tablist-assert-column-editable (n)
+ (unless (and (>= n 0)
+ (< n (length tabulated-list-format)))
+ (error "Invalid column number: %s" n))
+ (unless (tablist-operation-available-p 'edit-column)
+ (error "Editing columns not enabled in this buffer"))
+ (when (tablist-column-property n :read-only)
+ (error "This column is read-only")))
+
+(defun tablist-edit-column-constrain-point ()
+ (unless tablist-edit-column-minor-mode
+ (error "Not editing a column"))
+ (unless (get-text-property (point) 'tablist-edit)
+ (let ((bounds (tablist-edit-column-bounds)))
+ (when bounds
+ (if (> (point) (cdr bounds))
+ (goto-char (1- (cdr bounds)))
+ (goto-char (car bounds)))
+ (point)))))
+
+(defun tablist-edit-column-bounds (&optional skip-final-space)
+ (unless tablist-edit-column-minor-mode
+ (error "Not editing a column"))
+ (let ((pos (next-single-property-change
+ (point) 'tablist-edit))
+ beg end)
+ (cond
+ ((null pos)
+ (setq end (previous-single-property-change
+ (point-max) 'tablist-edit)
+ beg (previous-single-property-change
+ end 'tablist-edit)))
+ ((get-text-property pos 'tablist-edit)
+ (setq beg pos
+ end (next-single-property-change
+ pos 'tablist-edit)))
+ (pos
+ (setq end pos
+ beg (previous-single-property-change
+ pos 'tablist-edit))))
+
+ (unless (and beg end (get-text-property beg 'tablist-edit))
+ (error "Unable to locate edited text"))
+ (cons beg (if skip-final-space (1- end) end))))
+
+(defun tablist-edit-column-mark-field ()
+ (interactive)
+ (push-mark (field-beginning))
+ (push-mark (field-end) nil t)
+ (goto-char (field-beginning)))
+
+(defun tablist-find-entry (&optional id)
+ (interactive)
+ (unless (tablist-operation-available-p 'find-entry)
+ (error "Finding entries not supported in this buffer"))
+ (funcall tablist-operations-function
+ 'find-entry
+ (or id (tabulated-list-get-id))))
+
+;;
+;; *Utility
+;;
+
+(defun tablist-column-property (n prop)
+ (plist-get
+ (nthcdr 3 (aref tabulated-list-format n))
+ prop))
+
+(defun tablist-current-column ()
+ "Return the column number at point.
+
+Returns nil, if point is before the first column."
+ (let ((column
+ (1- (cl-position
+ (current-column)
+ (append (tablist-column-offsets)
+ (list most-positive-fixnum))
+ :test (lambda (column offset) (> offset column))))))
+ (when (>= column 0)
+ column)))
+
+(defun tablist-column-offsets ()
+ "Return a list of column positions.
+
+This is a list of offsets from the beginning of the line."
+ (let ((cc tabulated-list-padding)
+ columns)
+ (dotimes (i (length tabulated-list-format))
+ (let* ((c (aref tabulated-list-format i))
+ (len (nth 1 c))
+ (pad (or (plist-get (nthcdr 3 c) :pad-right)
+ 1)))
+ (push cc columns)
+ (when (numberp len)
+ (cl-incf cc len))
+ (when pad
+ (cl-incf cc pad))))
+ (nreverse columns)))
+
+(defun tablist-pretty-print-entry (item)
+ (mapconcat (lambda (i)
+ (tablist-nth-entry i item))
+ (tablist-major-columns) " "))
+
+(defun tablist--save-face-property (beg end)
+ ;; We need to distinguish ,,not set'' from ''no face''.
+ (unless (and (text-property-not-all beg end 'face nil)
+ (< beg end))
+ (put-text-property beg (1+ beg) 'face 'default))
+ (unless (text-property-not-all beg end 'tablist-saved-face nil)
+ (tablist-copy-text-property beg end 'face 'tablist-saved-face)))
+
+(defun tablist--restore-face-property (beg end)
+ (when (text-property-not-all beg end 'tablist-saved-face nil)
+ (tablist-copy-text-property beg end 'tablist-saved-face 'face)))
+
+(defun tablist-copy-text-property (beg end from to)
+ "Copy text property FROM to TO in region BEG to END."
+ (let ((inhibit-read-only t))
+ (save-excursion
+ (while (< beg end)
+ (goto-char beg)
+ (put-text-property
+ (point)
+ (setq beg (next-single-property-change
+ (point) from nil end))
+ to
+ (get-text-property (point) from))))))
+
+;;
+(defun tablist-read-column-name (arg &optional prompt default)
+ "Read the name of a column using ARG.
+
+If ARG is a number, return column ARG.
+If ARG is nil, return DEFAULT or the current column.
+Else ask the user, using PROMPT and DEFAULT."
+ (cond
+ ((numberp arg)
+ (or (tablist-column-name
+ (prefix-numeric-value arg))
+ (error "No such column: %d" (prefix-numeric-value arg))))
+ ((null arg)
+ (or default
+ (tablist-column-name
+ (or (tablist-current-column)
+ (car (tablist-major-columns))
+ 0))))
+ (t
+ (let* ((default (or default
+ (tablist-column-name
+ (car (tablist-major-columns)))))
+ (result
+ (completing-read
+ (format "%s %s: "
+ (or prompt "Use column")
+ (if default
+ (format "(default %s)"
+ default)
+ ""))
+ (tablist-column-names)
+ nil t nil 'tablist-column-name-history)))
+ (if (> (length result) 0)
+ result
+ (if (not default)
+ (error "No column selected")
+ default))))))
+
+(defun tablist-column-name (n)
+ "Return the name of column N."
+ (when (and n
+ (>= n 0)
+ (< n (length tabulated-list-format)))
+ (substring-no-properties
+ (car (elt tabulated-list-format n)) 0)))
+
+(defun tablist-column-names ()
+ "Return a list of all column-names."
+ (mapcar 'tablist-column-name
+ (number-sequence 0 (1- (length tabulated-list-format)))))
+
+(defun tablist-nth-entry (n &optional entry)
+ (unless entry (setq entry (tabulated-list-get-entry)))
+ (when (and entry
+ (>= n 0)
+ (< n (length entry)))
+ (let ((str (elt entry n)))
+ (if (stringp str)
+ str
+ (car str)))))
+
+(defun tablist-major-column-name ()
+ "Return a list of the major column names."
+ (tablist-column-name (car (tablist-major-columns))))
+
+(defun tablist-export-csv (&optional separator always-quote-p
+ invisible-p out-buffer display-p)
+ "Export a tabulated list to a CSV format.
+
+Use SEPARATOR (or ;) and quote if necessary (or always if
+ALWAYS-QUOTE-P is non-nil). Only consider non-filtered entries,
+unless invisible-p is non-nil. Create a buffer for the output or
+insert it after point in OUT-BUFFER. Finally if DISPLAY-P is
+non-nil, display this buffer.
+
+Return the output buffer."
+
+ (interactive (list nil t nil nil t))
+ (unless (derived-mode-p 'tabulated-list-mode)
+ (error "Not in Tabulated List Mode"))
+ (unless (stringp separator)
+ (setq separator (string (or separator ?\;))))
+ (let* ((outb (or out-buffer
+ (get-buffer-create
+ (format "%s.csv" (buffer-name)))))
+ (escape-re (format "[%s\"\n]" separator))
+ (header (tablist-column-names)))
+ (unless (buffer-live-p outb)
+ (error "Expected a live buffer: %s" outb))
+ (cl-labels
+ ((printit (entry)
+ (insert
+ (mapconcat
+ (lambda (e)
+ (unless (stringp e)
+ (setq e (car e)))
+ (if (or always-quote-p
+ (string-match escape-re e))
+ (concat "\""
+ (replace-regexp-in-string "\"" "\"\"" e t t)
+ "\"")
+ e))
+ entry separator))
+ (insert ?\n)))
+ (with-current-buffer outb
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (printit header)))
+ (save-excursion
+ (goto-char (point-min))
+ (unless invisible-p
+ (tablist-skip-invisible-entries))
+ (while (not (eobp))
+ (let* ((entry (tabulated-list-get-entry)))
+ (with-current-buffer outb
+ (let ((inhibit-read-only t))
+ (printit entry)))
+ (if invisible-p
+ (forward-line)
+ (tablist-forward-entry)))))
+ (if display-p
+ (display-buffer outb))
+ outb)))
+
+;;
+
+(defun tablist-enlarge-column (&optional column width)
+ "Enlarge column COLUMN by WIDTH.
+
+This function is lazy and therefore pretty slow."
+ (interactive
+ (list nil (* (prefix-numeric-value current-prefix-arg)
+ 3)))
+ (unless column (setq column (tablist-current-column)))
+ (unless column
+ (error "No column given and no entry at point"))
+ (unless width (setq width 1))
+ (when (or (not (numberp column))
+ (< column 0)
+ (>= column (length tabulated-list-format)))
+ (error "No such column: %d" column))
+ (when (= column (1- (length tabulated-list-format)))
+ (error "Can't resize last column"))
+
+ (let* ((cur-width (cadr (elt tabulated-list-format column))))
+ (setcar (cdr (elt tabulated-list-format column))
+ (max 3 (+ cur-width width)))
+ (tablist-with-remembering-entry
+ (tablist-save-marks
+ (tabulated-list-init-header)
+ (tabulated-list-print)))))
+
+(defun tablist-shrink-column (&optional column width)
+ (interactive
+ (list nil (* (prefix-numeric-value current-prefix-arg)
+ 3)))
+ (tablist-enlarge-column column (- (or width 1))))
+
+;; *Sorting
+;;
+
+(defun tablist-sort (&optional column)
+ "Sort the tabulated-list by COLUMN.
+
+COLUMN may be either a name or an index. The default compare
+function is given by the `tabulated-list-format', which see.
+
+This function saves the current sort column and the inverse
+sort-direction in the variable `tabulated-list-sort-key', which
+also determines the default COLUMN and direction.
+
+The main difference to `tabulated-list-sort' is, that this
+function sorts the buffer in-place and it ignores a nil sort
+entry in `tabulated-list-format' and sorts on the column
+anyway (why not ?)."
+
+ (interactive
+ (list
+ (if (null current-prefix-arg)
+ (tablist-column-name
+ (or (tablist-current-column)
+ (car (tablist-major-columns))
+ 0))
+ (tablist-read-column-name
+ '(4) "Sort by column"
+ (tablist-column-name (car (tablist-major-columns)))))))
+
+ (unless column
+ (setq column (or (car tabulated-list-sort-key)
+ (tablist-column-name (car (tablist-major-columns)))
+ (tablist-column-name 0))))
+ (when (numberp column)
+ (let ((column-name (tablist-column-name column)))
+ (unless column-name
+ (error "No such column: %d" column))
+ (setq column column-name)))
+
+ (setq tabulated-list-sort-key
+ (cons column
+ (if (equal column (car tabulated-list-sort-key))
+ (cdr tabulated-list-sort-key))))
+
+ (let* ((entries (if (functionp tabulated-list-entries)
+ (funcall tabulated-list-entries)
+ tabulated-list-entries))
+ (reverse (cdr tabulated-list-sort-key))
+ (n (tabulated-list--column-number ;;errors if column is n/a
+ (car tabulated-list-sort-key)))
+ (compare-fn (nth 2 (aref tabulated-list-format n))))
+
+ (when (or (null compare-fn)
+ (eq compare-fn t))
+ (setq compare-fn
+ (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))))))
+
+ (unless compare-fn
+ (error "This column cannot be sorted: %s" column))
+
+ (setcdr tabulated-list-sort-key (not reverse))
+ ;; Presort the entries and hash the result and sort the buffer.
+ (setq entries (sort (copy-sequence entries) compare-fn))
+ (let ((hash (make-hash-table :test 'equal)))
+ (dotimes (i (length entries))
+ (puthash (caar entries) i hash)
+ (setq entries (cdr entries)))
+ (tablist-with-remembering-entry
+ (goto-char (point-min))
+ (tablist-skip-invisible-entries)
+ (let ((inhibit-read-only t))
+ (sort-subr
+ nil 'tablist-forward-entry 'end-of-line
+ (lambda ()
+ (gethash (tabulated-list-get-id) hash 0))
+ nil (if reverse '< '>))))
+ (tablist-move-to-column n)
+ ;; Make the sort arrows display.
+ (tabulated-list-init-header))))
+
+;;
+;; *Filter
+;;
+
+(defun tablist-read-filter-name (prompt)
+ (let ((filter (cdr (assq major-mode tablist-named-filter))))
+ (unless filter
+ (error "No filter defined for %s mode" mode-name))
+ (let ((name (completing-read
+ (format "%s: " prompt)
+ filter
+ nil t)))
+ (unless (> (length name) 0)
+ (error "No filter selected"))
+ name)))
+
+(defun tablist-apply-filter (&optional filter)
+ "Apply FILTER to the current tabulated list.
+
+FILTER defaults to `tablist-current-filter'."
+ (unless filter (setq filter tablist-current-filter))
+ (tablist-filter-unhide-buffer)
+ (when (and filter
+ (null tablist-filter-suspended))
+ (tablist-with-remembering-entry
+ (tablist-map-with-filter
+ (lambda nil
+ (if tablist-umark-filtered-entries
+ (save-excursion (tablist-unmark-forward)))
+ (tablist-filter-hide-entry))
+ (tablist-filter-negate filter))))
+ (force-mode-line-update))
+
+(defadvice tabulated-list-print (after tabulated-list activate)
+ "Reapply the filter."
+ (when (or tablist-minor-mode
+ (derived-mode-p 'tablist-mode))
+ (tablist-apply-filter)))
+
+(defun tablist-eval-filter (filter)
+ (tablist-filter-eval
+ filter
+ (tabulated-list-get-id)
+ (tabulated-list-get-entry)
+ (cdr (assq major-mode tablist-named-filter))))
+
+(defun tablist-map-with-filter (fn filter &optional show-progress
+ distinguish-one-marked)
+ "Call FN for every unfiltered entry matching FILTER."
+ (prog1
+ (cl-labels ((search ()
+ (tablist-skip-invisible-entries)
+ (while (and (not (eobp))
+ (not (tablist-eval-filter filter)))
+ (tablist-forward-entry))
+ (unless (eobp)
+ (point-marker))))
+ (let (next-position results)
+ (save-excursion
+ (goto-char (point-min))
+ (setq next-position (search))
+ (while next-position
+ (goto-char next-position)
+ (if show-progress (sit-for 0))
+ (push (funcall fn) results)
+ ;; move after last match
+ (goto-char next-position)
+ (forward-line 1)
+ (set-marker next-position nil)
+ (setq next-position (search)))
+ (if (and distinguish-one-marked (= (length results) 1))
+ (setq results (cons t results))))))))
+
+;;
+;; **Filter Commands
+;;
+(defun tablist-push-filter (filter &optional interactive or-p)
+ (setq tablist-current-filter
+ (tablist-filter-push
+ tablist-current-filter
+ filter or-p))
+ (tablist-apply-filter)
+ (when interactive
+ (tablist-display-filter-temporarily)))
+
+(defun tablist-pop-filter (&optional n interactive)
+ "Remove the first N filter components."
+ (interactive (list (prefix-numeric-value current-prefix-arg) t))
+ (while (and tablist-current-filter
+ (> n 0))
+ (setq tablist-current-filter
+ (tablist-filter-pop
+ tablist-current-filter))
+ (cl-decf n))
+ (tablist-apply-filter)
+ (when interactive
+ (when (> n 0)
+ (message "The filter is empty."))
+ (tablist-display-filter-temporarily))
+ n)
+
+(defun tablist-negate-filter (&optional interactive)
+ "Negate the current filter."
+ (interactive (list t))
+ (setq tablist-current-filter
+ (tablist-filter-negate
+ tablist-current-filter))
+ (tablist-apply-filter)
+ (when interactive
+ (tablist-display-filter-temporarily)))
+
+(defun tablist-toggle-first-filter-logic ()
+ "Toggle between and/or for the first filter operand."
+ (interactive)
+ (setq tablist-current-filter
+ (pcase tablist-current-filter
+ (`(or ,x1 ,x2)
+ `(and ,x1 ,x2))
+ (`(and ,x1 ,x2)
+ `(or ,x1 ,x2))
+ (`(not ,x) x)
+ (x `(not ,x))))
+ (tablist-apply-filter)
+ (tablist-display-filter-temporarily))
+
+(defun tablist-suspend-filter (&optional flag)
+ "Temporarily disable filtering according to FLAG.
+
+Interactively, this command toggles filtering."
+ (interactive
+ (list (not tablist-filter-suspended)))
+ (let ((state tablist-filter-suspended))
+ (unless (eq (not (not state))
+ (not (not flag)))
+ (set (make-local-variable 'tablist-filter-suspended) flag)
+ (tablist-apply-filter))))
+
+(defun tablist-read-regexp-filter (operation arg)
+ (let ((column-name (tablist-read-column-name arg)))
+ (list
+ column-name
+ (let ((re
+ (read-regexp (format "%s where %s matches: " operation column-name))))
+ (unless (> (length re) 0)
+ (error "No regexp given"))
+ re))))
+
+(defun tablist-read-equal-filter (operation arg)
+ (let ((column-name (tablist-read-column-name arg)))
+ (list
+ column-name
+ (read-string (format "%s where %s equals: " operation column-name)))))
+
+(defun tablist-read-numeric-filter (operation arg)
+ (let* ((entry (tabulated-list-get-entry 1))
+ (default (cl-some
+ (lambda (idx)
+ (let ((value (tablist-nth-entry idx entry)))
+ (when (or (not (eq 0 (string-to-number value)))
+ (equal "0" value))
+ (tablist-column-name idx))))
+ (number-sequence 0 (length entry))))
+ (column-name (tablist-read-column-name arg nil default))
+ (op (completing-read
+ (format "%s %s matching binary op: " operation column-name)
+ '("=" "<" ">" "<=" ">=") nil t))
+ oper)
+
+ (when (equal "" op)
+ (error "No operation selected"))
+ (setq op (intern op))
+ (setq oper (number-to-string
+ (read-number
+ (format "%s where %s %s " operation column-name op))))
+
+ (list op column-name oper)))
+
+(defun tablist-push-regexp-filter (column-name regexp)
+ "Add a new filter matching REGEXP in COLUMN-NAME.
+
+The filter is and'ed with the current filter. Use
+`tablist-toggle-first-filter-logic' to change this."
+ (interactive
+ (tablist-with-filter-displayed
+ (tablist-read-regexp-filter "Filter" current-prefix-arg)))
+ (tablist-push-filter
+ `(=~ ,column-name ,regexp)
+ (called-interactively-p 'any)))
+
+(defun tablist-push-equal-filter (column-name string)
+ "Add a new filter whre string equals COLUMN-NAME's value.
+
+The filter is and'ed with the current filter. Use
+`tablist-toggle-first-filter-logic' to change this."
+ (interactive
+ (tablist-with-filter-displayed
+ (tablist-read-equal-filter "Filter" current-prefix-arg)))
+ (tablist-push-filter
+ `(== ,column-name ,string)
+ (called-interactively-p 'any)))
+
+(defun tablist-push-numeric-filter (op column-name 2nd-arg)
+ "Add a new filter matching a numeric predicate.
+
+The filter is and'ed with the current filter. Use
+`tablist-toggle-first-filter-logic' to change this."
+ (interactive
+ (tablist-with-filter-displayed
+ (tablist-read-numeric-filter "Filter" current-prefix-arg)))
+ (tablist-push-filter
+ `(,op ,column-name ,2nd-arg)
+ (called-interactively-p 'any)))
+
+(defun tablist-push-named-filter (name)
+ "Add a named filter called NAME.
+
+Named filter are saved in the variable `tablist-named-filter'."
+ (interactive
+ (tablist-with-filter-displayed
+ (list
+ (tablist-read-filter-name "Add filter"))))
+ (when (and name (symbolp name))
+ (setq name (symbol-name name)))
+ (tablist-push-filter name (called-interactively-p 'any)))
+
+(defun tablist-delete-named-filter (name &optional mode)
+ (interactive
+ (tablist-with-filter-displayed
+ (list
+ (tablist-read-filter-name "Delete filter"))))
+ (setq tablist-current-filter
+ (tablist-filter-map
+ (lambda (f)
+ (when (equal f name)
+ (setq f (tablist-get-named-filter f)))
+ f)
+ tablist-current-filter))
+ (unless mode (setq mode major-mode))
+ (let ((mode-filter
+ (assq mode tablist-named-filter)))
+ (when mode-filter
+ (setcdr mode-filter
+ (cl-remove name (cdr mode-filter)
+ :test 'equal :key 'car)))))
+
+(defun tablist-name-current-filter (name)
+ (interactive
+ (list (tablist-with-filter-displayed
+ (read-string
+ "Add name for current filter: "))))
+ (unless tablist-current-filter
+ (error "Filter is empty"))
+ (unless (> (length name) 0)
+ (error "No name given"))
+ (tablist-put-named-filter
+ name (if (stringp tablist-current-filter)
+ (tablist-get-named-filter
+ tablist-current-filter)
+ tablist-current-filter))
+ (setq tablist-current-filter name)
+ (force-mode-line-update))
+
+(defun tablist-deconstruct-named-filter ()
+ (interactive)
+ (let (found)
+ (setq tablist-current-filter
+ (tablist-filter-map
+ (lambda (f)
+ (when (and (not found)
+ (stringp f))
+ (setq found t)
+ (let ((df (tablist-get-named-filter f)))
+ (unless df
+ (error "Filter is not defined: %s" f))
+ (setq f df)))
+ f)
+ tablist-current-filter))
+ (unless found
+ (error "No named filter found"))
+ (force-mode-line-update)))
+
+(defun tablist-filter-names (&optional mode)
+ (mapcar 'car (cdr (assq (or mode major-mode)
+ tablist-named-filter))))
+
+(defun tablist-get-named-filter (name &optional mode)
+ (cdr (assoc name
+ (cdr (assq (or mode major-mode)
+ tablist-named-filter)))))
+
+(defun tablist-put-named-filter (name filter &optional mode)
+ (unless mode (setq mode major-mode))
+ (let ((mode-filter
+ (assq mode tablist-named-filter)))
+ (unless mode-filter
+ (setq mode-filter (cons mode nil))
+ (push mode-filter tablist-named-filter))
+ (let ((entry (assoc name mode-filter)))
+ (if entry
+ (setcdr entry filter)
+ (setcdr mode-filter
+ (list (cons name filter)))))))
+
+(defun tablist-validate-named-filter (filter)
+ (tablist-filter-map
+ (lambda (f)
+ (when (and (stringp f)
+ (null (tablist-get-named-filter f)))
+ (error "Undefined named filter: %s (defined: %s)" f
+ (mapconcat 'identity (tablist-filter-names) ","))))
+ filter))
+
+(defun tablist-edit-filter ()
+ (interactive)
+ (setq tablist-current-filter
+ (tablist-with-filter-displayed
+ (tablist-filter-edit-filter
+ "Edit filter: "
+ tablist-current-filter
+ nil
+ 'tablist-validate-named-filter)))
+ (tablist-apply-filter))
+
+(defun tablist-clear-filter ()
+ (interactive)
+ (setq tablist-current-filter nil)
+ (tablist-apply-filter))
+
+;; **Displaying filter
+;;
+
+(defconst tablist-display-filter-mode-line-tag nil)
+
+(defun tablist-display-filter (&optional flag)
+ "Display the current filter according to FLAG.
+
+If FLAG has the value 'toggle, toggle it's visibility.
+If FLAG has the 'state, then do nothing but return the current
+visibility."
+ (interactive (list 'toggle))
+ (let* ((tag 'tablist-display-filter-mode-line-tag)
+ (displayed-p (not (not (assq tag mode-line-format)))))
+ (if (eq flag 'state)
+ displayed-p
+ (let ((display-p (not (not (if (eq flag 'toggle)
+ (not displayed-p)
+ flag)))))
+ (unless (eq displayed-p display-p)
+ (setq mode-line-format
+ (if display-p
+ (list (cons tag mode-line-format)
+ '(:eval
+ (replace-regexp-in-string
+ "%" "%%"
+ (concat
+ (propertize "Filter: " 'face 'minibuffer-prompt)
+ (and tablist-filter-suspended
+ "[suspended] ")
+ (if tablist-current-filter
+ (tablist-filter-unparse
+ tablist-current-filter t)
+ "[none]")))))
+ (cdr (assq tag mode-line-format)))))
+ (force-mode-line-update)
+ display-p))))
+
+(defun tablist-display-filter-temporarily ()
+ (tablist-with-filter-displayed
+ (sit-for 9999)))
+
+;;
+;; **Hiding/Unhiding Entries
+;;
+(defun tablist-filter-set-entry-hidden (flag &optional pos)
+ (save-excursion
+ (when pos (goto-char pos))
+ (beginning-of-line)
+ (let ((inhibit-read-only t))
+ (add-text-properties
+ (point-at-bol)
+ (1+ (point-at-eol))
+ `(invisible ,flag)))))
+
+(defun tablist-filter-hide-entry (&optional pos)
+ (interactive)
+ (tablist-filter-set-entry-hidden t pos))
+
+(defun tablist-filter-unhide-entry (&optional pos)
+ (tablist-filter-set-entry-hidden nil pos))
+
+(defun tablist-filter-unhide-buffer ()
+ (let ((inhibit-read-only t))
+ (remove-text-properties
+ (point-min) (point-max)
+ '(invisible))))
+
+(defun tablist-window-attach (awindow &optional window)
+ "Attach AWINDOW to WINDOW.
+
+This has the following effect. Whenever WINDOW, defaulting to
+the selected window, stops displaying the buffer it currently
+displays (e.g., by switching buffers or because it was deleted)
+AWINDOW is deleted."
+ (unless window (setq window (selected-window)))
+ (let ((buffer (window-buffer window))
+ (hook (make-symbol "window-attach-hook")))
+ (fset hook
+ (lambda ()
+ (when (or (not (window-live-p window))
+ (not (eq buffer (window-buffer window))))
+ (remove-hook 'window-configuration-change-hook
+ hook)
+ ;; Deleting windows inside wcch may cause errors in
+ ;; windows.el .
+ (run-with-timer
+ 0 nil (lambda (win)
+ (when (and (window-live-p win)
+ (not (eq win (selected-window))))
+ (delete-window win)))
+ awindow))))
+ (add-hook 'window-configuration-change-hook hook)))
+
+(defun tablist-display-buffer-split-below-and-attach (buf alist)
+ "Display buffer action using `tablist-window-attach'."
+ (let ((window (selected-window))
+ (height (cdr (assq 'window-height alist)))
+ newwin)
+ (when height
+ (when (floatp height)
+ (setq height (round (* height (frame-height)))))
+ (setq height (- (max height window-min-height))))
+ (setq newwin (window--display-buffer
+ buf
+ (split-window-below height)
+ 'window alist))
+ (tablist-window-attach newwin window)
+ newwin))
+
+(defun tablist-generate-sorter (column compare-fn &optional read-fn)
+ "Generate a sort function for `tabulated-list' entries.
+
+Example:
+
+ \(tablist-generate-sorter 0 '< 'string-to-number\)
+
+would create a sort function sorting `tabulated-list-entries' on
+the 0-th column as numbers by the less-than relation."
+
+ (lambda (e1 e2)
+ (funcall compare-fn
+ (funcall (or read-fn 'identity)
+ (aref (cadr e1) column))
+ (funcall (or read-fn 'identity)
+ (aref (cadr e2) column)))))
+
+(provide 'tablist)
+;; Local Variables:
+;; outline-regexp: ";;\\(\\(?:[;*]+ \\| \\*+\\)[^\s\t\n]\\|###autoload\\)\\|("
+;; indent-tabs-mode: nil
+;; End:
+;;; tablist.el ends here
projects / emacsconfig.git / commitdiff