Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hbdata.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: hbdata.el
4 ;; SUMMARY: Hyperbole button attribute accessor methods.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: hypermedia
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Brown U.
10 ;;
11 ;; ORIG-DATE: 2-Apr-91
12 ;; LAST-MOD: 14-Apr-95 at 15:59:49 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) 1991-1995, Free Software Foundation, Inc.
18 ;; Developed with support from Motorola Inc.
19 ;;
20 ;; DESCRIPTION:
21 ;;
22 ;; This module handles Hyperbole button data/attribute storage. In
23 ;; general, it should not be extended by anyone other than Hyperbole
24 ;; maintainers. If you alter the formats or accessors herein, you are
25 ;; likely to make your buttons incompatible with future releases.
26 ;; System developers should instead work with and extend the "hbut.el"
27 ;; module which provides much of the Hyperbole application programming
28 ;; interface and which hides the low level details handled by this
29 ;; module.
30 ;;
31 ;;
32 ;; Button data is typically stored within a file that holds the button
33 ;; data for all files within that directory. The name of this file is
34 ;; given by the variable 'hattr:filename,' usually it is ".hypb".
35 ;;
36 ;; Here is a sample from a Hyperbole V2 button data file. Each button
37 ;; data entry is a list of fields:
38 ;;
39 ;;
40 ;; "TO-DO"
41 ;; (Key Placeholders LinkType <arg-list> creator and modifier with times)
42 ;; ("alt.mouse.el" nil nil link-to-file ("./ell/alt-mouse.el") "zzz@cs.brown.edu" "19911027:09:19:26" "zzz" "19911027:09:31:36")
43 ;;
44 ;; which means: button \<(alt.mouse.el)> found in file "TO-DO" in the current
45 ;; directory provides a link to the local file "./ell/alt-mouse.el". It was
46 ;; created and last modified by zzz@cs.brown.edu.
47 ;;
48 ;; All link entries that originate from the same source file are stored
49 ;; contiguously, one per line, in reverse order of creation.
50 ;; Preceding all such entries is the source name (in the case of a file
51 ;; used as a source, no directory information is included, since only
52 ;; sources within the same directory as the button data file are used as
53 ;; source files within it.
54 ;;
55 ;; DESCRIP-END.
56
57 ;;; ************************************************************************
58 ;;; Other required Elisp libraries
59 ;;; ************************************************************************
60
61 (require 'hbmap)
62
63 ;;; ************************************************************************
64 ;;; Public functions
65 ;;; ************************************************************************
66
67 ;;; ------------------------------------------------------------------------
68 ;;; Button data accessor functions
69 ;;; ------------------------------------------------------------------------
70 (defun hbdata:action (hbdata)
71 "[Hyp V2] Returns action overriding button's action type or nil."
72 (nth 1 hbdata))
73
74 (defun hbdata:actype (hbdata)
75 "Returns the action type in HBDATA as a string."
76 (let ((nm (symbol-name (nth 3 hbdata))))
77 (and nm (if (or (= (length nm) 2) (string-match "::" nm))
78 nm (concat "actypes::" nm)))))
79
80 (defun hbdata:args (hbdata)
81 "Returns the list of any arguments given in HBDATA."
82 (nth 4 hbdata))
83
84 (defun hbdata:categ (hbdata)
85 "Returns the category of HBDATA's button."
86 'explicit)
87
88 (defun hbdata:creator (hbdata)
89 "Returns the user-id of the original creator of HBDATA's button."
90 (nth 5 hbdata))
91
92 (defun hbdata:create-time (hbdata)
93 "Returns the original creation time given for HBDATA's button."
94 (nth 6 hbdata))
95
96 (defun hbdata:key (hbdata)
97 "Returns the indexing key in HBDATA as a string."
98 (car hbdata))
99
100 (defun hbdata:loc-p (hbdata)
101 "[Hyp V1] Returns 'L iff HBDATA referent is within a local file system.
102 Returns 'R if remote and nil if irrelevant for button action type."
103 (nth 1 hbdata))
104
105 (defun hbdata:modifier (hbdata)
106 "Returns the user-id of the most recent modifier of HBDATA's button.
107 Nil is returned when button has not been modified."
108 (nth 7 hbdata))
109
110 (defun hbdata:mod-time (hbdata)
111 "Returns the time of the most recent change to HBDATA's button.
112 Nil is returned when button has not beened modified."
113 (nth 8 hbdata))
114
115 (defun hbdata:referent (hbdata)
116 "Returns the referent name in HBDATA."
117 (nth 2 hbdata))
118
119 (defun hbdata:search (buf label partial)
120 "Go to Hyperbole hbdata BUF and find LABEL whole or PARTIAL matches.
121 Search is case-insensitive. Returns list with elements:
122 (<button-src> <label-key1> ... <label-keyN>)."
123 (set-buffer buf)
124 (let ((case-fold-search t) (src-matches) (src) (matches) (end))
125 (goto-char (point-min))
126 (while (re-search-forward "^\^L\n\"\\([^\"]+\\)\"" nil t)
127 (setq src (buffer-substring (match-beginning 1)
128 (match-end 1))
129 matches nil)
130 (save-excursion
131 (setq end (if (re-search-forward "^\^L" nil t)
132 (1- (point)) (point-max))))
133 (while (re-search-forward
134 (concat "^(\"\\(" (if partial "[^\"]*")
135 (regexp-quote (ebut:label-to-key label))
136 (if partial "[^\"]*") "\\)\"") nil t)
137 (setq matches (cons
138 (buffer-substring (match-beginning 1)
139 (match-end 1))
140 matches)))
141 (if matches
142 (setq src-matches (cons (cons src matches) src-matches)))
143 (goto-char end))
144 src-matches))
145
146 ;;; ------------------------------------------------------------------------
147 ;;; Button data operators
148 ;;; ------------------------------------------------------------------------
149
150 (defun hbdata:build (&optional mod-lbl-key but-sym)
151 "Tries to construct button data from optional MOD-LBL-KEY and BUT-SYM.
152 MOD-LBL-KEY nil means create a new entry, otherwise modify existing one.
153 BUT-SYM nil means use 'hbut:current'. If successful, returns a cons of
154 (button-data . button-instance-str), else nil."
155 (let* ((but)
156 (b (hattr:copy (or but-sym 'hbut:current) 'but))
157 (l (hattr:get b 'loc))
158 (key (or mod-lbl-key (hattr:get b 'lbl-key)))
159 (new-key (if mod-lbl-key (hattr:get b 'lbl-key) key))
160 (lbl-instance) (creator) (create-time) (modifier) (mod-time)
161 (entry) loc dir)
162 (if (null l)
163 nil
164 (setq loc (if (bufferp l) l (file-name-nondirectory l))
165 dir (if (bufferp l) nil (file-name-directory l)))
166 (if (setq entry (hbdata:to-entry key loc dir (not mod-lbl-key)))
167 (if mod-lbl-key
168 (progn
169 (setq creator (hbdata:creator entry)
170 create-time (hbdata:create-time entry)
171 modifier (let* ((user (user-login-name))
172 (addr (concat user
173 hyperb:host-domain)))
174 (if (equal creator addr)
175 user addr))
176 mod-time (htz:date-sortable-gmt)
177 entry (cons new-key (cdr entry)))
178 (hbdata:delete-entry-at-point)
179 (if (setq lbl-instance (hbdata:instance-last new-key loc dir))
180 (progn
181 (setq lbl-instance (concat ebut:instance-sep
182 (1+ lbl-instance)))
183 ;; This line is needed to ensure that the highest
184 ;; numbered instance of a label appears before
185 ;; other instances, so 'hbdata:instance-last' will work.
186 (if (hbdata:to-entry-buf loc dir) (forward-line 1))))
187 )
188 (let ((inst-num (hbdata:instance-last new-key loc dir)))
189 (setq lbl-instance (if inst-num
190 (hbdata:instance-next
191 (concat new-key ebut:instance-sep
192 (int-to-string inst-num))))))
193 ))
194 (if (or entry (not mod-lbl-key))
195 (cons
196 (list (concat new-key lbl-instance)
197 (hattr:get b 'action)
198 ;; Hyperbole V1 referent compatibility, always nil in V2
199 (hattr:get b 'referent)
200 ;; Save actype without class prefix
201 (let ((actype (hattr:get b 'actype)))
202 (and actype (symbolp actype)
203 (setq actype (symbol-name actype))
204 (intern
205 (substring actype (if (string-match "::" actype)
206 (match-end 0) 0)))))
207 (let ((mail-dir (and (fboundp 'hmail:composing-dir)
208 (hmail:composing-dir l)))
209 (args (hattr:get b 'args)))
210 ;; Replace matches for Emacs Lisp directory variable
211 ;; values with their variable names in any pathname args.
212 (mapcar 'hpath:substitute-var
213 (if mail-dir
214 ;; Make pathname args absolute for outgoing mail and
215 ;; news messages.
216 (action:path-args-abs args mail-dir)
217 args)))
218 (or creator (concat (user-login-name) hyperb:host-domain))
219 (or create-time (htz:date-sortable-gmt))
220 modifier
221 mod-time)
222 lbl-instance)
223 ))))
224
225 (defun hbdata:get-entry (lbl-key key-src &optional directory)
226 "Returns button data entry given by LBL-KEY, KEY-SRC and optional DIRECTORY.
227 Returns nil if no matching entry is found.
228 A button data entry is a list of attribute values. Use methods from
229 class 'hbdata' to operate on the entry."
230 (hbdata:apply-entry
231 (function (lambda () (read (current-buffer))))
232 lbl-key key-src directory))
233
234 (defun hbdata:instance-next (lbl-key)
235 "Returns string for button instance number following LBL-KEY's.
236 nil if LBL-KEY is nil."
237 (and lbl-key
238 (if (string-match
239 (concat (regexp-quote ebut:instance-sep) "[0-9]+$") lbl-key)
240 (concat ebut:instance-sep
241 (int-to-string
242 (1+ (string-to-int
243 (substring lbl-key (1+ (match-beginning 0)))))))
244 ":2")))
245
246 (defun hbdata:instance-last (lbl-key key-src &optional directory)
247 "Returns highest instance number for repeated button label.
248 1 if not repeated, nil if no instance.
249 Takes arguments LBL-KEY, KEY-SRC and optional DIRECTORY."
250 (hbdata:apply-entry
251 (function (lambda ()
252 (if (looking-at "[0-9]+")
253 (string-to-int (buffer-substring (match-beginning 0)
254 (match-end 0)))
255 1)))
256 lbl-key key-src directory nil 'instance))
257
258 (defun hbdata:delete-entry (lbl-key key-src &optional directory)
259 "Deletes button data entry given by LBL-KEY, KEY-SRC and optional DIRECTORY.
260 Returns entry deleted (a list of attribute values) or nil.
261 Use methods from class 'hbdata' to operate on the entry."
262 (hbdata:apply-entry
263 (function
264 (lambda ()
265 (prog1 (read (current-buffer))
266 (let ((empty-file-entry "[ \t\n]*\\(\^L\\|\\'\\)")
267 (kill))
268 (beginning-of-line)
269 (hbdata:delete-entry-at-point)
270 (if (looking-at empty-file-entry)
271 (let ((end (point))
272 (empty-hbdata-file "[ \t\n]*\\'"))
273 (forward-line -1)
274 (if (= (following-char) ?\")
275 ;; Last button entry for filename, so del filename.
276 (progn (forward-line -1) (delete-region (point) end)))
277 (save-excursion
278 (goto-char (point-min))
279 (if (looking-at empty-hbdata-file)
280 (setq kill t)))
281 (if kill
282 (let ((fname buffer-file-name))
283 (erase-buffer) (save-buffer) (kill-buffer nil)
284 (hbmap:dir-remove (file-name-directory fname))
285 (call-process "rm" nil 0 nil "-f" fname)))))))))
286 lbl-key key-src directory))
287
288 (defun hbdata:delete-entry-at-point ()
289 (delete-region (point) (progn (forward-line 1) (point))))
290
291 (defun hbdata:to-entry (but-key key-src &optional directory instance)
292 "Returns button data entry indexed by BUT-KEY, KEY-SRC, optional DIRECTORY.
293 Returns nil if entry is not found. Leaves point at start of entry when
294 successful or where entry should be inserted if unsuccessful.
295 A button entry is a list. Use methods from class 'hbdata' to operate on the
296 entry. Optional INSTANCE non-nil means search for any button instance matching
297 but-key."
298 (let ((pos-entry-cons
299 (hbdata:apply-entry
300 (function
301 (lambda ()
302 (beginning-of-line)
303 (cons (point) (read (current-buffer)))))
304 but-key key-src directory 'create instance)))
305 (hbdata:to-entry-buf key-src directory)
306 (forward-line 1)
307 (if pos-entry-cons
308 (progn
309 (goto-char (car pos-entry-cons))
310 (cdr pos-entry-cons)))))
311
312 ;;; ************************************************************************
313 ;;; Private functions
314 ;;; ************************************************************************
315
316 (defun hbdata:apply-entry (function lbl-key key-src &optional directory
317 create instance)
318 "Invokes FUNCTION with point at hbdata entry given by LBL-KEY, KEY-SRC, optional DIRECTORY.
319 With optional CREATE, if no such line exists, inserts a new file entry at the
320 beginning of the hbdata file (which is created if necessary).
321 INSTANCE non-nil means search for any button instance matching LBL-KEY and
322 call FUNCTION with point right after any 'ebut:instance-sep' in match.
323 Returns value of evaluation when a matching entry is found or nil."
324 (let ((found)
325 (rtn)
326 (opoint)
327 (end-func))
328 (save-excursion
329 (unwind-protect
330 (progn
331 (if (not (bufferp key-src))
332 nil
333 (set-buffer key-src)
334 (cond ((hmail:editor-p)
335 (setq end-func (function (lambda ()
336 (hmail:msg-narrow)))))
337 ((and (hmail:lister-p)
338 (progn (rmail:summ-msg-to) (rmail:to)))
339 (setq opoint (point)
340 key-src (current-buffer)
341 end-func (function (lambda ()
342 (hmail:msg-narrow)
343 (goto-char opoint)
344 (lmail:to)))))
345 ((and (hnews:lister-p)
346 (progn (rnews:summ-msg-to) (rnews:to)))
347 (setq opoint (point)
348 key-src (current-buffer)
349 end-func (function (lambda ()
350 (hmail:msg-narrow)
351 (goto-char opoint)
352 (lnews:to)))))))
353 (setq found (hbdata:to-entry-buf key-src directory create)))
354 (if found
355 (let ((case-fold-search t)
356 (qkey (regexp-quote lbl-key))
357 (end (save-excursion (if (search-forward "\n\^L" nil t)
358 (point) (point-max)))))
359 (if (if instance
360 (re-search-forward
361 (concat "\n(\"" qkey "["
362 ebut:instance-sep "\"]") end t)
363 (search-forward (concat "\n(\"" lbl-key "\"") end t))
364 (progn
365 (or instance (beginning-of-line))
366 (let (buffer-read-only)
367 (setq rtn (funcall function)))))))
368 (if end-func (funcall end-func))))
369 rtn))
370
371 (defun hbdata:to-hbdata-buffer (dir &optional create)
372 "Reads in the file containing DIR's button data, if any, and returns buffer.
373 If it does not exist and optional CREATE is non-nil, creates a new
374 one and returns buffer, otherwise returns nil."
375 (let* ((file (expand-file-name hattr:filename (or dir default-directory)))
376 (existing-file (or (file-exists-p file) (get-file-buffer file)))
377 (buf (or (get-file-buffer file)
378 (and (or create existing-file)
379 (find-file-noselect file)))))
380 (if buf
381 (progn (set-buffer buf)
382 (or (verify-visited-file-modtime (get-file-buffer file))
383 (cond ((yes-or-no-p
384 "Hyperbole button data file has changed, read new contents? ")
385 (revert-buffer t t)
386 )))
387 (or (= (point-max) 1) (eq (char-after 1) ?\^L)
388 (error "File %s is not a valid Hyperbole button data table." file))
389 (or (equal (buffer-name) file) (rename-buffer file))
390 (setq buffer-read-only nil)
391 (or existing-file (hbmap:dir-add (file-name-directory file)))
392 buf))))
393
394
395 (defun hbdata:to-entry-buf (key-src &optional directory create)
396 "Moves point to end of line in but data buffer matching KEY-SRC.
397 Uses hbdata file in KEY-SRC's directory, or optional DIRECTORY or if nil, uses
398 default-directory.
399 With optional CREATE, if no such line exists, inserts a new file entry at the
400 beginning of the hbdata file (which is created if necessary).
401 Returns non-nil if KEY-SRC is found or created, else nil."
402 (let ((rtn) (ln-dir))
403 (if (bufferp key-src)
404 ;; Button buffer has no file attached
405 (progn (setq rtn (set-buffer key-src)
406 buffer-read-only nil)
407 (if (not (hmail:hbdata-to-p))
408 (insert "\n" hmail:hbdata-sep "\n"))
409 (backward-char 1)
410 )
411 (setq directory (or (file-name-directory key-src) directory))
412 (let ((ln-file) (link-p key-src))
413 (while (setq link-p (file-symlink-p link-p))
414 (setq ln-file link-p))
415 (if ln-file
416 (setq ln-dir (file-name-directory ln-file)
417 key-src (file-name-nondirectory ln-file))
418 (setq key-src (file-name-nondirectory key-src))))
419 (if (or (hbdata:to-hbdata-buffer directory create)
420 (and ln-dir (hbdata:to-hbdata-buffer ln-dir nil)
421 (setq create nil
422 directory ln-dir)))
423 (progn
424 (goto-char 1)
425 (cond ((search-forward (concat "\^L\n\"" key-src "\"")
426 nil t)
427 (setq rtn t))
428 (create
429 (setq rtn t)
430 (insert "\^L\n\"" key-src "\"\n")
431 (backward-char 1))
432 ))))
433 rtn
434 ))
435
436 (defun hbdata:write (&optional orig-lbl-key but-sym)
437 "Tries to write Hyperbole button data from optional ORIG-LBL-KEY and BUT-SYM.
438 ORIG-LBL-KEY nil means create a new entry, otherwise modify existing one.
439 BUT-SYM nil means use 'hbut:current'. If successful, returns
440 a button instance string to append to button label or t when first instance.
441 On failure, returns nil."
442 (let ((cns (hbdata:build orig-lbl-key but-sym))
443 entry lbl-instance)
444 (if (or (and buffer-file-name
445 (not (file-writable-p buffer-file-name)))
446 (null cns))
447 nil
448 (setq entry (car cns) lbl-instance (cdr cns))
449 (prin1 entry (current-buffer))
450 (terpri (current-buffer))
451 (or lbl-instance t)
452 )))
453
454
455 ;;; ************************************************************************
456 ;;; Private variables
457 ;;; ************************************************************************
458
459 (provide 'hbdata)