21 |
;; program's author or from the Free Software Foundation, Inc., 675 Mass |
;; program's author or from the Free Software Foundation, Inc., 675 Mass |
22 |
;; Ave, Cambridge, MA 02139, USA. |
;; Ave, Cambridge, MA 02139, USA. |
23 |
|
|
24 |
(defvar filesets-version "1.8.1") |
(defvar filesets-version "1.8.4") |
25 |
(defvar filesets-homepage |
(defvar filesets-homepage |
26 |
"http://members.a1.net/t.link/CompEmacsFilesets.html") |
"http://members.a1.net/t.link/CompEmacsFilesets.html") |
27 |
|
|
151 |
(when (funcall cond-fn elt) |
(when (funcall cond-fn elt) |
152 |
(setq rv (append rv (list elt))))))) |
(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 |
185 |
|
|
186 |
(defun filesets-sublist (lst beg &optional end) |
(defun filesets-sublist (lst beg &optional end) |
187 |
"Get the sublist of LST from BEG to END - 1." |
"Get the sublist of LST from BEG to END - 1." |
188 |
(let ((rv nil) |
(let ((rv nil) |
643 |
|
|
644 |
:constraintp FUNCTION ... use this viewer only if FUNCTION returns non-nil |
:constraintp FUNCTION ... use this viewer only if FUNCTION returns non-nil |
645 |
|
|
646 |
:constraint-flag SYMBOL ... use this viewer only if SYMBOL is non-nil |
:constraint-flag SEXP ... use this viewer only if SEXP evaluates to non-nil |
647 |
|
|
648 |
:open-hook HOOK ... run hooks after spawning the viewer -- mainly useful |
:open-hook HOOK ... run hooks after spawning the viewer -- mainly useful |
649 |
in conjunction with :capture-output |
in conjunction with :capture-output |
691 |
:value (:constraint-flag) |
:value (:constraint-flag) |
692 |
(const :format "" |
(const :format "" |
693 |
:value :constraint-flag) |
:value :constraint-flag) |
694 |
(symbol :tag "Symbol")) |
(sexp :tag "Symbol")) |
695 |
(list :tag ":ignore-on-open-all" |
(list :tag ":ignore-on-open-all" |
696 |
:value (:ignore-on-open-all t) |
:value (:ignore-on-open-all t) |
697 |
(const :format "" |
(const :format "" |
1203 |
filename))) |
filename))) |
1204 |
(if (file-exists-p f) |
(if (file-exists-p f) |
1205 |
f |
f |
1206 |
(some (lambda (dir) |
(filesets-some |
1207 |
(let ((dir (file-name-as-directory dir)) |
(lambda (dir) |
1208 |
(files (if (file-exists-p dir) |
(let ((dir (file-name-as-directory dir)) |
1209 |
(filesets-directory-files dir nil ':files) |
(files (if (file-exists-p dir) |
1210 |
nil))) |
(filesets-directory-files dir nil ':files) |
1211 |
(some (lambda (file) |
nil))) |
1212 |
(if (equal filename (file-name-nondirectory file)) |
(filesets-some (lambda (file) |
1213 |
(concat dir file) |
(if (equal filename (file-name-nondirectory file)) |
1214 |
nil)) |
(concat dir file) |
1215 |
files))) |
nil)) |
1216 |
path-list)))) |
files))) |
1217 |
|
path-list)))) |
1218 |
|
|
1219 |
|
|
1220 |
(defun filesets-eviewer-get-props (entry) |
(defun filesets-eviewer-get-props (entry) |
1236 |
(defun filesets-get-external-viewer (file) |
(defun filesets-get-external-viewer (file) |
1237 |
"Find an external viewer for FILE." |
"Find an external viewer for FILE." |
1238 |
(let ((filename (file-name-nondirectory file))) |
(let ((filename (file-name-nondirectory file))) |
1239 |
(some |
(filesets-some |
1240 |
(lambda (entry) |
(lambda (entry) |
1241 |
(when (and (string-match (nth 0 entry) filename) |
(when (and (string-match (nth 0 entry) filename) |
1242 |
(filesets-eviewer-constraint-p entry)) |
(filesets-eviewer-constraint-p entry)) |
1246 |
(defun filesets-get-external-viewer-by-name (name) |
(defun filesets-get-external-viewer-by-name (name) |
1247 |
"Get the external viewer definition called NAME." |
"Get the external viewer definition called NAME." |
1248 |
(when name |
(when name |
1249 |
(some |
(filesets-some |
1250 |
(lambda (entry) |
(lambda (entry) |
1251 |
(when (and (string-equal (nth 1 entry) name) |
(when (and (string-equal (nth 1 entry) name) |
1252 |
(filesets-eviewer-constraint-p entry)) |
(filesets-eviewer-constraint-p entry)) |
1447 |
"Return fileset ENTRY's mode: :files, :file, :tree, :pattern, or :ingroup. |
"Return fileset ENTRY's mode: :files, :file, :tree, :pattern, or :ingroup. |
1448 |
See `filesets-data'." |
See `filesets-data'." |
1449 |
(let ((data (filesets-data-get-data entry))) |
(let ((data (filesets-data-get-data entry))) |
1450 |
(some (lambda (x) |
(filesets-some |
1451 |
(if (assoc x data) |
(lambda (x) |
1452 |
x)) |
(if (assoc x data) |
1453 |
'(:files :tree :pattern :ingroup :file)))) |
x)) |
1454 |
|
'(:files :tree :pattern :ingroup :file)))) |
1455 |
|
|
1456 |
(defun filesets-entry-get-open-fn (fileset-name &optional fileset-entry) |
(defun filesets-entry-get-open-fn (fileset-name &optional fileset-entry) |
1457 |
"Get the open-function for FILESET-NAME. |
"Get the open-function for FILESET-NAME. |
1791 |
(if entry |
(if entry |
1792 |
(let* ((files (filesets-entry-get-files entry)) |
(let* ((files (filesets-entry-get-files entry)) |
1793 |
(this (buffer-file-name buffer)) |
(this (buffer-file-name buffer)) |
1794 |
(inlist (member* this files :test 'filesets-files-equalp))) |
(inlist (filesets-member this files |
1795 |
|
:test 'filesets-files-equalp))) |
1796 |
(cond |
(cond |
1797 |
(inlist |
(inlist |
1798 |
(message "Filesets: '%s' is already in '%s'" this name)) |
(message "Filesets: '%s' is already in '%s'" this name)) |
1817 |
(if entry |
(if entry |
1818 |
(let* ((files (filesets-entry-get-files entry)) |
(let* ((files (filesets-entry-get-files entry)) |
1819 |
(this (buffer-file-name buffer)) |
(this (buffer-file-name buffer)) |
1820 |
(inlist (member* this files :test 'filesets-files-equalp))) |
(inlist (filesets-member this files |
1821 |
|
:test 'filesets-files-equalp))) |
1822 |
;;(message "%s %s %s" files this inlist) |
;;(message "%s %s %s" files this inlist) |
1823 |
(if (and files this inlist) |
(if (and files this inlist) |
1824 |
(let ((new (list (cons ':files (delete (car inlist) files))))) |
(let ((new (list (cons ':files (delete (car inlist) files))))) |
1982 |
(and (stringp a) |
(and (stringp a) |
1983 |
(stringp b) |
(stringp b) |
1984 |
(string-match a b)))))) |
(string-match a b)))))) |
1985 |
(some (lambda (x) |
(filesets-some (lambda (x) |
1986 |
(if (funcall fn (car x) masterfile) |
(if (funcall fn (car x) masterfile) |
1987 |
(nth pos x) |
(nth pos x) |
1988 |
nil)) |
nil)) |
1989 |
filesets-ingroup-patterns))) |
filesets-ingroup-patterns))) |
1990 |
|
|
1991 |
(defun filesets-ingroup-get-pattern (master) |
(defun filesets-ingroup-get-pattern (master) |
1992 |
"Access to `filesets-ingroup-patterns'. Extract patterns." |
"Access to `filesets-ingroup-patterns'. Extract patterns." |
2062 |
(when (and f |
(when (and f |
2063 |
(not (member f flist)) |
(not (member f flist)) |
2064 |
(or (not remdupl-flag) |
(or (not remdupl-flag) |
2065 |
(not (member* |
(not (filesets-member |
2066 |
f filesets-ingroup-files |
f filesets-ingroup-files |
2067 |
:test 'filesets-files-equalp)))) |
:test 'filesets-files-equalp)))) |
2068 |
(let ((no-stub-flag |
(let ((no-stub-flag |