|
0
|
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)
|
