* lisp/filesets.el: Use lexical-binding

Remove redundant `:group` args.  Require cl-lib and seq.
Fix various O(n²) bug and flag a few remaining ones.

(filesets-external-viewers): Simplify regexps.  Use \' instead of $.
Remove useless :constraint-flag properties.
(filesets-convert-path-list): η-reduce.
(filesets-eviewer-constraint-p): Mark :constraint-flag as obsolete.
(filesets-spawn-external-viewer): Can't use `run-hooks` on
lexical variable.
(filesets-filter-list): Fix O(n²) bug.
(filesets-ormap): Simplify.
(filesets-some, filesets-member, filesets-sublist): Make them
obsolete aliases.
(filesets-reset-fileset): Simplify.
(filesets-directory-files): Use `push`.
(filesets-spawn-external-viewer): Use `mapconcat` to fix O(n²) bug.
(filesets-cmd-get-args): Use `mapcan` to fix O(n²) bug.
(filesets-run-cmd): Use `mapconcat` and `mapcan` to fix O(n²) bugs.
(filesets-ingroup-collect-finder): Use dynamic scoping.
(filesets-ingroup-collect-files): Use `nreverse` to fix O(n²) bug.
(filesets-ingroup-collect-build-menu): Use `mapcan` to fix O(n²) bug.
This commit is contained in:
Stefan Monnier 2021-01-04 18:23:43 -05:00
parent 57e872ac75
commit 80e2647220

View file

@ -1,4 +1,4 @@
;;; filesets.el --- handle group of files
;;; filesets.el --- handle group of files -*- lexical-binding: t; -*-
;; Copyright (C) 2002-2021 Free Software Foundation, Inc.
@ -88,7 +88,8 @@
;;; Code:
(eval-when-compile (require 'cl-lib))
(require 'cl-lib)
(require 'seq)
(require 'easymenu)
;;; Some variables
@ -153,52 +154,25 @@ COND-FN takes one argument: the current element."
; (cl-remove 'dummy lst :test (lambda (dummy elt)
; (not (funcall cond-fn elt)))))
(let ((rv nil))
(dolist (elt lst rv)
(dolist (elt lst)
(when (funcall cond-fn elt)
(setq rv (append rv (list elt)))))))
(push elt rv)))
(nreverse rv)))
(defun filesets-ormap (fsom-pred lst)
"Return the tail of LST for the head of which FSOM-PRED is non-nil."
(let ((fsom-lst lst)
(fsom-rv nil))
(while (and (not (null fsom-lst))
(while (and fsom-lst
(null fsom-rv))
(if (funcall fsom-pred (car fsom-lst))
(setq fsom-rv fsom-lst)
(setq fsom-lst (cdr fsom-lst))))
fsom-rv))
(defun filesets-some (fss-pred fss-lst)
"Return non-nil if FSS-PRED is non-nil for any element of FSS-LST.
Like `some', return the first value of FSS-PRED that is non-nil."
(catch 'exit
(dolist (fss-this fss-lst nil)
(let ((fss-rv (funcall fss-pred fss-this)))
(when fss-rv
(throw 'exit fss-rv))))))
;(fset 'filesets-some 'cl-some) ;; or use the cl function
(defun filesets-member (fsm-item fsm-lst &rest fsm-keys)
"Find the first occurrence of FSM-ITEM in FSM-LST.
It is supposed to work like cl's `member*'. At the moment only the :test
key is supported."
(let ((fsm-test (or (plist-get fsm-keys ':test)
(function equal))))
(filesets-ormap (lambda (fsm-this)
(funcall fsm-test fsm-item fsm-this))
fsm-lst)))
;(fset 'filesets-member 'cl-member) ;; or use the cl function
(defun filesets-sublist (lst beg &optional end)
"Get the sublist of LST from BEG to END - 1."
(let ((rv nil)
(i beg)
(top (or end
(length lst))))
(while (< i top)
(setq rv (append rv (list (nth i lst))))
(setq i (+ i 1)))
rv))
(define-obsolete-function-alias 'filesets-some #'cl-some "28.1")
(define-obsolete-function-alias 'filesets-member #'cl-member "28.1")
(define-obsolete-function-alias 'filesets-sublist #'seq-subseq "28.1")
(defun filesets-select-command (cmd-list)
"Select one command from CMD-LIST -- a string with space separated names."
@ -222,7 +196,7 @@ key is supported."
(defun filesets-message (level &rest args)
"Show a message only if LEVEL is greater or equal then `filesets-verbosity'."
(when (<= level (abs filesets-verbosity))
(apply 'message args)))
(apply #'message args)))
;;; config file
@ -233,9 +207,9 @@ key is supported."
(defun filesets-reset-fileset (&optional fileset no-cache)
"Reset the cached values for one or all filesets."
(if fileset
(setq filesets-submenus (lax-plist-put filesets-submenus fileset nil))
(setq filesets-submenus nil))
(setq filesets-submenus (if fileset
(lax-plist-put filesets-submenus fileset nil)
nil))
(setq filesets-has-changed-flag t)
(setq filesets-update-cache-file-flag (or filesets-update-cache-file-flag
(not no-cache))))
@ -303,50 +277,46 @@ SYM to VAL and return t. If INIT-FLAG is non-nil, set with
(defcustom filesets-menu-name "Filesets"
"Filesets' menu name."
:set (function filesets-set-default)
:type 'string
:group 'filesets)
:set #'filesets-set-default
:type 'string)
(defcustom filesets-menu-path '("File") ; cf recentf-menu-path
"The menu under which the filesets menu should be inserted.
See `easy-menu-add-item' for documentation."
:set (function filesets-set-default)
:set #'filesets-set-default
:type '(choice (const :tag "Top Level" nil)
(sexp :tag "Menu Path"))
:version "23.1" ; was nil
:group 'filesets)
)
(defcustom filesets-menu-before "Open File..." ; cf recentf-menu-before
"The name of a menu before which this menu should be added.
See `easy-menu-add-item' for documentation."
:set (function filesets-set-default)
:set #'filesets-set-default
:type '(choice (string :tag "Name")
(const :tag "Last" nil))
:version "23.1" ; was "File"
:group 'filesets)
)
(defcustom filesets-menu-in-menu nil
"Use that instead of `current-menubar' as the menu to change.
See `easy-menu-add-item' for documentation."
:set (function filesets-set-default)
:type 'sexp
:group 'filesets)
:set #'filesets-set-default
:type 'sexp)
(defcustom filesets-menu-shortcuts-flag t
"Non-nil means to prepend menus with hopefully unique shortcuts."
:set (function filesets-set-default!)
:type 'boolean
:group 'filesets)
:set #'filesets-set-default!
:type 'boolean)
(defcustom filesets-menu-shortcuts-marker "%_"
"String for marking menu shortcuts."
:set (function filesets-set-default!)
:type 'string
:group 'filesets)
:set #'filesets-set-default!
:type 'string)
;;(defcustom filesets-menu-cnvfp-flag nil
;; "Non-nil means show \"Convert :pattern to :files\" entry for :pattern menus."
;; :set (function filesets-set-default!)
;; :set #'filesets-set-default!
;; :type 'boolean
;; :group 'filesets)
@ -355,9 +325,8 @@ See `easy-menu-add-item' for documentation."
"File to be used for saving the filesets menu between sessions.
Set this to \"\", to disable caching of menus.
Don't forget to check out `filesets-menu-ensure-use-cached'."
:set (function filesets-set-default)
:type 'file
:group 'filesets)
:set #'filesets-set-default
:type 'file)
(put 'filesets-menu-cache-file 'risky-local-variable t)
(defcustom filesets-menu-cache-contents
@ -383,7 +352,7 @@ If you want caching to work properly, at least `filesets-submenus',
list.
Don't forget to check out `filesets-menu-ensure-use-cached'."
:set (function filesets-set-default)
:set #'filesets-set-default
:type '(repeat
(choice :tag "Variable"
(const :tag "filesets-submenus"
@ -400,8 +369,7 @@ Don't forget to check out `filesets-menu-ensure-use-cached'."
:value filesets-ingroup-patterns)
(const :tag "filesets-be-docile-flag"
:value filesets-be-docile-flag)
(sexp :tag "Other" :value nil)))
:group 'filesets)
(sexp :tag "Other" :value nil))))
(define-obsolete-variable-alias 'filesets-cache-fill-content-hooks
'filesets-cache-fill-content-hook "24.3")
@ -423,48 +391,43 @@ configuration file, you can add a something like this
to this hook.
Don't forget to check out `filesets-menu-ensure-use-cached'."
:set (function filesets-set-default)
:type 'hook
:group 'filesets)
:set #'filesets-set-default
:type 'hook)
(defcustom filesets-cache-hostname-flag nil
"Non-nil means cache the hostname.
If the current name differs from the cached one,
rebuild the menu and create a new cache file."
:set (function filesets-set-default)
:type 'boolean
:group 'filesets)
:set #'filesets-set-default
:type 'boolean)
(defcustom filesets-cache-save-often-flag nil
"Non-nil means save buffer on every change of the filesets menu.
If this variable is set to nil and if Emacs crashes, the cache and
filesets-data could get out of sync. Set this to t if this happens from
time to time or if the fileset cache causes troubles."
:set (function filesets-set-default)
:type 'boolean
:group 'filesets)
:set #'filesets-set-default
:type 'boolean)
(defcustom filesets-max-submenu-length 25
"Maximum length of submenus.
Set this value to 0 to turn menu splitting off. BTW, parts of submenus
will not be rewrapped if their length exceeds this value."
:set (function filesets-set-default)
:type 'integer
:group 'filesets)
:set #'filesets-set-default
:type 'integer)
(defcustom filesets-max-entry-length 50
"Truncate names of split submenus to this length."
:set (function filesets-set-default)
:type 'integer
:group 'filesets)
:set #'filesets-set-default
:type 'integer)
(defcustom filesets-browse-dir-function 'dired
(defcustom filesets-browse-dir-function #'dired
"A function or command used for browsing directories.
When using an external command, \"%s\" will be replaced with the
directory's name.
Note: You have to manually rebuild the menu if you change this value."
:set (function filesets-set-default)
:set #'filesets-set-default
:type '(choice :tag "Function:"
(const :tag "dired"
:value dired)
@ -473,10 +436,9 @@ Note: You have to manually rebuild the menu if you change this value."
(string :tag "Name")
(string :tag "Arguments"))
(function :tag "Function"
:value nil))
:group 'filesets)
:value nil)))
(defcustom filesets-open-file-function 'filesets-find-or-display-file
(defcustom filesets-open-file-function #'filesets-find-or-display-file
"The function used for opening files.
`filesets-find-or-display-file' ... Filesets' default function for
@ -489,26 +451,24 @@ for a specific file type. Either this viewer, if defined, or
readable, will not be opened.
Caveat: Changes will take effect only after rebuilding the menu."
:set (function filesets-set-default)
:set #'filesets-set-default
:type '(choice :tag "Function:"
(const :tag "filesets-find-or-display-file"
:value filesets-find-or-display-file)
(const :tag "filesets-find-file"
:value filesets-find-file)
(function :tag "Function"
:value nil))
:group 'filesets)
:value nil)))
(defcustom filesets-save-buffer-function 'save-buffer
(defcustom filesets-save-buffer-function #'save-buffer
"The function used to save a buffer.
Caveat: Changes will take effect after rebuilding the menu."
:set (function filesets-set-default)
:set #'filesets-set-default
:type '(choice :tag "Function:"
(const :tag "save-buffer"
:value save-buffer)
(function :tag "Function"
:value nil))
:group 'filesets)
:value nil)))
(defcustom filesets-find-file-delay
(if (and (featurep 'xemacs) gutter-buffers-tab-visible-p)
@ -519,29 +479,25 @@ This is for calls via `filesets-find-or-display-file'
or `filesets-find-file'.
Set this to 0, if you don't use XEmacs's buffer tabs."
:set (function filesets-set-default)
:type 'number
:group 'filesets)
:set #'filesets-set-default
:type 'number)
(defcustom filesets-be-docile-flag nil
"Non-nil means don't complain if a file or a directory doesn't exist.
This is useful if you want to use the same startup files in different
computer environments."
:set (function filesets-set-default)
:type 'boolean
:group 'filesets)
:set #'filesets-set-default
:type 'boolean)
(defcustom filesets-sort-menu-flag t
"Non-nil means sort the filesets menu alphabetically."
:set (function filesets-set-default)
:type 'boolean
:group 'filesets)
:set #'filesets-set-default
:type 'boolean)
(defcustom filesets-sort-case-sensitive-flag t
"Non-nil means sorting of the filesets menu is case sensitive."
:set (function filesets-set-default)
:type 'boolean
:group 'filesets)
:set #'filesets-set-default
:type 'boolean)
(defcustom filesets-tree-max-level 3
"Maximum scan depth for directory trees.
@ -561,9 +517,8 @@ i.e. how deep the menu should be. Try something like
and it should become clear what this option is about. In any case,
including directory trees to the menu can take a lot of memory."
:set (function filesets-set-default)
:type 'integer
:group 'filesets)
:set #'filesets-set-default
:type 'integer)
(defcustom filesets-commands
'(("Isearch"
@ -590,7 +545,7 @@ function that returns one) to be run on a filesets' files.
The argument <file-name> or <<file-name>> (quoted) will be replaced with
the filename."
:set (function filesets-set-default+)
:set #'filesets-set-default+
:type '(repeat :tag "Commands"
(list :tag "Definition" :value ("")
(string "Name")
@ -606,8 +561,7 @@ the filename."
(string :tag "Quoted File Name"
:value "<<file-name>>")
(function :tag "Function"
:value nil)))))
:group 'filesets)
:value nil))))))
(put 'filesets-commands 'risky-local-variable t)
(defcustom filesets-external-viewers
@ -627,28 +581,33 @@ the filename."
(dvi-cmd "xdvi")
(doc-cmd "antiword")
(pic-cmd "gqview"))
`(("^.+\\..?html?$" browse-url
`((".\\..?html?\\'" browse-url
((:ignore-on-open-all t)))
("^.+\\.pdf$" ,pdf-cmd
(".\\.pdf\\'" ,pdf-cmd
((:ignore-on-open-all t)
(:ignore-on-read-text t)
(:constraint-flag ,pdf-cmd)))
("^.+\\.e?ps\\(.gz\\)?$" ,ps-cmd
;; (:constraintp ,pdf-cmd)
))
(".\\.e?ps\\(.gz\\)?\\'" ,ps-cmd
((:ignore-on-open-all t)
(:ignore-on-read-text t)
(:constraint-flag ,ps-cmd)))
("^.+\\.dvi$" ,dvi-cmd
;; (:constraintp ,ps-cmd)
))
(".\\.dvi\\'" ,dvi-cmd
((:ignore-on-open-all t)
(:ignore-on-read-text t)
(:constraint-flag ,dvi-cmd)))
("^.+\\.doc$" ,doc-cmd
;; (:constraintp ,dvi-cmd)
))
(".\\.doc\\'" ,doc-cmd
((:capture-output t)
(:ignore-on-read-text t)
(:constraint-flag ,doc-cmd)))
("^.+\\.\\(tiff\\|xpm\\|gif\\|pgn\\)$" ,pic-cmd
;; (:constraintp ,doc-cmd)
))
(".\\.\\(tiff\\|xpm\\|gif\\|pgn\\)\\'" ,pic-cmd
((:ignore-on-open-all t)
(:ignore-on-read-text t)
(:constraint-flag ,pic-cmd)))))
;; (:constraintp ,pic-cmd)
))))
"Association list of file patterns and external viewers for use with
`filesets-find-or-display-file'.
@ -665,10 +624,8 @@ i.e. on open-all-files-events or when running commands
:constraintp FUNCTION ... use this viewer only if FUNCTION returns non-nil
:constraint-flag SEXP ... use this viewer only if SEXP evaluates to non-nil
:open-hook HOOK ... run hooks after spawning the viewer -- mainly useful
in conjunction with :capture-output
:open-hook FUNCTIONs ... run FUNCTIONs after spawning the viewer -- mainly
useful in conjunction with :capture-output
:args (FORMAT-STRING or SYMBOL or FUNCTION) ... a list of arguments
\(defaults to (list \"%S\")) when using shell commands
@ -693,7 +650,7 @@ In order to view pdf or rtf files in an Emacs buffer, you could use these:
(:constraintp (lambda ()
(and (filesets-which-command-p \"rtf2htm\")
(filesets-which-command-p \"w3m\"))))))"
:set (function filesets-set-default)
:set #'filesets-set-default
:type '(repeat :tag "Viewer"
(list :tag "Definition"
:value ("^.+\\.suffix$" "")
@ -708,7 +665,7 @@ In order to view pdf or rtf files in an Emacs buffer, you could use these:
(const :format ""
:value :constraintp)
(function :tag "Function"))
(list :tag ":constraint-flag"
(list :tag ":constraint-flag (obsolete)"
:value (:constraint-flag)
(const :format ""
:value :constraint-flag)
@ -749,8 +706,7 @@ In order to view pdf or rtf files in an Emacs buffer, you could use these:
:value (:capture-output t)
(const :format ""
:value :capture-output)
(boolean :tag "Boolean"))))))
:group 'filesets)
(boolean :tag "Boolean")))))))
(put 'filesets-external-viewers 'risky-local-variable t)
(defcustom filesets-ingroup-patterns
@ -891,7 +847,7 @@ With duplicates removed, it would be:
M + A - X
B"
:set (function filesets-set-default)
:set #'filesets-set-default
:type '(repeat
:tag "Include"
(list
@ -937,8 +893,7 @@ With duplicates removed, it would be:
(list :tag ":preprocess"
:value (:preprocess)
(const :format "" :value :preprocess)
(function :tag "Function")))))))
:group 'filesets)
(function :tag "Function"))))))))
(put 'filesets-ingroup-patterns 'risky-local-variable t)
(defcustom filesets-data nil
@ -1009,8 +964,7 @@ is used.
Before using :ingroup, make sure that the file type is already
defined in `filesets-ingroup-patterns'."
:group 'filesets
:set (function filesets-data-set-default)
:set #'filesets-data-set-default
:type '(repeat
(cons :tag "Fileset"
(string :tag "Name" :value "")
@ -1072,9 +1026,8 @@ defined in `filesets-ingroup-patterns'."
(defcustom filesets-query-user-limit 15
"Query the user before opening a fileset with that many files."
:set (function filesets-set-default)
:type 'integer
:group 'filesets)
:set #'filesets-set-default
:type 'integer)
(defun filesets-filter-dir-names (lst &optional negative)
@ -1127,16 +1080,16 @@ Return full path if FULL-FLAG is non-nil."
(string-match-p pattern this))
(filesets-message 5 "Filesets: matched dir %S with pattern %S"
this pattern)
(setq dirs (cons this dirs))))
(push this dirs)))
(t
(when (or (not pattern)
(string-match-p pattern this))
(filesets-message 5 "Filesets: matched file %S with pattern %S"
this pattern)
(setq files (cons (if full-flag
(concat (file-name-as-directory dir) this)
this)
files))))))
(push (if full-flag
(concat (file-name-as-directory dir) this)
this)
files)))))
(cond
((equal what ':dirs)
(filesets-conditional-sort dirs))
@ -1193,7 +1146,7 @@ Return full path if FULL-FLAG is non-nil."
(defun filesets-convert-path-list (string)
"Return a path-list given as STRING as list."
(if string
(mapcar (lambda (x) (file-name-as-directory x))
(mapcar #'file-name-as-directory
(split-string string path-separator))
nil))
@ -1203,17 +1156,17 @@ Return full path if FULL-FLAG is non-nil."
filename)))
(if (file-exists-p f)
f
(filesets-some
(cl-some
(lambda (dir)
(let ((dir (file-name-as-directory dir))
(files (if (file-exists-p dir)
(filesets-directory-files dir nil ':files)
nil)))
(filesets-some (lambda (file)
(if (equal filename (file-name-nondirectory file))
(concat dir file)
nil))
files)))
(cl-some (lambda (file)
(if (equal filename (file-name-nondirectory file))
(concat dir file)
nil))
files)))
path-list))))
@ -1223,12 +1176,14 @@ Return full path if FULL-FLAG is non-nil."
(defun filesets-eviewer-constraint-p (entry)
(let* ((props (filesets-eviewer-get-props entry))
(constraint (assoc ':constraintp props))
(constraint-flag (assoc ':constraint-flag props)))
(constraint (assoc :constraintp props))
(constraint-flag (assoc :constraint-flag props)))
(cond
(constraint
(funcall (cadr constraint)))
(constraint-flag
(message "Obsolete :constraint-flag %S, use :constraintp instead"
(cadr constraint-flag))
(eval (cadr constraint-flag)))
(t
t))))
@ -1236,7 +1191,7 @@ Return full path if FULL-FLAG is non-nil."
(defun filesets-get-external-viewer (file)
"Find an external viewer for FILE."
(let ((filename (file-name-nondirectory file)))
(filesets-some
(cl-some
(lambda (entry)
(when (and (string-match-p (nth 0 entry) filename)
(filesets-eviewer-constraint-p entry))
@ -1246,7 +1201,7 @@ Return full path if FULL-FLAG is non-nil."
(defun filesets-get-external-viewer-by-name (name)
"Get the external viewer definition called NAME."
(when name
(filesets-some
(cl-some
(lambda (entry)
(when (and (string-equal (nth 1 entry) name)
(filesets-eviewer-constraint-p entry))
@ -1308,17 +1263,13 @@ Use the viewer defined in EV-ENTRY (a valid element of
(oh (filesets-filetype-get-prop ':open-hook file entry))
(args (let ((fmt (filesets-filetype-get-prop ':args file entry)))
(if fmt
(let ((rv ""))
(dolist (this fmt rv)
(setq rv (concat rv
(cond
((stringp this)
(format this file))
((and (symbolp this)
(fboundp this))
(format "%S" (funcall this)))
(t
(format "%S" this)))))))
(mapconcat
(lambda (this)
(if (stringp this) (format this file)
(format "%S" (if (functionp this)
(funcall this)
this))))
fmt "")
(format "%S" file))))
(output
(cond
@ -1338,13 +1289,15 @@ Use the viewer defined in EV-ENTRY (a valid element of
(insert output)
(setq-local filesets-output-buffer-flag t)
(set-visited-file-name file t)
(when oh
(run-hooks 'oh))
(if (functionp oh)
(funcall oh)
(mapc #'funcall oh))
(set-buffer-modified-p nil)
(setq buffer-read-only t)
(goto-char (point-min)))
(when oh
(run-hooks 'oh))))
(if (functionp oh)
(funcall oh)
(mapc #'funcall oh))))
(error "Filesets: general error when spawning external viewer"))))
(defun filesets-find-file (file)
@ -1355,7 +1308,8 @@ not be opened."
(when (or (file-readable-p file)
(not filesets-be-docile-flag))
(sit-for filesets-find-file-delay)
(find-file file)))
(with-suppressed-warnings ((interactive-only find-file))
(find-file file))))
(defun filesets-find-or-display-file (&optional file viewer)
"Visit FILE using an external VIEWER or open it in an Emacs buffer."
@ -1394,7 +1348,8 @@ not be opened."
(if (functionp filesets-browse-dir-function)
(funcall filesets-browse-dir-function dir)
(let ((name (car filesets-browse-dir-function))
(args (format (cadr filesets-browse-dir-function) (expand-file-name dir))))
(args (format (cadr filesets-browse-dir-function)
(expand-file-name dir))))
(with-temp-buffer
(start-process (concat "Filesets:" name)
"*Filesets external directory browser*"
@ -1445,7 +1400,7 @@ Return DEFAULT if not found. Return (car VALUE) if CARP is non-nil."
"Return fileset ENTRY's mode: :files, :file, :tree, :pattern, or :ingroup.
See `filesets-data'."
(let ((data (filesets-data-get-data entry)))
(filesets-some
(cl-some
(lambda (x)
(if (assoc x data)
x))
@ -1557,16 +1512,15 @@ SAVE-FUNCTION takes no argument, but works on the current buffer."
(assoc cmd-name filesets-commands))
(defun filesets-cmd-get-args (cmd-name)
(let ((args (let ((def (filesets-cmd-get-def cmd-name)))
(nth 2 def)))
(rv nil))
(dolist (this args rv)
(cond
((and (symbolp this) (fboundp this))
(let ((x (funcall this)))
(setq rv (append rv (if (listp x) x (list x))))))
(t
(setq rv (append rv (list this))))))))
(mapcan (lambda (this)
(cond
((and (symbolp this) (fboundp this))
(let ((x (funcall this)))
(if (listp x) x (list x))))
(t
(list this))))
(let ((def (filesets-cmd-get-def cmd-name)))
(nth 2 def))))
(defun filesets-cmd-get-fn (cmd-name)
(let ((def (filesets-cmd-get-def cmd-name)))
@ -1628,28 +1582,24 @@ Replace <file-name> or <<file-name>> with filename."
(cond
((stringp fn)
(let* ((args
(let ((txt ""))
(dolist (this args txt)
(setq txt
(concat txt
(if (equal txt "") "" " ")
(filesets-run-cmd--repl-fn
(mapconcat
(lambda (this)
(filesets-run-cmd--repl-fn
this
(lambda (this)
(format "%s" this))))))))
(format "%s" this))))
args
" "))
(cmd (concat fn " " args)))
(filesets-cmd-show-result
cmd (shell-command-to-string cmd))))
((symbolp fn)
(let ((args
(let ((argl nil))
(dolist (this args argl)
(setq argl
(append argl
(filesets-run-cmd--repl-fn
this
'list)))))))
(apply fn args)))))))))))))))))
(apply fn
(mapcan (lambda (this)
(filesets-run-cmd--repl-fn
this
'list))
args)))))))))))))))))
(defun filesets-get-cmd-menu ()
"Create filesets command menu."
@ -1832,8 +1782,8 @@ User will be queried, if no fileset name is provided."
(if entry
(let* ((files (filesets-entry-get-files entry))
(this (buffer-file-name buffer))
(inlist (filesets-member this files
:test 'filesets-files-equalp)))
(inlist (cl-member this files
:test #'filesets-files-equalp)))
(cond
(inlist
(message "Filesets: `%s' is already in `%s'" this name))
@ -1858,8 +1808,8 @@ User will be queried, if no fileset name is provided."
(if entry
(let* ((files (filesets-entry-get-files entry))
(this (buffer-file-name buffer))
(inlist (filesets-member this files
:test 'filesets-files-equalp)))
(inlist (cl-member this files
:test #'filesets-files-equalp)))
;;(message "%s %s %s" files this inlist)
(if (and files this inlist)
(let ((new (list (cons ':files (delete (car inlist) files)))))
@ -1908,7 +1858,7 @@ User will be queried, if no fileset name is provided."
(substring (elt submenu 0) 2))))
(if (listp submenu)
(cons name (cdr submenu))
(apply 'vector (list name (cadr (append submenu nil)))))))
(apply #'vector (list name (cadr (append submenu nil)))))))
; (vconcat `[,name] (subseq submenu 1)))))
(defun filesets-wrap-submenu (submenu-body)
@ -1926,12 +1876,14 @@ User will be queried, if no fileset name is provided."
((or (> count bl)
(null data)))
;; (let ((sl (subseq submenu-body count
(let ((sl (filesets-sublist submenu-body count
(let ((x (+ count factor)))
(if (>= bl x)
x
nil)))))
(let ((sl (seq-subseq submenu-body count
(let ((x (+ count factor)))
(if (>= bl x)
x
nil)))))
(when sl
;; FIXME: O(n²) performance bug because of repeated `append':
;; use `mapcan'?
(setq result
(append
result
@ -1948,6 +1900,8 @@ User will be queried, if no fileset name is provided."
(if (null (cdr x))
""
", "))))
;; FIXME: O(n²) performance bug because of
;; repeated `concat': use `mapconcat'?
(setq rv
(concat
rv
@ -2023,11 +1977,11 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings."
(and (stringp a)
(stringp b)
(string-match-p a b))))))
(filesets-some (lambda (x)
(if (funcall fn (car x) masterfile)
(nth pos x)
nil))
filesets-ingroup-patterns)))
(cl-some (lambda (x)
(if (funcall fn (car x) masterfile)
(nth pos x)
nil))
filesets-ingroup-patterns)))
(defun filesets-ingroup-get-pattern (master)
"Access to `filesets-ingroup-patterns'. Extract patterns."
@ -2039,12 +1993,8 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings."
(defun filesets-ingroup-collect-finder (patt case-sensitivep)
"Helper function for `filesets-ingroup-collect'. Find pattern PATT."
(let ((cfs case-fold-search)
(rv (progn
(setq case-fold-search (not case-sensitivep))
(re-search-forward patt nil t))))
(setq case-fold-search cfs)
rv))
(let ((case-fold-search (not case-sensitivep)))
(re-search-forward patt nil t)))
(defun filesets-ingroup-cache-get (master)
"Access to `filesets-ingroup-cache'."
@ -2102,9 +2052,9 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings."
(when (and f
(not (member f flist))
(or (not remdupl-flag)
(not (filesets-member
(not (cl-member
f filesets-ingroup-files
:test 'filesets-files-equalp))))
:test #'filesets-files-equalp))))
(let ((no-stub-flag
(and (not this-stub-flag)
(if this-stubp
@ -2116,16 +2066,18 @@ LOOKUP-NAME is used as lookup name for retrieving fileset specific settings."
(cons f filesets-ingroup-files))
(when no-stub-flag
(filesets-ingroup-cache-put master f))
(setq lst (append lst (list f))))))))
(push f lst))))))
(when lst
(setq rv
;; FIXME: O(n²) performance bug because of repeated
;; `nconc'.
(nconc rv
(mapcar (lambda (this)
`((,this ,this-name)
,@(filesets-ingroup-collect-files
fs remdupl-flag this
(- this-sd 1))))
lst))))))))
(nreverse lst)))))))))
(filesets-message 2 "Filesets: no patterns defined for %S" master)))))
(defun filesets-ingroup-collect-build-menu (fs flist &optional other-count)
@ -2135,42 +2087,41 @@ FS is a fileset's name. FLIST is a list returned by
(if (null flist)
nil
(let ((count 0)
(fsn fs)
(rv nil))
(dolist (this flist rv)
(setq count (+ count 1))
(let* ((def (if (listp this) (car this) (list this "")))
(files (if (listp this) (cdr this) nil))
(master (nth 0 def))
(name (nth 1 def))
(nm (concat (filesets-get-shortcut (if (or (not other-count) files)
count other-count))
(if (or (null name) (equal name ""))
""
(format "%s: " name))
(file-name-nondirectory master))))
(setq rv
(append rv
(if files
`((,nm
[,(concat "Inclusion Group: "
(file-name-nondirectory master))
(filesets-open ':ingroup ',master ',fsn)]
"---"
[,master (filesets-file-open nil ',master ',fsn)]
"---"
,@(let ((count 0))
(mapcar
(lambda (this)
(setq count (+ count 1))
(let ((ff (filesets-ingroup-collect-build-menu
fs (list this) count)))
(if (= (length ff) 1)
(car ff)
ff)))
files))
,@(filesets-get-menu-epilog master ':ingroup fsn)))
`([,nm (filesets-file-open nil ',master ',fsn)])))))))))
(fsn fs))
(mapcan (lambda (this)
(setq count (+ count 1))
(let* ((def (if (listp this) (car this) (list this "")))
(files (if (listp this) (cdr this) nil))
(master (nth 0 def))
(name (nth 1 def))
(nm (concat (filesets-get-shortcut
(if (or (not other-count) files)
count other-count))
(if (or (null name) (equal name ""))
""
(format "%s: " name))
(file-name-nondirectory master))))
(if files
`((,nm
[,(concat "Inclusion Group: "
(file-name-nondirectory master))
(filesets-open ':ingroup ',master ',fsn)]
"---"
[,master (filesets-file-open nil ',master ',fsn)]
"---"
,@(let ((count 0))
(mapcar
(lambda (this)
(setq count (+ count 1))
(let ((ff (filesets-ingroup-collect-build-menu
fs (list this) count)))
(if (= (length ff) 1)
(car ff)
ff)))
files))
,@(filesets-get-menu-epilog master ':ingroup fsn)))
`([,nm (filesets-file-open nil ',master ',fsn)]))))
flist))))
(defun filesets-ingroup-collect (fs remdupl-flag master)
"Collect names of included files and build submenu."
@ -2275,7 +2226,7 @@ Construct a shortcut from COUNT."
(:pattern
(let* ((files (filesets-get-filelist entry mode 'on-ls))
(dirpatt (filesets-entry-get-pattern entry))
(pattname (apply 'concat (cons "Pattern: " dirpatt)))
(pattname (apply #'concat (cons "Pattern: " dirpatt)))
(count 0))
;;(filesets-message 3 "Filesets: scanning %S" pattname)
`([,pattname
@ -2418,14 +2369,14 @@ fileset thinks this is necessary or not."
(dolist (this filesets-menu-cache-contents)
(if (get this 'custom-type)
(progn
(insert (format "(setq-default %s '%S)" this (eval this)))
(insert (format "(setq-default %s '%S)" this (eval this t)))
(when filesets-menu-ensure-use-cached
(newline)
(insert (format "(setq %s (cons '%s %s))"
'filesets-ignore-next-set-default
this
'filesets-ignore-next-set-default))))
(insert (format "(setq %s '%S)" this (eval this))))
(insert (format "(setq %s '%S)" this (eval this t))))
(newline 2))
(insert (format "(setq filesets-cache-version %S)" filesets-version))
(newline 2)
@ -2526,9 +2477,9 @@ We apologize for the inconvenience.")))
"Filesets initialization.
Set up hooks, load the cache file -- if existing -- and build the menu."
(add-hook 'menu-bar-update-hook #'filesets-build-menu-maybe)
(add-hook 'kill-buffer-hook (function filesets-remove-from-ubl))
(add-hook 'first-change-hook (function filesets-reset-filename-on-change))
(add-hook 'kill-emacs-hook (function filesets-exit))
(add-hook 'kill-buffer-hook #'filesets-remove-from-ubl)
(add-hook 'first-change-hook #'filesets-reset-filename-on-change)
(add-hook 'kill-emacs-hook #'filesets-exit)
(if (filesets-menu-cache-file-load)
(progn
(filesets-build-menu-maybe)
@ -2542,7 +2493,7 @@ Set up hooks, load the cache file -- if existing -- and build the menu."
(defun filesets-error (_class &rest args)
"`error' wrapper."
(declare (obsolete error "28.1"))
(error "%s" (mapconcat 'identity args " ")))
(error "%s" (mapconcat #'identity args " ")))
(provide 'filesets)