Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/wrolo-logic.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: wrolo-logic.el
4 ;; SUMMARY: Performs logical retrievals on rolodex files
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: hypermedia, matching
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Motorola Inc.
10 ;;
11 ;; ORIG-DATE: 13-Jun-89 at 22:57:33
12 ;; LAST-MOD: 14-Apr-95 at 16:27:43 by Bob Weiner
13 ;;
14 ;; This file is part of Hyperbole.
15 ;; Available for use and distribution under the same terms as GNU Emacs.
16 ;;
17 ;; Copyright (C) 1989-1995, Free Software Foundation, Inc.
18 ;; Developed with support from Motorola Inc.
19 ;;
20 ;; DESCRIPTION:
21 ;;
22 ;; INSTALLATION:
23 ;;
24 ;; See also wrolo.el. These functions are separated from wrolo.el since many
25 ;; users may never want or need them. They can be automatically loaded when
26 ;; desired by adding the following to one of your Emacs init files:
27 ;;
28 ;; (autoload 'rolo-logic "wrolo-logic" "Logical rolodex search filters." t)
29 ;;
30 ;; FEATURES:
31 ;;
32 ;; 1. One command, 'rolo-logic' which takes a logical search expression as
33 ;; an argument and displays any matching entries.
34 ;;
35 ;; 2. Logical 'and', 'or', 'not', and 'xor' rolodex entry retrieval filter
36 ;; functions. They take any number of string or boolean arguments and
37 ;; may be nested. NOTE THAT THESE FUNCTIONS SHOULD NEVER BE CALLED
38 ;; DIRECTLY UNLESS THE FREE VARIABLES 'start' and 'end' ARE BOUND
39 ;; BEFOREHAND.
40 ;;
41 ;; EXAMPLE:
42 ;;
43 ;; (rolo-logic (function
44 ;; (lambda ()
45 ;; (rolo-and
46 ;; (rolo-not "Tool-And-Die")
47 ;; "secretary"))))
48 ;;
49 ;; would find all non-Tool-And-Die Corp. secretaries in your rolodex.
50 ;;
51 ;; The logical matching routines are not at all optimal, but then most
52 ;; rolodex files are not terribly lengthy either.
53 ;;
54 ;; DESCRIP-END.
55
56 (require 'wrolo)
57
58 ;;;###autoload
59 (defun rolo-logic (func &optional in-bufs count-only include-sub-entries
60 no-sub-entries-out)
61 "Apply FUNC to all entries in optional IN-BUFS, display entries where FUNC is non-nil.
62 If IN-BUFS is nil, 'rolo-file-list' is used. If optional COUNT-ONLY is
63 non-nil, don't display entries, return count of matching entries only. If
64 optional INCLUDE-SUB-ENTRIES flag is non-nil, FUNC will be applied across all
65 sub-entries at once. Default is to apply FUNC to each entry and sub-entry
66 separately. Entries are displayed with all of their sub-entries unless
67 INCLUDE-SUB-ENTRIES is nil and optional NO-SUB-ENTRIES-OUT flag is non-nil.
68 FUNC should use the free variables 'start' and 'end' which contain the limits
69 of the region on which it should operate. Returns number of applications of
70 FUNC that return non-nil."
71 (interactive "xLogic function of no arguments, (lambda () (<function calls>): ")
72 (let ((obuf (current-buffer))
73 (display-buf (if count-only
74 nil
75 (prog1 (set-buffer (get-buffer-create rolo-display-buffer))
76 (setq buffer-read-only nil)
77 (erase-buffer)))))
78 (let ((result
79 (mapcar
80 (function
81 (lambda (in-bufs)
82 (rolo-map-logic func in-bufs count-only include-sub-entries
83 no-sub-entries-out)))
84 (cond ((null in-bufs) rolo-file-list)
85 ((listp in-bufs) in-bufs)
86 ((list in-bufs))))))
87 (let ((total-matches (apply '+ result)))
88 (if (or count-only (= total-matches 0))
89 nil
90 (pop-to-buffer display-buf)
91 (goto-char (point-min))
92 (set-buffer-modified-p nil)
93 (setq buffer-read-only t)
94 (let ((buf (get-buffer-window obuf)))
95 (if buf (select-window buf) (switch-to-buffer buf))))
96 (if (interactive-p)
97 (message (concat (if (= total-matches 0) "No" total-matches)
98 " matching entr"
99 (if (= total-matches 1) "y" "ies")
100 " found in rolodex.")))
101 total-matches))))
102
103 (defun rolo-map-logic (func rolo-buf &optional count-only
104 include-sub-entries no-sub-entries-out)
105 "Apply FUNC to all entries in ROLO-BUF, write to buffer entries where FUNC is non-nil.
106 If optional COUNT-ONLY is non-nil, don't display entries, return count of
107 matching entries only. If optional INCLUDE-SUB-ENTRIES flag is non-nil, FUNC
108 will be applied across all sub-entries at once. Default is to apply FUNC to
109 each entry and sub-entry separately. Entries are displayed with all of their
110 sub-entries unless INCLUDE-SUB-ENTRIES is nil and optional NO-SUB-ENTRIES-OUT
111 flag is non-nil. FUNC should use the free variables 'start' and 'end' which
112 contain the limits of the region on which it should operate. Returns number
113 of applications of FUNC that return non-nil."
114 (if (or (bufferp rolo-buf)
115 (if (file-exists-p rolo-buf)
116 (setq rolo-buf (find-file-noselect rolo-buf t))))
117 (let* ((display-buf (set-buffer (get-buffer-create rolo-display-buffer)))
118 (buffer-read-only))
119 (let ((hdr-pos) (num-found 0))
120 (set-buffer rolo-buf)
121 (goto-char (point-min))
122 (if (re-search-forward rolo-hdr-regexp nil t 2)
123 (progn (forward-line)
124 (setq hdr-pos (cons (point-min) (point)))))
125 (let* ((start)
126 (end)
127 (end-entry-hdr)
128 (curr-entry-level))
129 (while (re-search-forward rolo-entry-regexp nil t)
130 (setq start (save-excursion (beginning-of-line) (point))
131 next-entry-exists nil
132 end-entry-hdr (point)
133 curr-entry-level (buffer-substring start end-entry-hdr)
134 end (rolo-to-entry-end include-sub-entries curr-entry-level))
135 (let ((fun (funcall func)))
136 (or count-only
137 (and fun (= num-found 0) hdr-pos
138 (append-to-buffer display-buf
139 (car hdr-pos) (cdr hdr-pos))))
140 (if fun
141 (progn (goto-char end)
142 (setq num-found (1+ num-found)
143 end (if (or include-sub-entries
144 no-sub-entries-out)
145 end
146 (goto-char (rolo-to-entry-end
147 t curr-entry-level))))
148 (or count-only
149 (append-to-buffer display-buf start end)))
150 (goto-char end-entry-hdr)))))
151 (rolo-kill-buffer rolo-buf)
152 num-found))
153 0))
154
155
156 ;;
157 ;; INTERNAL FUNCTIONS.
158 ;;
159
160 ;; Do NOT call the following functions directly.
161 ;; Send them as parts of a lambda expression to 'rolo-logic'.
162
163 (defun rolo-not (&rest pat-list)
164 "Logical <not> rolodex entry filter. PAT-LIST is a list of pattern elements.
165 Each element may be t, nil, or a string."
166 (let ((pat))
167 (while (and pat-list
168 (or (not (setq pat (car pat-list)))
169 (and (not (eq pat t))
170 (goto-char start)
171 (not (search-forward pat end t)))))
172 (setq pat-list (cdr pat-list)))
173 (if pat-list nil t)))
174
175 (defun rolo-or (&rest pat-list)
176 "Logical <or> rolodex entry filter. PAT-LIST is a list of pattern elements.
177 Each element may be t, nil, or a string."
178 (if (memq t pat-list)
179 t
180 (let ((pat))
181 (while (and pat-list
182 (or (not (setq pat (car pat-list)))
183 (and (not (eq pat t))
184 (goto-char start)
185 (not (search-forward pat end t)))))
186 (setq pat-list (cdr pat-list)))
187 (if pat-list t nil))))
188
189 (defun rolo-xor (&rest pat-list)
190 "Logical <xor> rolodex entry filter. PAT-LIST is a list of pattern elements.
191 Each element may be t, nil, or a string."
192 (let ((pat)
193 (matches 0))
194 (while (and pat-list
195 (or (not (setq pat (car pat-list)))
196 (and (or (eq pat t)
197 (not (goto-char start))
198 (search-forward pat end t))
199 (setq matches (1+ matches)))
200 t)
201 (< matches 2))
202 (setq pat-list (cdr pat-list)))
203 (= matches 1)))
204
205 (defun rolo-and (&rest pat-list)
206 "Logical <and> rolodex entry filter. PAT-LIST is a list of pattern elements.
207 Each element may be t, nil, or a string."
208 (if (memq nil pat-list)
209 nil
210 (let ((pat))
211 (while (and pat-list
212 (setq pat (car pat-list))
213 (or (eq pat t)
214 (not (goto-char start))
215 (search-forward pat end t)))
216 (setq pat-list (cdr pat-list)))
217 (if pat-list nil t))))
218
219 ;; Work with regular expression patterns rather than strings
220
221 (defun rolo-r-not (&rest pat-list)
222 "Logical <not> rolodex entry filter. PAT-LIST is a list of pattern elements.
223 Each element may be t, nil, or a string."
224 (let ((pat))
225 (while (and pat-list
226 (or (not (setq pat (car pat-list)))
227 (and (not (eq pat t))
228 (goto-char start)
229 (not (re-search-forward pat end t)))))
230 (setq pat-list (cdr pat-list)))
231 (if pat-list nil t)))
232
233 (defun rolo-r-or (&rest pat-list)
234 "Logical <or> rolodex entry filter. PAT-LIST is a list of pattern elements.
235 Each element may be t, nil, or a string."
236 (if (memq t pat-list)
237 t
238 (let ((pat))
239 (while (and pat-list
240 (or (not (setq pat (car pat-list)))
241 (and (not (eq pat t))
242 (goto-char start)
243 (not (re-search-forward pat end t)))))
244 (setq pat-list (cdr pat-list)))
245 (if pat-list t nil))))
246
247 (defun rolo-r-xor (&rest pat-list)
248 "Logical <xor> rolodex entry filter. PAT-LIST is a list of pattern elements.
249 Each element may be t, nil, or a string."
250 (let ((pat)
251 (matches 0))
252 (while (and pat-list
253 (or (not (setq pat (car pat-list)))
254 (and (or (eq pat t)
255 (not (goto-char start))
256 (re-search-forward pat end t))
257 (setq matches (1+ matches)))
258 t)
259 (< matches 2))
260 (setq pat-list (cdr pat-list)))
261 (= matches 1)))
262
263 (defun rolo-r-and (&rest pat-list)
264 "Logical <and> rolodex entry filter. PAT-LIST is a list of pattern elements.
265 Each element may be t, nil, or a string."
266 (if (memq nil pat-list)
267 nil
268 (let ((pat))
269 (while (and pat-list
270 (setq pat (car pat-list))
271 (or (eq pat t)
272 (not (goto-char start))
273 (re-search-forward pat end t)))
274 (setq pat-list (cdr pat-list)))
275 (if pat-list nil t))))
276
277 (provide 'wrolo-logic)