1946 lines
65 KiB
EmacsLisp
1946 lines
65 KiB
EmacsLisp
;;; 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
|