Mercurial > emacs

comparison lisp/filesets.el @ 45164:79ab9956f2a0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(filesets-external-viewers): Fix customization problem. (filesets-some): Replaces cl's `some'. Calls changed. (filesets-member): Replaces cl's `member*'. Calls changed. (filesets-ormap): New function.
author Richard M. Stallman <rms@gnu.org>
date Tue, 07 May 2002 16:11:20 +0000
parents c26266baaba5
children aa4f6ae8b6a9
comparison
equal deleted inserted replaced
45163:58815b772067 45164:79ab9956f2a0
19 19
20 ;; A copy of the GNU General Public License can be obtained from this 20 ;; A copy of the GNU General Public License can be obtained from this
21 ;; program's author or from the Free Software Foundation, Inc., 675 Mass 21 ;; program's author or from the Free Software Foundation, Inc., 675 Mass
22 ;; Ave, Cambridge, MA 02139, USA. 22 ;; Ave, Cambridge, MA 02139, USA.
23 23
24 (defvar filesets-version "1.8.1") 24 (defvar filesets-version "1.8.4")
25 (defvar filesets-homepage 25 (defvar filesets-homepage
26 "http://members.a1.net/t.link/CompEmacsFilesets.html") 26 "http://members.a1.net/t.link/CompEmacsFilesets.html")
27 27
28 ;;; Commentary: 28 ;;; Commentary:
29 29
148 ; (not (funcall cond-fn elt))))) 148 ; (not (funcall cond-fn elt)))))
149 (let ((rv nil)) 149 (let ((rv nil))
150 (dolist (elt lst rv) 150 (dolist (elt lst rv)
151 (when (funcall cond-fn elt) 151 (when (funcall cond-fn elt)
152 (setq rv (append rv (list elt))))))) 152 (setq rv (append rv (list elt)))))))
153
154 (defun filesets-ormap (fsom-pred lst)
155 "Return the the tail of FSOM-LST for the head of which FSOM-PRED is non-nil."
156 (let ((fsom-lst lst)
157 (fsom-rv nil))
158 (while (and (not (null fsom-lst))
159 (null fsom-rv))
160 (if (funcall fsom-pred (car fsom-lst))
161 (setq fsom-rv fsom-lst)
162 (setq fsom-lst (cdr fsom-lst))))
163 fsom-rv))
164
165 (defun filesets-some (fss-pred fss-lst)
166 "Return non-nil if FSS-PRED is non-nil for any element of FSS-LST.
167 Like `some', return the first value of FSS-PRED that is non-nil."
168 (catch 'exit
169 (dolist (fss-this fss-lst nil)
170 (let ((fss-rv (funcall fss-pred fss-this)))
171 (when fss-rv
172 (throw 'exit fss-rv))))))
173 ;(fset 'filesets-some 'some) ;; or use the cl function
174
175 (defun filesets-member (fsm-item fsm-lst &rest fsm-keys)
176 "Find the first occurrence of FSM-ITEM in FSM-LST.
177 It is supposed to work like cl's `member*'. At the moment only the :test
178 key is supported."
179 (let ((fsm-test (or (plist-get fsm-keys ':test)
180 (function equal))))
181 (filesets-ormap (lambda (fsm-this)
182 (funcall fsm-test fsm-item fsm-this))
183 fsm-lst)))
184 ;(fset 'filesets-member 'member*) ;; or use the cl function
153 185
154 (defun filesets-sublist (lst beg &optional end) 186 (defun filesets-sublist (lst beg &optional end)
155 "Get the sublist of LST from BEG to END - 1." 187 "Get the sublist of LST from BEG to END - 1."
156 (let ((rv nil) 188 (let ((rv nil)
157 (i beg) 189 (i beg)
609 641
610 :capture-output ... capture an external viewer output 642 :capture-output ... capture an external viewer output
611 643
612 :constraintp FUNCTION ... use this viewer only if FUNCTION returns non-nil 644 :constraintp FUNCTION ... use this viewer only if FUNCTION returns non-nil
613 645
614 :constraint-flag SYMBOL ... use this viewer only if SYMBOL is non-nil 646 :constraint-flag SEXP ... use this viewer only if SEXP evaluates to non-nil
615 647
616 :open-hook HOOK ... run hooks after spawning the viewer -- mainly useful 648 :open-hook HOOK ... run hooks after spawning the viewer -- mainly useful
617 in conjunction with :capture-output 649 in conjunction with :capture-output
618 650
619 :args (FORMAT-STRING or SYMBOL or FUNCTION) ... a list of arguments 651 :args (FORMAT-STRING or SYMBOL or FUNCTION) ... a list of arguments
657 (function :tag "Function")) 689 (function :tag "Function"))
658 (list :tag ":constraint-flag" 690 (list :tag ":constraint-flag"
659 :value (:constraint-flag) 691 :value (:constraint-flag)
660 (const :format "" 692 (const :format ""
661 :value :constraint-flag) 693 :value :constraint-flag)
662 (symbol :tag "Symbol")) 694 (sexp :tag "Symbol"))
663 (list :tag ":ignore-on-open-all" 695 (list :tag ":ignore-on-open-all"
664 :value (:ignore-on-open-all t) 696 :value (:ignore-on-open-all t)
665 (const :format "" 697 (const :format ""
666 :value :ignore-on-open-all) 698 :value :ignore-on-open-all)
667 (boolean :tag "Boolean")) 699 (boolean :tag "Boolean"))
1169 "Search for a FILENAME relative to a MASTER file in PATH-LIST." 1201 "Search for a FILENAME relative to a MASTER file in PATH-LIST."
1170 (let ((f (concat (file-name-directory master) 1202 (let ((f (concat (file-name-directory master)
1171 filename))) 1203 filename)))
1172 (if (file-exists-p f) 1204 (if (file-exists-p f)
1173 f 1205 f
1174 (some (lambda (dir) 1206 (filesets-some
1175 (let ((dir (file-name-as-directory dir)) 1207 (lambda (dir)
1176 (files (if (file-exists-p dir) 1208 (let ((dir (file-name-as-directory dir))
1177 (filesets-directory-files dir nil ':files) 1209 (files (if (file-exists-p dir)
1178 nil))) 1210 (filesets-directory-files dir nil ':files)
1179 (some (lambda (file) 1211 nil)))
1180 (if (equal filename (file-name-nondirectory file)) 1212 (filesets-some (lambda (file)
1181 (concat dir file) 1213 (if (equal filename (file-name-nondirectory file))
1182 nil)) 1214 (concat dir file)
1183 files))) 1215 nil))
1184 path-list)))) 1216 files)))
1217 path-list))))
1185 1218
1186 1219
1187 (defun filesets-eviewer-get-props (entry) 1220 (defun filesets-eviewer-get-props (entry)
1188 "Get ENTRY's (representing an external viewer) properties." 1221 "Get ENTRY's (representing an external viewer) properties."
1189 (nth 2 entry)) 1222 (nth 2 entry))
1201 t)))) 1234 t))))
1202 1235
1203 (defun filesets-get-external-viewer (file) 1236 (defun filesets-get-external-viewer (file)
1204 "Find an external viewer for FILE." 1237 "Find an external viewer for FILE."
1205 (let ((filename (file-name-nondirectory file))) 1238 (let ((filename (file-name-nondirectory file)))
1206 (some 1239 (filesets-some
1207 (lambda (entry) 1240 (lambda (entry)
1208 (when (and (string-match (nth 0 entry) filename) 1241 (when (and (string-match (nth 0 entry) filename)
1209 (filesets-eviewer-constraint-p entry)) 1242 (filesets-eviewer-constraint-p entry))
1210 entry)) 1243 entry))
1211 filesets-external-viewers))) 1244 filesets-external-viewers)))
1212 1245
1213 (defun filesets-get-external-viewer-by-name (name) 1246 (defun filesets-get-external-viewer-by-name (name)
1214 "Get the external viewer definition called NAME." 1247 "Get the external viewer definition called NAME."
1215 (when name 1248 (when name
1216 (some 1249 (filesets-some
1217 (lambda (entry) 1250 (lambda (entry)
1218 (when (and (string-equal (nth 1 entry) name) 1251 (when (and (string-equal (nth 1 entry) name)
1219 (filesets-eviewer-constraint-p entry)) 1252 (filesets-eviewer-constraint-p entry))
1220 entry)) 1253 entry))
1221 filesets-external-viewers))) 1254 filesets-external-viewers)))
1412 1445
1413 (defun filesets-entry-mode (entry) 1446 (defun filesets-entry-mode (entry)
1414 "Return fileset ENTRY's mode: :files, :file, :tree, :pattern, or :ingroup. 1447 "Return fileset ENTRY's mode: :files, :file, :tree, :pattern, or :ingroup.
1415 See `filesets-data'." 1448 See `filesets-data'."
1416 (let ((data (filesets-data-get-data entry))) 1449 (let ((data (filesets-data-get-data entry)))
1417 (some (lambda (x) 1450 (filesets-some
1418 (if (assoc x data) 1451 (lambda (x)
1419 x)) 1452 (if (assoc x data)
1420 '(:files :tree :pattern :ingroup :file)))) 1453 x))
1454 '(:files :tree :pattern :ingroup :file))))
1421 1455
1422 (defun filesets-entry-get-open-fn (fileset-name &optional fileset-entry) 1456 (defun filesets-entry-get-open-fn (fileset-name &optional fileset-entry)
1423 "Get the open-function for FILESET-NAME. 1457 "Get the open-function for FILESET-NAME.
1424 Use FILESET-ENTRY for finding the open function, if provided." 1458 Use FILESET-ENTRY for finding the open function, if provided."
1425 (filesets-data-get (or fileset-entry 1459 (filesets-data-get (or fileset-entry
1755 filesets-data nil t))) 1789 filesets-data nil t)))
1756 (entry (assoc name filesets-data))) 1790 (entry (assoc name filesets-data)))
1757 (if entry 1791 (if entry
1758 (let* ((files (filesets-entry-get-files entry)) 1792 (let* ((files (filesets-entry-get-files entry))
1759 (this (buffer-file-name buffer)) 1793 (this (buffer-file-name buffer))
1760 (inlist (member* this files :test 'filesets-files-equalp))) 1794 (inlist (filesets-member this files
1795 :test 'filesets-files-equalp)))
1761 (cond 1796 (cond
1762 (inlist 1797 (inlist
1763 (message "Filesets: '%s' is already in '%s'" this name)) 1798 (message "Filesets: '%s' is already in '%s'" this name))
1764 ((and (equal (filesets-entry-mode entry) ':files) 1799 ((and (equal (filesets-entry-mode entry) ':files)
1765 this) 1800 this)
1780 filesets-data nil t))) 1815 filesets-data nil t)))
1781 (entry (assoc name filesets-data))) 1816 (entry (assoc name filesets-data)))
1782 (if entry 1817 (if entry
1783 (let* ((files (filesets-entry-get-files entry)) 1818 (let* ((files (filesets-entry-get-files entry))
1784 (this (buffer-file-name buffer)) 1819 (this (buffer-file-name buffer))
1785 (inlist (member* this files :test 'filesets-files-equalp))) 1820 (inlist (filesets-member this files
1821 :test 'filesets-files-equalp)))
1786 ;;(message "%s %s %s" files this inlist) 1822 ;;(message "%s %s %s" files this inlist)
1787 (if (and files this inlist) 1823 (if (and files this inlist)
1788 (let ((new (list (cons ':files (delete (car inlist) files))))) 1824 (let ((new (list (cons ':files (delete (car inlist) files)))))
1789 (setcdr entry new) 1825 (setcdr entry new)
1790 (filesets-set-config name 'filesets-data filesets-data)) 1826 (filesets-set-config name 'filesets-data filesets-data))
1944 (let ((masterfile (file-name-nondirectory master)) 1980 (let ((masterfile (file-name-nondirectory master))
1945 (fn (or fun (lambda (a b) 1981 (fn (or fun (lambda (a b)
1946 (and (stringp a) 1982 (and (stringp a)
1947 (stringp b) 1983 (stringp b)
1948 (string-match a b)))))) 1984 (string-match a b))))))
1949 (some (lambda (x) 1985 (filesets-some (lambda (x)
1950 (if (funcall fn (car x) masterfile) 1986 (if (funcall fn (car x) masterfile)
1951 (nth pos x) 1987 (nth pos x)
1952 nil)) 1988 nil))
1953 filesets-ingroup-patterns))) 1989 filesets-ingroup-patterns)))
1954 1990
1955 (defun filesets-ingroup-get-pattern (master) 1991 (defun filesets-ingroup-get-pattern (master)
1956 "Access to `filesets-ingroup-patterns'. Extract patterns." 1992 "Access to `filesets-ingroup-patterns'. Extract patterns."
1957 (filesets-ingroup-get-data master 2)) 1993 (filesets-ingroup-get-data master 2))
1958 1994
2024 (let* ((txt (match-string this-mn)) 2060 (let* ((txt (match-string this-mn))
2025 (f (funcall this-fn master txt))) 2061 (f (funcall this-fn master txt)))
2026 (when (and f 2062 (when (and f
2027 (not (member f flist)) 2063 (not (member f flist))
2028 (or (not remdupl-flag) 2064 (or (not remdupl-flag)
2029 (not (member* 2065 (not (filesets-member
2030 f filesets-ingroup-files 2066 f filesets-ingroup-files
2031 :test 'filesets-files-equalp)))) 2067 :test 'filesets-files-equalp))))
2032 (let ((no-stub-flag 2068 (let ((no-stub-flag
2033 (and (not this-stub-flag) 2069 (and (not this-stub-flag)
2034 (if this-stubp 2070 (if this-stubp