Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hypb.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 4103f0995bd7
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: hypb.el
4 ;; SUMMARY: Miscellaneous Hyperbole support features.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: extensions, hypermedia
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Brown U.
10 ;;
11 ;; ORIG-DATE: 6-Oct-91 at 03:42:38
12 ;; LAST-MOD: 30-Oct-95 at 21:23:19 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 ;; DESCRIP-END.
22
23 ;;; ************************************************************************
24 ;;; Other required Elisp libraries
25 ;;; ************************************************************************
26
27 (mapcar 'require '(hversion hact))
28
29 ;;; ************************************************************************
30 ;;; Public variables
31 ;;; ************************************************************************
32
33 (defconst hypb:help-buf-suffix " Hypb Help*"
34 "Suffix attached to all native Hyperbole help buffer names.")
35
36 ;;; ************************************************************************
37 ;;; Public functions
38 ;;; ************************************************************************
39
40 (defun hypb:call-process-p (program infile &optional predicate &rest args)
41 "Calls an external PROGRAM with INFILE for input.
42 If PREDICATE is given, it is evaluated in a buffer with the PROGRAM's
43 output and the result returned. If PREDICATE is nil, returns t iff
44 program has no output or just a 0-valued output.
45 Rest of ARGS are passed as arguments to PROGRAM."
46 (let ((buf (get-buffer-create "*test-output*"))
47 (found))
48 (save-excursion
49 (set-buffer buf) (setq buffer-read-only nil) (erase-buffer)
50 (apply 'call-process program infile buf nil args)
51 (setq found
52 (if predicate
53 (eval predicate)
54 (or (= (point-max) 1) ;; No output, consider cmd a success.
55 (and (< (point-max) 4)
56 (string= (buffer-substring 1 2) "0")))))
57 (set-buffer-modified-p nil)
58 (kill-buffer buf))
59 found))
60
61
62 (defun hypb:chmod (op octal-permissions file)
63 "Uses OP and OCTAL-PERMISSIONS integer to set FILE permissions.
64 OP may be +, -, xor, or default =."
65 (let ((func (cond ((eq op '+) (function logior))
66 ((eq op '-) (function
67 (lambda (p1 p2) (logand (lognot p1) p2))))
68 ((eq op 'xor) (function logxor))
69 (t (function (lambda (p1 p2) p1))))))
70 (set-file-modes file (funcall func (hypb:oct-to-int octal-permissions)
71 (file-modes file)))))
72
73 (defun hypb:cmd-key-string (cmd-sym &optional keymap)
74 "Returns a single pretty printed key sequence string bound to CMD-SYM.
75 Global keymap is used unless optional KEYMAP is given."
76 (if (and cmd-sym (symbolp cmd-sym) (fboundp cmd-sym))
77 (let* ((get-keys (function
78 (lambda (cmd-sym keymap)
79 (key-description (where-is-internal
80 cmd-sym keymap 'first)))))
81 (keys (funcall get-keys cmd-sym keymap)))
82 (concat "{"
83 (if (string= keys "")
84 (concat (funcall get-keys 'execute-extended-command nil)
85 " " (symbol-name cmd-sym) " RTN")
86 keys)
87 "}"))
88 (error "(hypb:cmd-key-string): Invalid cmd-sym arg: %s." cmd-sym)))
89
90 ;;;###autoload
91 (defun hypb:configuration (&optional out-buf)
92 "Insert Emacs configuration information at the end of optional OUT-BUF or the current buffer."
93 (save-excursion
94 (and out-buf (set-buffer out-buf))
95 (goto-char (point-max))
96 (delete-blank-lines) (delete-blank-lines)
97 (let ((start (point)))
98 (insert (format "I use:\tEditor: %s\n\tHyperbole: %s\n"
99 (if (boundp 'epoch::version)
100 epoch::version
101 (hypb:replace-match-string
102 " of .+" (emacs-version) "" t))
103 hyperb:version))
104 (if (and (boundp 'system-configuration) (stringp system-configuration))
105 (insert (format "\tSys Type: %s\n" system-configuration)))
106 (insert (format "\tOS Type: %s\n\tWindow Sys: %s\n"
107 system-type (or window-system hyperb:window-system
108 "None")))
109 (if (and (boundp 'hmail:reader) hmail:reader)
110 (insert (format "\tMailer: %s\n"
111 (cond ((eq hmail:reader 'rmail-mode) "RMAIL")
112 ((eq hmail:reader 'vm-mode)
113 (concat "VM " vm-version))
114 ((and (eq hmail:reader 'mh-show-mode)
115 (string-match "v ?\\([0-9]+.[0-9]+\\)"
116 mh-e-RCS-id))
117 (concat "MH-e "
118 (substring mh-e-RCS-id
119 (match-beginning 1)
120 (match-end 1))))
121 ((eq hmail:reader 'pm-fdr-mode)
122 (concat "PIEmail " pm-version))
123 ))))
124 (if (and (boundp 'hnews:reader) (boundp 'gnus-version) hnews:reader)
125 (insert (format "\tNews Rdr: %s\n" gnus-version)))
126 (if (and (boundp 'br-version) (stringp br-version))
127 (insert (format "\tOO-Browser: %s\n" br-version)))
128 (untabify start (point)))))
129
130 (if (fboundp 'copy-tree)
131 (fset 'hypb:copy-sublists 'copy-tree)
132 ;;
133 ;; This function is derived from a copylefted function.
134 ;; Define hypb:copy-sublists if not a builtin. This version
135 ;; is a Lisp translation of the C version in Lemacs 19.8.
136 ;; Copyright (C) 1985, 1986, 1987, 1992, 1993 Free Software Foundation, Inc.
137 ;; Available for use and distribution under the GPL.
138 ;;
139 (defun hypb:copy-sublists (obj &optional vector-p)
140 "Return a copy of a list and substructures.
141 The argument is copied, and any lists contained within it are copied
142 recursively. Circularities and shared substructures are not preserved.
143 Second arg VECP causes vectors to be copied, too. Strings are not copied."
144 (cond ((consp obj)
145 (let (rest)
146 (setq obj (copy-sequence obj)
147 rest obj)
148 (while (consp rest)
149 (let ((elt (car rest)))
150 (if quit-flag (top-level))
151 (if (or (consp elt) (vectorp elt))
152 (setcar rest (hypb:copy-sublists elt vector-p)))
153 (if (vectorp (cdr rest))
154 (setcdr rest (hypb:copy-sublists (cdr rest) vector-p)))
155 (setq rest (cdr rest))))))
156 ((and (vectorp obj) obj)
157 (let ((i (length obj))
158 (j 0)
159 elt)
160 (setq obj (copy-sequence obj))
161 (while (< j i)
162 (setq elt (aref obj j))
163 (if quit-flag (top-level))
164 (if (or (consp elt) (vectorp elt))
165 (aset obj j (hypb:copy-sublists elt vector-p)))
166 (setq j (1+ j))))))
167 obj))
168
169 (defun hypb:debug ()
170 "Loads Hyperbole hbut.el source file and sets debugging traceback flag."
171 (interactive)
172 (or (featurep 'hinit) (load "hsite"))
173 (or (and (featurep 'hbut)
174 (let ((func (hypb:indirect-function 'ebut:create)))
175 (not (or (hypb:v19-byte-code-p func)
176 (eq 'byte-code
177 (car (car (nthcdr 3 (hypb:indirect-function
178 'ebut:create)))))))))
179 (load "hbut.el"))
180 (setq debug-on-error t))
181
182 (defun hypb:domain-name ()
183 "Returns current Internet domain name with '@' prepended or nil if none."
184 (let* ((dname-cmd (or (file-exists-p "/usr/bin/domainname")
185 (file-exists-p "/bin/domainname")))
186 (dname (or (getenv "DOMAINNAME")
187 (if dname-cmd
188 (hypb:call-process-p
189 "domainname" nil
190 '(substring (buffer-string) 0 -1))))))
191 (if (or (and dname (string-match "\\." dname))
192 (let* ((src "/etc/resolv.conf")
193 (src-buf-exists-p (get-file-buffer src)))
194 (and (file-exists-p src) (file-readable-p src)
195 (save-excursion
196 (set-buffer (find-file-noselect src))
197 (goto-char (point-min))
198 (if (re-search-forward "^domain[ \t]+\\([^ \t\n]+\\)"
199 nil t)
200 (setq dname (buffer-substring (match-beginning 1)
201 (match-end 1))))
202 (or src-buf-exists-p (kill-buffer nil))
203 dname))))
204 (concat "@" dname))))
205
206 (defun hypb:error (&rest args)
207 "Signals an error typically to be caught by 'hui:menu'."
208 (let ((msg (apply 'format args)))
209 (put 'error 'error-message msg)
210 (error msg)))
211
212 (defun hypb:functionp (obj)
213 "Returns t if OBJ is a function, nil otherwise."
214 (cond
215 ((symbolp obj) (fboundp obj))
216 ((subrp obj))
217 ((hypb:v19-byte-code-p obj))
218 ((consp obj)
219 (if (eq (car obj) 'lambda) (listp (car (cdr obj)))))
220 (t nil)))
221
222 (defun hypb:function-copy (func-symbol)
223 "Copies FUNC-SYMBOL's body for overloading. Returns copy of body."
224 (if (fboundp func-symbol)
225 (let ((func (hypb:indirect-function func-symbol)))
226 (cond ((listp func) (copy-sequence func))
227 ((subrp func) (error "(hypb:function-copy): `%s' is a primitive; can't copy body."
228 func-symbol))
229 ((and (hypb:v19-byte-code-p func) (fboundp 'make-byte-code))
230 (let ((new-code (append func nil))) ; turn it into a list
231 (apply 'make-byte-code new-code)))
232 (t (error "(hypb:function-copy): Can't copy function body: %s" func))
233 ))
234 (error "(hypb:function-copy): `%s' symbol is not bound to a function."
235 func-symbol)))
236
237 (defun hypb:function-overload (func-sym prepend &rest new-forms)
238 "Redefine function named FUNC-SYM by either PREPENDing (or appending if nil) rest of quoted NEW-FORMS."
239 (let ((old-func-sym (intern
240 (concat "*hypb-old-"
241 (symbol-name func-sym)
242 "*"))))
243 (or (fboundp old-func-sym)
244 (fset old-func-sym (hypb:function-copy func-sym)))
245 (let* ((old-func (hypb:indirect-function old-func-sym))
246 (old-param-list (action:params old-func))
247 (param-list (action:param-list old-func))
248 (old-func-call
249 (list (if (memq '&rest old-param-list)
250 ;; Have to account for extra list wrapper from &rest.
251 (cons 'apply
252 (cons (list 'quote old-func-sym) param-list))
253 (cons old-func-sym param-list)))))
254 (eval (append
255 (list 'defun func-sym old-param-list)
256 (delq nil
257 (list
258 (documentation old-func-sym)
259 (action:commandp old-func-sym)))
260 (if prepend
261 (append new-forms old-func-call)
262 (append old-func-call new-forms)))))))
263
264 (defun hypb:function-symbol-replace (func-sym sym-to-replace replace-with-sym)
265 "Replaces in body of FUNC-SYM SYM-TO-REPLACE with REPLACE-WITH-SYM.
266 All occurrences within lists are replaced. Returns body of modified FUNC-SYM."
267 (let ((body (hypb:indirect-function func-sym))
268 (arg-vector) (arg))
269 (if (listp body)
270 ;; assume V18 byte compiler
271 (setq arg-vector
272 (car (delq nil (mapcar
273 (function
274 (lambda (elt)
275 (and (listp elt)
276 (vectorp (setq arg-vector (nth 2 elt)))
277 arg-vector)))
278 body))))
279 ;; assume V19 byte compiler (eq (compiled-function-p body) t)
280 (setq arg (aref body 2)
281 arg-vector (if (vectorp arg) arg))
282 )
283 (if arg-vector
284 ;; Code is byte-compiled.
285 (let ((i (1- (length arg-vector))))
286 (setq arg nil)
287 (while (and (not arg) (>= i 0))
288 (if (eq (setq arg (aref arg-vector i)) sym-to-replace)
289 (aset arg-vector i replace-with-sym)
290 (setq arg nil i (1- i)))))
291 ;; Code is not byte-compiled.
292 ;; Only replaces occurrence of symbol as an element of a list.
293 (hypb:map-sublists
294 (function
295 (lambda (atom list) (if (eq atom sym-to-replace)
296 (let ((again t))
297 (while (and again list)
298 (if (eq (car list) atom)
299 (progn (setcar list replace-with-sym)
300 (setq again nil))
301 (setq list (cdr list))))))))
302 body)
303 )
304 body))
305
306 (defun hypb:help-buf-name (&optional prefix)
307 "Returns a Hyperbole help buffer name for current buffer.
308 With optional PREFIX string, uses it rather than buffer name."
309 (let ((bn (or prefix (buffer-name))))
310 (if (string-match " Hypb " bn)
311 (buffer-name (generate-new-buffer bn))
312 (concat "*" bn hypb:help-buf-suffix))))
313
314 (defun hypb:indirect-function (obj)
315 "Return the function at the end of OBJ's function chain.
316 Resolves autoloadable function symbols properly."
317 (let ((func
318 (if (fboundp 'indirect-function)
319 (indirect-function obj)
320 (while (symbolp obj)
321 (setq obj (symbol-function obj)))
322 obj)))
323 ;; Handle functions with autoload bodies.
324 (if (and (symbolp obj) (listp func) (eq (car func) 'autoload))
325 (let ((load-file (car (cdr func))))
326 (load load-file)
327 ;; Prevent infinite recursion
328 (if (equal func (symbol-function obj))
329 (error "(hypb:indirect-function): Autoload of '%s' failed" obj)
330 (hypb:indirect-function obj)))
331 func)))
332
333 (defun hypb:insert-region (buffer start end invisible-flag)
334 "Insert into BUFFER the contents of a region from START to END in the current buffer.
335 INVISIBLE-FLAG, if non-nil, means invisible text in an outline region is
336 copied, otherwise, it is omitted."
337 (let ((from-koutline (eq major-mode 'kotl-mode)))
338 (append-to-buffer buffer start end)
339 (save-excursion
340 (set-buffer buffer)
341 (let ((first (- (point) (- end start)))
342 (last (point)))
343 ;; Remove from buffer any copied text that was hidden if invisible-flag
344 ;; is nil.
345 (if invisible-flag
346 ;; Show all hidden text within the copy.
347 (subst-char-in-region first last ?\r ?\n t)
348 ;; Remove hidden text.
349 (goto-char first)
350 (while (search-forward "\r" last t)
351 (delete-region (1- (point)) (progn (end-of-line) (point)))))
352 ;;
353 ;; If region came from a koutline, remove any characters with an
354 ;; invisible property which separate cells.
355 (if from-koutline
356 (kproperty:map
357 (function (lambda (prop) (delete-char 1))) 'invisible t))))))
358
359 (if (or hyperb:lemacs-p hyperb:emacs19-p)
360 (fset 'hypb:mark 'mark)
361 (defun hypb:mark (inactive-p)
362 "Return this buffer's mark value as integer, or nil if no mark.
363 INACTIVE-P non-nil means return value of mark even if region is not active
364 under Emacs version 19.
365 If you are using this in an editing command, you are most likely making
366 a mistake; see the documentation of `set-mark'."
367 (mark))
368 )
369 (if hyperb:lemacs-p
370 (fset 'hypb:mark-marker 'mark-marker)
371 (defun hypb:mark-marker (inactive-p)
372 "Return this buffer's mark as a marker object, or nil if no mark.
373 INACTIVE-P is unused, it is for compatibility with Lucid Emacs'
374 version of mark-marker."
375 (mark-marker))
376 )
377
378 (defun hypb:map-sublists (func list)
379 "Applies FUNC to every atom found at any level of LIST.
380 FUNC must take two arguments, an atom and a list in which the atom is found.
381 Returns values from applications of FUNC as a list with the same
382 structure as LIST. FUNC is therefore normally used just for its side-effects."
383 (mapcar (function
384 (lambda (elt) (if (atom elt)
385 (funcall func elt list)
386 (hypb:map-sublists func elt)))
387 list)))
388
389 (defun hypb:map-vector (func object)
390 "Returns list of results of application of FUNC to each element of OBJECT.
391 OBJECT should be a vector or byte-code object."
392 (if (not (or (vectorp object) (hypb:v19-byte-code-p object)))
393 (error "(hypb:map-vector): Second argument must be a vector or byte-code object."))
394 (let ((end (length object))
395 (i 0)
396 (result))
397 (while (< i end)
398 (setq result (cons (funcall func (aref object i)) result)
399 i (1+ i)))
400 (nreverse result)))
401
402 (defun hypb:mouse-help-file ()
403 "Return the full path to the Hyperbole mouse key help file."
404 (let* ((hypb-man (expand-file-name "man/" hyperb:dir))
405 (help-file (expand-file-name "hypb-mouse.txt" hypb-man)))
406 (if (or (file-exists-p help-file)
407 (file-exists-p
408 (setq help-file (expand-file-name
409 "hypb-mouse.txt" data-directory))))
410 help-file
411 (error "(hypb:mouse-help-file): Non-existent file: \"%s\"" help-file))))
412
413 (if (or hyperb:lemacs-p hyperb:emacs19-p)
414 (fset 'hypb:push-mark 'push-mark)
415 (defun hypb:push-mark (&optional location nomsg activate-region)
416 "Set mark at LOCATION (point, by default) and push old mark on mark ring.
417 If the last global mark pushed was not in the current buffer,
418 also push LOCATION on the global mark ring.
419 Display `Mark set' unless the optional second arg NOMSG is non-nil.
420 Optional third arg ACTIVATE-REGION is ignored.
421
422 Novice Emacs Lisp programmers often try to use the mark for the wrong
423 purposes. See the documentation of `set-mark' for more information."
424 (push-mark location nomsg))
425 )
426
427 (defun hypb:replace-match-string (regexp str newtext &optional literal)
428 "Replaces all matches for REGEXP in STR with NEWTEXT string.
429 Optional LITERAL non-nil means do a literal replacement.
430 Otherwise treat \\ in NEWTEXT string as special:
431 \\& means substitute original matched text,
432 \\N means substitute match for \(...\) number N,
433 \\\\ means insert one \\.
434 NEWTEXT may instead be a function of one argument, the string to replace in,
435 that returns a replacement string."
436 (if (not (stringp str))
437 (error "(hypb:replace-match-string): 2nd arg must be a string: %s" str))
438 (if (or (stringp newtext) (hypb:functionp newtext))
439 nil
440 (error "(hypb:replace-match-string): 3rd arg must be a string or function: %s"
441 newtext))
442 (let ((rtn-str "")
443 (start 0)
444 (special)
445 match prev-start)
446 (while (setq match (string-match regexp str start))
447 (setq prev-start start
448 start (match-end 0)
449 rtn-str
450 (concat
451 rtn-str
452 (substring str prev-start match)
453 (cond ((hypb:functionp newtext) (funcall newtext str))
454 (literal newtext)
455 (t (mapconcat
456 (function
457 (lambda (c)
458 (if special
459 (progn
460 (setq special nil)
461 (cond ((eq c ?\\) "\\")
462 ((eq c ?&)
463 (substring str
464 (match-beginning 0)
465 (match-end 0)))
466 ((and (>= c ?0) (<= c ?9))
467 (if (> c (+ ?0 (length
468 (match-data))))
469 ;; Invalid match num
470 (error "(hypb:replace-match-string) Invalid match num: %c" c)
471 (setq c (- c ?0))
472 (substring str
473 (match-beginning c)
474 (match-end c))))
475 (t (char-to-string c))))
476 (if (eq c ?\\) (progn (setq special t) nil)
477 (char-to-string c)))))
478 newtext ""))))))
479 (concat rtn-str (substring str start))))
480
481 (defun hypb:supercite-p ()
482 "Returns non-nil iff the Emacs add-on supercite package is in use."
483 (let (hook-val)
484 (if (memq t (mapcar
485 (function
486 (lambda (hook-var)
487 (and (boundp hook-var)
488 (progn (setq hook-val (symbol-value hook-var))
489 (cond ((listp hook-val)
490 (if (memq 'sc-cite-original hook-val)
491 t))
492 ((eq hook-val 'sc-cite-original)))))))
493 '(mail-citation-hook mail-yank-hooks)))
494 t)))
495
496 ;;; Next function is copied from a copylefted function:
497 ;;; Copyright (C) 1987, 1988 Kyle E. Jones
498 (if (or hyperb:lemacs-p hyperb:emacs19-p)
499 (defun hypb:window-list-all-frames (&optional mini)
500 "Returns a list of Lisp window objects for all Emacs windows in all frames.
501 Optional first arg MINI t means include the minibuffer window
502 in the list, even if it is not active. If MINI is neither t
503 nor nil it means to not count the minibuffer window even if it is active."
504 (let* ((first-window (next-window
505 (previous-window (selected-window) nil t t)
506 mini t t))
507 (windows (cons first-window nil))
508 (current-cons windows)
509 (w (next-window first-window mini t t)))
510 (while (not (eq w first-window))
511 (setq current-cons (setcdr current-cons (cons w nil)))
512 (setq w (next-window w mini t t)))
513 windows)))
514
515 ;;; Next function is copied from a copylefted function:
516 ;;; Copyright (C) 1987, 1988 Kyle E. Jones
517 (defun hypb:window-list (&optional mini)
518 "Returns a list of Lisp window objects for all Emacs windows in selected frame.
519 Optional first arg MINI t means include the minibuffer window
520 in the list, even if it is not active. If MINI is neither t
521 nor nil it means to not count the minibuffer window even if it is active."
522 (let* ((first-window (next-window
523 (previous-window (selected-window)) mini))
524 (windows (cons first-window nil))
525 (current-cons windows)
526 (w (next-window first-window mini)))
527 (while (not (eq w first-window))
528 (setq current-cons (setcdr current-cons (cons w nil)))
529 (setq w (next-window w mini)))
530 windows))
531
532 (defun hypb:v19-byte-code-p (obj)
533 "Return non-nil iff OBJ is an Emacs V19 byte compiled object."
534 (or (and (fboundp 'compiled-function-p) (compiled-function-p obj))
535 (and (fboundp 'byte-code-function-p) (byte-code-function-p obj))))
536
537 ;;; ************************************************************************
538 ;;; Private functions
539 ;;; ************************************************************************
540
541 (defun hypb:oct-to-int (oct-num)
542 "Returns octal integer OCTAL-NUM converted to a decimal integer."
543 (let ((oct-str (int-to-string oct-num))
544 (dec-num 0))
545 (and (string-match "[^0-7]" oct-str)
546 (error (format "(hypb:oct-to-int): Bad octal number: %s" oct-str)))
547 (mapconcat (function
548 (lambda (o)
549 (setq dec-num (+ (* dec-num 8)
550 (if (and (>= o ?0) (<= o ?7))
551 (- o ?0))))))
552 oct-str "")
553 dec-num))
554
555 ;;; ************************************************************************
556 ;;; Private variables
557 ;;; ************************************************************************
558
559 (provide 'hypb)