diff options
Diffstat (limited to 'elpa/tablist-20200427.2205/tablist.el')
| -rw-r--r-- | elpa/tablist-20200427.2205/tablist.el | 1945 |
1 files changed, 0 insertions, 1945 deletions
diff --git a/elpa/tablist-20200427.2205/tablist.el b/elpa/tablist-20200427.2205/tablist.el deleted file mode 100644 index df8778b..0000000 --- a/elpa/tablist-20200427.2205/tablist.el +++ /dev/null @@ -1,1945 +0,0 @@ -;;; tablist.el --- Extended tabulated-list-mode -*- lexical-binding: t -*- - -;; Copyright (C) 2013, 2014 Andreas Politz - -;; Author: Andreas Politz <politza@fh-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-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 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 -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 - "" 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 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 |