0
|
1 ;;!emacs
|
|
2 ;;
|
|
3 ;; FILE: hui.el
|
|
4 ;; SUMMARY: GNU Emacs User Interface to Hyperbole
|
|
5 ;; USAGE: GNU Emacs Lisp Library
|
|
6 ;; KEYWORDS: hypermedia
|
|
7 ;;
|
|
8 ;; AUTHOR: Bob Weiner
|
70
|
9 ;; ORG: Brown U.
|
0
|
10 ;;
|
|
11 ;; ORIG-DATE: 19-Sep-91 at 21:42:03
|
70
|
12 ;; LAST-MOD: 25-Aug-95 at 02:26:56 by Bob Weiner
|
0
|
13 ;;
|
|
14 ;; This file is part of Hyperbole.
|
|
15 ;; Available for use and distribution under the same terms as GNU Emacs.
|
|
16 ;;
|
70
|
17 ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
|
0
|
18 ;; Developed with support from Motorola Inc.
|
|
19 ;;
|
|
20 ;; DESCRIPTION:
|
|
21 ;; DESCRIP-END.
|
|
22
|
|
23 ;;; ************************************************************************
|
|
24 ;;; Other required Elisp libraries
|
|
25 ;;; ************************************************************************
|
|
26
|
|
27 (require 'hargs) (require 'set) (require 'hmail)
|
|
28
|
|
29 ;;; ************************************************************************
|
|
30 ;;; Public variables
|
|
31 ;;; ************************************************************************
|
|
32
|
|
33 (defvar hui:ebut-delete-confirm-p t
|
|
34 "*Non-nil means prompt before interactively deleting explicit buttons.")
|
|
35
|
|
36 ;;; ************************************************************************
|
|
37 ;;; Public functions
|
|
38 ;;; ************************************************************************
|
|
39
|
|
40 (defun hui:ebut-create (&optional start end)
|
|
41 "Creates an explicit but starting from label between optional START and END.
|
|
42 Indicates by delimiting and adding any necessary instance number of the button
|
|
43 label."
|
|
44 (interactive (list (and (marker-position (hypb:mark-marker t))
|
|
45 (region-beginning))
|
|
46 (and (marker-position (hypb:mark-marker t))
|
|
47 (region-end))))
|
|
48 (let ((default-lbl) lbl but-buf actype)
|
|
49 (save-excursion
|
|
50 (setq default-lbl
|
|
51 (hui:hbut-label-default start end (not (interactive-p)))
|
|
52 lbl (hui:hbut-label default-lbl "ebut-create"))
|
|
53 (if (not (equal lbl default-lbl)) (setq default-lbl nil))
|
|
54
|
|
55 (setq but-buf (if default-lbl (current-buffer) (hui:ebut-buf)))
|
|
56 (hui:buf-writable-err but-buf "ebut-create")
|
|
57
|
|
58 (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
|
|
59 (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
|
|
60 (setq actype (hui:actype))
|
|
61 (hattr:set 'hbut:current 'actype actype)
|
|
62 (hattr:set 'hbut:current 'args (hargs:actype-get actype))
|
|
63 (hattr:set 'hbut:current 'action
|
|
64 (and (boundp 'hui:ebut-prompt-for-action)
|
|
65 hui:ebut-prompt-for-action (hui:action actype)))
|
|
66 )
|
|
67 (ebut:operate lbl nil)))
|
|
68
|
|
69 (defun hui:ebut-delete (but-key &optional key-src)
|
|
70 "Deletes explicit Hyperbole button given by BUT-KEY in optional KEY-SRC.
|
|
71 KEY-SRC may be a buffer or a pathname, when nil the current buffer is used.
|
|
72 Returns t if button is deleted, nil if user chooses not to delete or signals
|
|
73 an error otherwise. If called interactively, prompts user whether to delete
|
|
74 and derives BUT-KEY from the button that point is within.
|
|
75 Signals an error if point is not within a button."
|
|
76 (interactive (list (if (ebut:at-p)
|
|
77 (hattr:get 'hbut:current 'lbl-key)
|
|
78 nil)))
|
|
79 (cond ((null but-key)
|
|
80 (hypb:error
|
|
81 "(ebut-delete): Point is not over the label of an existing button."))
|
|
82 ((not (stringp but-key))
|
|
83 (hypb:error
|
|
84 "(ebut-delete): Invalid label key argument: '%s'." but-key)))
|
|
85 (let ((interactive (interactive-p)))
|
|
86 (if (and hui:ebut-delete-confirm-p interactive)
|
|
87 (if (y-or-n-p (format "Delete button %s%s%s? "
|
|
88 ebut:start
|
|
89 (hbut:key-to-label but-key) ebut:end))
|
|
90 (hui:ebut-delete-op interactive but-key key-src)
|
|
91 (message ""))
|
|
92 (hui:ebut-delete-op interactive but-key key-src))))
|
|
93
|
|
94 (defun hui:ebut-edit ()
|
|
95 "Creates or modifies an explicit Hyperbole button when conditions are met.
|
|
96 A region must have been delimited with the action-key and point must now be
|
|
97 within it before this function is called or it will do nothing. The region
|
|
98 must be no larger than the size given by 'ebut:max-len'. It must be entirely
|
|
99 within or entirely outside of an existing explicit button. When region is
|
|
100 within the button, the button is interactively modified. Otherwise, a new
|
|
101 button is created interactively with the region as the default label."
|
|
102 (interactive)
|
|
103 (let ((m (marker-position (hypb:mark-marker t)))
|
|
104 (op action-key-depress-prev-point) (p (point)) (lbl-key))
|
|
105 (if (and m (eq (marker-buffer m) (marker-buffer op))
|
|
106 (< op m) (<= (- m op) ebut:max-len)
|
|
107 (<= p m) (<= op p))
|
|
108 (progn
|
|
109 (if (setq lbl-key (ebut:label-p))
|
|
110 (hui:ebut-modify lbl-key)
|
|
111 (hui:ebut-create op m))
|
|
112 t))))
|
|
113
|
|
114 (defun hui:ebut-modify (lbl-key)
|
|
115 "Modifies an explicit Hyperbole button given by LBL-KEY.
|
|
116 Signals an error when no such button is found in the current buffer."
|
|
117 (interactive (list (save-excursion
|
|
118 (hui:buf-writable-err (current-buffer) "ebut-modify")
|
|
119 (or (ebut:label-p)
|
|
120 (ebut:label-to-key
|
|
121 (hargs:read-match "Button to modify: "
|
|
122 (ebut:alist) nil t
|
|
123 nil 'ebut))))))
|
|
124 (let ((lbl (ebut:key-to-label lbl-key))
|
|
125 (but-buf (current-buffer))
|
|
126 actype but new-lbl)
|
|
127 (save-excursion
|
|
128 (or (interactive-p)
|
|
129 (hui:buf-writable-err but-buf "ebut-modify"))
|
|
130
|
|
131 (or (setq but (ebut:get lbl-key but-buf))
|
|
132 (progn (pop-to-buffer but-buf)
|
|
133 (hypb:error "(ebut-modify): Invalid button, no data for '%s'." lbl)))
|
|
134
|
|
135 (setq new-lbl
|
|
136 (hargs:read
|
|
137 "Change button label to: "
|
|
138 (function
|
|
139 (lambda (lbl)
|
|
140 (and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
|
|
141 lbl
|
|
142 (format "(ebut-modify): Enter a string of at most %s chars."
|
|
143 ebut:max-len)
|
|
144 'string))
|
|
145
|
|
146 (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
|
|
147 (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
|
|
148 (setq actype (hui:actype (hattr:get but 'actype)))
|
|
149 (hattr:set 'hbut:current 'actype actype)
|
|
150 (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying))
|
|
151 (hattr:set 'hbut:current 'action
|
|
152 (and (boundp 'hui:ebut-prompt-for-action)
|
|
153 hui:ebut-prompt-for-action (hui:action actype)))
|
|
154 )
|
|
155 (ebut:operate lbl new-lbl)))
|
|
156
|
|
157 (defun hui:ebut-rename (curr-label new-label)
|
|
158 "Renames explicit Hyperbole button given by CURR-LABEL to NEW-LABEL.
|
|
159 If called interactively when point is not within an explicit button:
|
|
160 prompts for old and new button label values and performs rename.
|
|
161 If called interactively when point is within an explicit button:
|
|
162 saves button label and tells user to edit label, then call again.
|
|
163 second call changes the button's name from the stored value to the
|
|
164 edited value.
|
|
165 Signals an error if any problem occurs."
|
|
166 (interactive
|
|
167 (save-excursion
|
|
168 (let (curr-label new-label)
|
|
169 (hui:buf-writable-err (current-buffer) "ebut-rename")
|
|
170 (if hui:ebut-label-prev
|
|
171 (setq curr-label hui:ebut-label-prev
|
|
172 new-label (ebut:label-p 'as-label))
|
|
173 (setq new-label nil
|
|
174 curr-label
|
|
175 (or (ebut:label-p 'as-label)
|
|
176 (let ((buts (ebut:alist)))
|
|
177 (if (null buts)
|
|
178 (hypb:error "(ebut-rename): No explicit buttons in buffer.")
|
|
179 (prog1 (hargs:read-match
|
|
180 "Button label to rename: "
|
|
181 buts nil t nil 'ebut)
|
|
182 (setq new-label
|
|
183 (hargs:read
|
|
184 "Rename button label to: "
|
|
185 (function
|
|
186 (lambda (lbl)
|
|
187 (and (not (string= lbl ""))
|
|
188 (<= (length lbl) ebut:max-len))))
|
|
189 curr-label
|
|
190 (format
|
|
191 "(ebut-rename): Use a quoted string of at most %s chars."
|
|
192 ebut:max-len)
|
|
193 'string))))))))
|
|
194 (list curr-label new-label))))
|
|
195
|
|
196 (save-excursion
|
|
197 (if (interactive-p)
|
|
198 nil
|
|
199 (hui:buf-writable-err (current-buffer) "ebut-rename")
|
|
200 (if (or (not (stringp curr-label)) (string= curr-label ""))
|
|
201 (hypb:error "(ebut-rename): 'curr-label' must be a non-empty string: %s"
|
|
202 curr-label))
|
|
203 (and (stringp new-label) (string= new-label "")
|
|
204 (hypb:error "(ebut-rename): 'new-label' must be a non-empty string: %s"
|
|
205 new-label)))
|
|
206 (or (ebut:get (ebut:label-to-key curr-label))
|
|
207 (hypb:error "(ebut-rename): Can't rename %s since no button data."
|
|
208 curr-label))
|
|
209 )
|
|
210 (cond (new-label
|
|
211 (ebut:operate curr-label new-label)
|
|
212 (setq hui:ebut-label-prev nil)
|
|
213 (message "Renamed from '%s' to '%s'." curr-label new-label))
|
|
214 (curr-label
|
|
215 (setq hui:ebut-label-prev curr-label)
|
|
216 (message "Edit button label and use same command to finish rename."))
|
|
217 (t (hypb:error "(ebut-rename): Move point to within a button label."))))
|
|
218
|
|
219 (defun hui:ebut-search (string &optional match-part)
|
|
220 "Shows lines of files/buffers containing an explicit but match for STRING.
|
|
221 Returns number of buttons matched and displayed.
|
|
222 By default, only matches for whole button labels are found, optional MATCH-PART
|
|
223 enables partial matches. The match lines are shown in a buffer which serves as
|
|
224 a menu to find any of the occurrences."
|
|
225 (interactive (list (read-string "Search for button string: ")
|
|
226 (y-or-n-p "Enable partial matches? ")))
|
|
227 (if (not (stringp string))
|
|
228 (hypb:error "(ebut-search): String to search for is required."))
|
|
229 (let* ((prefix (if (> (length string) 14)
|
|
230 (substring string 0 13) string))
|
|
231 (out-buf (get-buffer-create (concat "*" prefix " Hypb Search*")))
|
|
232 (total (ebut:search string out-buf match-part)))
|
|
233 (if (> total 0)
|
|
234 (progn
|
|
235 (set-buffer out-buf)
|
|
236 (moccur-mode)
|
|
237 (if (fboundp 'outline-minor-mode)
|
|
238 (and (progn (goto-char 1)
|
|
239 (search-forward "\C-m" nil t))
|
|
240 (outline-minor-mode 1)))
|
|
241 (if (fboundp 'hproperty:but-create)
|
|
242 (hproperty:but-create nil nil (regexp-quote
|
|
243 (if match-part string
|
|
244 (concat ebut:start string ebut:end)))))
|
|
245 (goto-char (point-min))
|
|
246 (pop-to-buffer out-buf)
|
|
247 (if (interactive-p) (message "%d match%s." total
|
|
248 (if (> total 1) "es" ""))
|
|
249 total))
|
|
250 (if (interactive-p) (message "No matches.")
|
|
251 total))))
|
|
252
|
|
253 (defun hui:error (&rest args)
|
|
254 (hypb:error "(hui:error): Obsolete, use hypb:error instead."))
|
|
255
|
|
256 (defun hui:gbut-create (lbl)
|
|
257 "Creates Hyperbole global button with LBL."
|
|
258 (interactive "sCreate global button labeled: ")
|
|
259 (let (but-buf actype)
|
|
260 (save-excursion
|
|
261 (setq actype (hui:actype))
|
|
262 (setq but-buf (set-buffer (find-file-noselect gbut:file)))
|
|
263 (hui:buf-writable-err but-buf "ebut-create")
|
|
264 ;; This prevents movement of point which might be useful to user.
|
|
265 (save-excursion
|
|
266 (goto-char (point-max))
|
|
267 (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
|
|
268 (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
|
|
269 (hattr:set 'hbut:current 'actype actype)
|
|
270 (hattr:set 'hbut:current 'args (hargs:actype-get actype))
|
|
271 (hattr:set 'hbut:current 'action
|
|
272 (and (boundp 'hui:ebut-prompt-for-action)
|
|
273 hui:ebut-prompt-for-action (hui:action actype)))
|
|
274 (setq lbl (concat lbl (ebut:operate lbl nil)))
|
|
275 (goto-char (point-max))
|
|
276 (insert "\n")
|
|
277 (save-buffer)
|
|
278 )
|
|
279 (message "%s created." lbl)
|
|
280 )))
|
|
281
|
|
282 (defun hui:gbut-modify (lbl-key)
|
|
283 "Modifies a global Hyperbole button given by LBL-KEY.
|
|
284 Signals an error when no such button is found."
|
|
285 (interactive (list (save-excursion
|
|
286 (hui:buf-writable-err
|
|
287 (find-file-noselect gbut:file) "gbut-modify")
|
|
288 (hbut:label-to-key
|
|
289 (hargs:read-match "Global button to modify: "
|
70
|
290 (mapcar 'list (gbut:lbl-list))
|
0
|
291 nil t nil 'ebut)))))
|
|
292 (let ((lbl (hbut:key-to-label lbl-key))
|
|
293 (but-buf (find-file-noselect gbut:file))
|
|
294 actype but new-lbl)
|
|
295 (save-excursion
|
|
296 (or (interactive-p)
|
|
297 (hui:buf-writable-err but-buf "gbut-modify"))
|
|
298
|
|
299 (or (setq but (ebut:get lbl-key but-buf))
|
|
300 (progn (pop-to-buffer but-buf)
|
|
301 (hypb:error
|
|
302 "(gbut-modify): Invalid button, no data for '%s'." lbl)))
|
|
303
|
|
304 (setq new-lbl
|
|
305 (hargs:read
|
|
306 "Change global button label to: "
|
|
307 (function
|
|
308 (lambda (lbl)
|
|
309 (and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
|
|
310 lbl
|
|
311 (format "(gbut-modify): Enter a string of at most %s chars."
|
|
312 ebut:max-len)
|
|
313 'string))
|
|
314
|
|
315 (hattr:set 'hbut:current 'loc (hui:key-src but-buf))
|
|
316 (hattr:set 'hbut:current 'dir (hui:key-dir but-buf))
|
|
317 (setq actype (hui:actype (hattr:get but 'actype)))
|
|
318 (hattr:set 'hbut:current 'actype actype)
|
|
319 (hattr:set 'hbut:current 'args (hargs:actype-get actype 'modifying))
|
|
320 (hattr:set 'hbut:current 'action
|
|
321 (and (boundp 'hui:ebut-prompt-for-action)
|
|
322 hui:ebut-prompt-for-action (hui:action actype)))
|
|
323 (set-buffer but-buf)
|
|
324 (ebut:operate lbl new-lbl))))
|
|
325
|
|
326 (defun hui:hbut-act (&optional but)
|
|
327 "Executes action for optional Hyperbole button symbol BUT in current buffer.
|
|
328 Default is the current button."
|
|
329 (interactive
|
|
330 (let ((but (hbut:at-p)) (lst))
|
|
331 (list
|
|
332 (cond (but)
|
|
333 ((setq lst (ebut:alist))
|
|
334 (ebut:get (ebut:label-to-key
|
|
335 (hargs:read-match "Button to execute: " lst nil t
|
|
336 (ebut:label-p 'as-label) 'ebut))))
|
|
337 (t (hypb:error "(hbut-act): No explicit buttons in buffer."))))))
|
|
338 (cond ((and (interactive-p) (null but))
|
|
339 (hypb:error "(hbut-act): No current button to activate."))
|
|
340 ((not (hbut:is-p but))
|
|
341 (hypb:error "(hbut-act): Button is invalid; it has no attributes."))
|
|
342 (t (or but (setq but 'hbut:current))
|
|
343 (hui:but-flash) (hyperb:act but))))
|
|
344
|
|
345 (defun hui:hbut-help (&optional but)
|
|
346 "Checks for and explains an optional button given by symbol, BUT.
|
|
347 BUT defaults to the button whose label point is within."
|
|
348 (interactive)
|
|
349 (setq but (or but (hbut:at-p)
|
|
350 (ebut:get (ebut:label-to-key
|
|
351 (hargs:read-match "Help for button: "
|
|
352 (ebut:alist) nil t nil 'ebut)))))
|
|
353 (or but
|
|
354 (hypb:error "(hbut-help): Move point to a valid Hyperbole button."))
|
|
355 (if (not (hbut:is-p but))
|
|
356 (cond (but (hypb:error "(hbut-help): Invalid button."))
|
|
357 (t (hypb:error
|
|
358 "(hbut-help): Not on an implicit button and no buffer explicit buttons."))))
|
|
359 (let ((type-help-func (intern-soft
|
|
360 (concat
|
|
361 (htype:names 'ibtypes (hattr:get but 'categ))
|
|
362 ":help"))))
|
|
363 (or (equal (hypb:indirect-function 'hui:but-flash)
|
|
364 (function (lambda nil)))
|
|
365 ;; Only flash button if point is on it.
|
|
366 (let ((lbl-key (hattr:get but 'lbl-key)))
|
|
367 (and lbl-key
|
|
368 (or (equal lbl-key (ebut:label-p))
|
|
369 (equal lbl-key (ibut:label-p)))
|
|
370 (hui:but-flash))))
|
|
371 (if type-help-func
|
|
372 (funcall type-help-func but)
|
|
373 (let ((total (hbut:report but)))
|
|
374 (if total (hui:help-ebut-highlight))))))
|
|
375
|
|
376 (defun hui:hbut-label (default-label func-name)
|
|
377 "Reads button label from user using DEFAULT-LABEL and caller's FUNC-NAME."
|
|
378 (hargs:read "Button label: "
|
|
379 (function
|
|
380 (lambda (lbl)
|
|
381 (and (not (string= lbl "")) (<= (length lbl) ebut:max-len))))
|
|
382 default-label
|
|
383 (format "(%s): Enter a string of at most %s chars."
|
|
384 func-name ebut:max-len)
|
|
385 'string))
|
|
386
|
|
387 (defun hui:hbut-label-default (start end &optional skip-len-test)
|
|
388 "Returns default label based on START and END region markers or points.
|
|
389 Optional SKIP-LEN-TEST means don't limit label to 'ebut:max-len' length.
|
|
390 Returns nil if START or END are invalid or if region fails length test.
|
|
391
|
|
392 Also has side effect of moving point to start of default label, if any."
|
|
393 (if (markerp start) (setq start (marker-position start)))
|
|
394 (if (markerp end) (setq end (marker-position end)))
|
|
395 ;; Test whether to use region as default button label.
|
|
396 (if (and (integerp start) (integerp end)
|
|
397 (or skip-len-test
|
|
398 (<= (max (- end start) (- start end)) ebut:max-len)))
|
|
399 (progn (goto-char start)
|
|
400 (buffer-substring start end))))
|
|
401
|
|
402 (defun hui:hbut-report (&optional arg)
|
|
403 "Pretty prints attributes of current button, using optional prefix ARG.
|
|
404 See 'hbut:report'."
|
|
405 (interactive "P")
|
|
406 (if (and arg (symbolp arg))
|
|
407 (hui:hbut-help arg)
|
|
408 (let ((total (hbut:report arg)))
|
|
409 (if total
|
|
410 (progn (hui:help-ebut-highlight)
|
|
411 (message "%d button%s." total (if (/= total 1) "s" "")))))))
|
|
412
|
|
413 (fset 'hui:hbut-summarize 'hui:hbut-report)
|
|
414
|
|
415 (defun hui:link-directly ()
|
|
416 "Creates a Hyperbole link button at depress point, linked to release point.
|
|
417 See also documentation for 'hui:link-possible-types'."
|
|
418 (let* ((link-types (hui:link-possible-types))
|
|
419 (but-window action-key-depress-window)
|
|
420 (num-types (length link-types))
|
|
421 (release-window (selected-window))
|
|
422 (but-modify nil)
|
|
423 type-and-args lbl-key but-loc but-dir)
|
|
424 (select-window action-key-depress-window)
|
|
425 (hui:buf-writable-err (current-buffer) "link-directly")
|
|
426 (if (ebut:at-p)
|
|
427 (progn
|
|
428 (setq but-modify t
|
|
429 but-loc (hattr:get 'hbut:current 'loc)
|
|
430 but-dir (hattr:get 'hbut:current 'dir)
|
|
431 lbl-key (hattr:get 'hbut:current 'lbl-key)))
|
|
432 (setq but-loc (hui:key-src (current-buffer))
|
|
433 but-dir (hui:key-dir (current-buffer))
|
|
434 lbl-key (hbut:label-to-key
|
|
435 (hui:hbut-label
|
|
436 (if (marker-position (hypb:mark-marker t))
|
|
437 (hui:hbut-label-default
|
|
438 (region-beginning) (region-end)))
|
|
439 "link-directly"))))
|
|
440 (select-window release-window)
|
|
441
|
|
442 (cond ((= num-types 0)
|
|
443 (error "(link-directly): No possible link type to create."))
|
|
444 ((= num-types 1)
|
|
445 (hui:link-create but-modify
|
|
446 but-window lbl-key but-loc but-dir
|
|
447 (setq type-and-args (car link-types))))
|
|
448 (t;; more than 1
|
|
449 (let ((item)
|
|
450 type)
|
|
451 (hui:link-create
|
|
452 but-modify but-window
|
|
453 lbl-key but-loc but-dir
|
|
454 (setq type-and-args
|
|
455 (hui:menu-select
|
|
456 (cons '("Link to>")
|
|
457 (mapcar
|
|
458 (function
|
|
459 (lambda (type-and-args)
|
|
460 (setq type (car type-and-args))
|
|
461 (list
|
|
462 (capitalize
|
|
463 (if (string-match
|
|
464 "^\\(link-to\\|eval\\)-"
|
|
465 (setq item (symbol-name type)))
|
|
466 (setq item (substring
|
|
467 item (match-end 0)))
|
|
468 item))
|
|
469 type-and-args
|
|
470 (documentation
|
|
471 (intern (concat "actypes::"
|
|
472 (symbol-name type)))))))
|
|
473 link-types))))))))
|
|
474 (message "`%s' button %s type `%s'."
|
|
475 (hbut:key-to-label lbl-key)
|
|
476 (if but-modify "set to" "created with")
|
|
477 (car type-and-args))))
|
|
478
|
|
479 ;;; ************************************************************************
|
|
480 ;;; Private functions
|
|
481 ;;; ************************************************************************
|
|
482
|
|
483 (defun hui:action (actype &optional prompt)
|
|
484 "Prompts for and returns an action to override action from ACTYPE."
|
|
485 (and actype
|
|
486 (let* ((act) (act-str)
|
|
487 (params (actype:params actype))
|
|
488 (params-str (and params (concat " " (prin1-to-string params))))
|
|
489 )
|
|
490 (while (progn
|
|
491 (while (and (setq act-str
|
|
492 (hargs:read
|
|
493 (or prompt (concat "Action" params-str
|
|
494 ": ")) nil nil
|
|
495 nil 'string))
|
|
496 (not (string= act-str ""))
|
|
497 (condition-case ()
|
|
498 (progn (setq act (read act-str)) nil)
|
|
499 (error
|
|
500 (beep) (message "Invalid action syntax.")
|
|
501 (sit-for 3) t))))
|
|
502 (and (not (symbolp act))
|
|
503 params
|
|
504 ;; Use the weak condition that action must
|
|
505 ;; involve at least one of actype's parameters
|
|
506 ;; or else we assume the action is invalid, tell
|
|
507 ;; the user and provide another chance for entry.
|
|
508 (not (memq t
|
|
509 (mapcar
|
|
510 (function
|
|
511 (lambda (param)
|
|
512 (setq param (symbol-name param))
|
|
513 (and (string-match
|
|
514 (concat "[\( \t\n,']"
|
|
515 (regexp-quote param)
|
|
516 "[\(\) \t\n\"]")
|
|
517 act-str)
|
|
518 t)))
|
|
519 params)))
|
|
520 ))
|
|
521 (beep) (message "Action must use at least one parameter.")
|
|
522 (sit-for 3))
|
|
523 (let (head)
|
|
524 (while (cond ((listp act)
|
|
525 (and act (setq head (car act))
|
|
526 (not (or (eq head 'lambda)
|
|
527 (eq head 'defun)
|
|
528 (eq head 'defmacro)))
|
|
529 (setq act (list 'lambda params act))
|
|
530 nil ;; terminate loop
|
|
531 ))
|
|
532 ((symbolp act)
|
|
533 (setq act (cons act params)))
|
|
534 ((stringp act)
|
|
535 (setq act (action:kbd-macro act 1)))
|
|
536 ;; Unrecognized form
|
|
537 (t (setq act nil))
|
|
538 )))
|
|
539 act)))
|
|
540
|
|
541 (defun hui:actype (&optional default-actype prompt)
|
|
542 "Using optional DEFAULT-ACTYPE, PROMPTs for a button action type.
|
|
543 DEFAULT-ACTYPE may be a valid symbol or symbol-name."
|
|
544 (and default-actype (symbolp default-actype)
|
|
545 (progn
|
|
546 (setq default-actype (symbol-name default-actype))
|
|
547 (if (string-match "actypes::" default-actype)
|
|
548 (setq default-actype (substring default-actype (match-end 0))))))
|
|
549 (if (or (null default-actype) (stringp default-actype))
|
|
550 (intern-soft
|
|
551 (concat "actypes::"
|
|
552 (hargs:read-match (or prompt "Button's action type: ")
|
|
553 (mapcar 'list (htype:names 'actypes))
|
|
554 nil t default-actype 'actype)))
|
|
555 (hypb:error "(actype): Invalid default action type received.")
|
|
556 ))
|
|
557
|
|
558 (defun hui:buf-writable-err (but-buf func-name)
|
|
559 "If BUT-BUF is read-only or is unwritable, signal an error from FUNC-NAME."
|
|
560 (let ((obuf (prog1 (current-buffer) (set-buffer but-buf)))
|
|
561 ;; (unwritable (and buffer-file-name
|
|
562 ;; (not (file-writable-p buffer-file-name))))
|
|
563 (err))
|
|
564 ;; (if unwritable
|
|
565 ;; Commented error out since some people want to be able to create
|
|
566 ;; buttons within files which they have purposely marked read-only.
|
|
567 ;; (setq err
|
|
568 ;; (format "(ebut-modify): You are not allowed to modify '%s'."
|
|
569 ;; (file-name-nondirectory buffer-file-name))))
|
|
570 (if buffer-read-only
|
|
571 (setq err
|
|
572 (format
|
|
573 "Button buffer '%s' is read-only. Use %s to change it."
|
|
574 (buffer-name but-buf)
|
|
575 (hypb:cmd-key-string
|
|
576 (if (where-is-internal 'vc-toggle-read-only)
|
|
577 'vc-toggle-read-only 'toggle-read-only))
|
|
578 )))
|
|
579 (set-buffer obuf)
|
|
580 (if err (progn (pop-to-buffer but-buf) (hypb:error err)))))
|
|
581
|
|
582 (defun hui:ebut-buf (&optional prompt)
|
|
583 "Prompt for and return a buffer in which to place a button."
|
|
584 (let ((buf-name))
|
|
585 (while
|
|
586 (progn
|
|
587 (setq buf-name
|
|
588 (hargs:read-match
|
|
589 (or prompt "Button's buffer: ")
|
|
590 (delq nil
|
|
591 (mapcar
|
|
592 (function
|
|
593 (lambda (buf)
|
|
594 (let ((b (buffer-name buf)))
|
|
595 (if (and (not (string-match "mail\\*" b))
|
|
596 (not (string-match "\\*post-news\\*" b))
|
|
597 (string-match "\\`[* ]" b))
|
|
598 nil
|
|
599 (cons b nil)))))
|
|
600 (buffer-list)))
|
|
601 nil t (buffer-name) 'buffer))
|
|
602 (or (null buf-name) (equal buf-name "")))
|
|
603 (beep))
|
|
604 (get-buffer buf-name)))
|
|
605
|
|
606 (defun hui:ebut-delete-op (interactive but-key key-src)
|
|
607 "INTERACTIVEly or not deletes explicit Hyperbole button given by BUT-KEY in KEY-SRC.
|
|
608 KEY-SRC may be a buffer or a pathname, when nil the current buffer is used.
|
|
609 Returns t if button is deleted, signals error otherwise. If called
|
|
610 with INTERACTIVE non-nil, derives BUT-KEY from the button that point is
|
|
611 within."
|
|
612 (let ((buf (current-buffer)) (ebut))
|
|
613 (if (if interactive
|
|
614 (ebut:delete)
|
|
615 (cond ((or (null key-src) (and (bufferp key-src) (setq buf key-src)))
|
|
616 (setq ebut (ebut:get but-key key-src)))
|
|
617 ((and (stringp key-src)
|
|
618 (setq buf (find-file-noselect key-src)))
|
|
619 (setq ebut (ebut:get but-key buf)))
|
|
620 (t (hypb:error "(ebut-delete): Invalid key-src: '%s'." key-src)))
|
|
621 (if ebut
|
|
622 (ebut:delete ebut)
|
|
623 (hypb:error "(ebut-delete): No valid %s button in %s."
|
|
624 (ebut:key-to-label but-key) buf))
|
|
625 )
|
|
626 (progn (set-buffer buf)
|
|
627 (if interactive
|
|
628 (progn
|
|
629 (call-interactively 'hui:ebut-unmark)
|
|
630 (message "Button deleted."))
|
|
631 (hui:ebut-unmark but-key key-src))
|
|
632 (if (hmail:reader-p) (hmail:msg-narrow))
|
|
633 )
|
|
634 (hypb:error "(ebut-delete): You may not delete buttons from this buffer."))))
|
|
635
|
|
636 (defun hui:ebut-delimit (start end instance-str)
|
|
637 (hypb:error "(hui:ebut-delimit): Obsolete, use ebut:delimit instead."))
|
|
638
|
|
639 (defun hui:ebut-operate (curr-label new-label)
|
|
640 (hypb:error "(hui:ebut-operate): Obsolete, use ebut:operate instead."))
|
|
641
|
|
642 (defun hui:ebut-unmark (&optional but-key key-src directory)
|
|
643 "Remove delimiters from button given by BUT-KEY in KEY-SRC of DIRECTORY.
|
|
644 All args are optional, the current button and buffer file are the defaults."
|
|
645 (interactive)
|
|
646 (let ((form (function
|
|
647 (lambda ()
|
|
648 (let ((buffer-read-only) start end)
|
|
649 (setq start (match-beginning 0)
|
|
650 end (match-end 0))
|
|
651 (and (fboundp 'hproperty:but-delete)
|
|
652 (hproperty:but-delete start))
|
|
653 (skip-chars-backward " \t\n")
|
|
654 (skip-chars-backward "0-9")
|
|
655 (if (= (preceding-char) (string-to-char ebut:instance-sep))
|
|
656 (setq start (1- (point))))
|
|
657 (if (search-backward ebut:start (- (point) ebut:max-len) t)
|
|
658 (if current-prefix-arg
|
|
659 ;; Remove button label, delimiters and preceding
|
|
660 ;; space, if any.
|
|
661 (delete-region (max (point-min)
|
|
662 (1- (match-beginning 0)))
|
|
663 end)
|
|
664 ;;
|
|
665 ;; Remove button delimiters only.
|
|
666 ;;
|
|
667 ;; Remove button ending delimiter
|
|
668 (delete-region start end)
|
|
669 ;; Remove button starting delimiter
|
|
670 (delete-region (match-beginning 0)
|
|
671 (match-end 0)))))))))
|
|
672 (if (interactive-p)
|
|
673 (save-excursion
|
|
674 (if (search-forward ebut:end nil t) (funcall form)))
|
|
675 ;; Non-interactive invocation.
|
|
676 (let ((cur-p))
|
|
677 (if (and (or (null key-src) (eq key-src buffer-file-name))
|
|
678 (or (null directory) (eq directory default-directory)))
|
|
679 (setq cur-p t)
|
|
680 (set-buffer (find-file-noselect
|
|
681 (expand-file-name key-src directory))))
|
|
682 (save-excursion
|
|
683 (goto-char (point-min))
|
|
684 (if (re-search-forward (ebut:label-regexp but-key) nil t)
|
|
685 (progn (funcall form)
|
|
686 ;; If modified a buffer other than the current one,
|
|
687 ;; save it.
|
|
688 (or cur-p (save-buffer)))))))))
|
|
689
|
|
690 (defun hui:file-find (file-name)
|
|
691 "If FILE-NAME is readable, finds it, else signals an error."
|
|
692 (if (and (stringp file-name) (file-readable-p file-name))
|
|
693 (find-file file-name)
|
|
694 (hypb:error "(file-find): \"%s\" does not exist or is not readable."
|
|
695 file-name)))
|
|
696
|
|
697 (defun hui:hbut-term-highlight (start end)
|
|
698 "For terminals only: Emphasize a button spanning from START to END."
|
|
699 (save-restriction
|
|
700 (save-excursion
|
|
701 (goto-char start)
|
|
702 (narrow-to-region (point-min) start)
|
|
703 (sit-for 0)
|
|
704 (setq inverse-video t)
|
|
705 (goto-char (point-min))
|
|
706 (widen)
|
|
707 (narrow-to-region (point) end)
|
|
708 (sit-for 0)
|
|
709 (setq inverse-video nil)
|
|
710 )))
|
|
711
|
|
712 (defun hui:hbut-term-unhighlight (start end)
|
|
713 "For terminals only: Remove any emphasis from hyper-button at START to END."
|
|
714 (save-restriction
|
|
715 (save-excursion
|
|
716 (goto-char start)
|
|
717 (narrow-to-region (point-min) start)
|
|
718 (sit-for 0)
|
|
719 (setq inverse-video nil))))
|
|
720
|
|
721 (defun hui:help-ebut-highlight ()
|
|
722 "Highlight any explicit buttons in help buffer associated with current buffer."
|
|
723 (if (fboundp 'hproperty:but-create)
|
|
724 (save-excursion
|
|
725 (set-buffer
|
|
726 (get-buffer (hypb:help-buf-name)))
|
|
727 (hproperty:but-create))))
|
|
728
|
|
729 (defun hui:htype-delete (htype-sym)
|
|
730 "Deletes HTYPE-SYM from use in current Hyperbole session.
|
|
731 HTYPE-SYM must be redefined for use again."
|
|
732 (and htype-sym (symbolp htype-sym)
|
|
733 (let ((type
|
|
734 (intern (hargs:read-match
|
|
735 (concat "Delete from " (symbol-name htype-sym) ": ")
|
|
736 (mapcar 'list (htype:names htype-sym))
|
|
737 nil t nil htype-sym))))
|
|
738 (htype:delete type htype-sym))))
|
|
739
|
|
740 (defun hui:htype-help (htype-sym &optional no-sort)
|
|
741 "Displays documentation for types from HTYPE-SYM which match to a regexp.
|
|
742 Optional NO-SORT means display in decreasing priority order (natural order)."
|
|
743 (and htype-sym (symbolp htype-sym)
|
|
744 (let* ((tstr (symbol-name htype-sym))
|
|
745 (tprefix (concat tstr "::"))
|
|
746 (buf-name (hypb:help-buf-name (capitalize tstr)))
|
|
747 (temp-buffer-show-hook
|
|
748 (function
|
|
749 (lambda (buf)
|
|
750 (set-buffer buf) (goto-char (point-min))
|
|
751 (replace-regexp "^" " ") (goto-char (point-min))
|
|
752 (replace-string (concat " " tprefix) "")
|
|
753 (goto-char (point-min)) (set-buffer-modified-p nil)
|
|
754 (display-buffer buf nil))))
|
|
755 (temp-buffer-show-function temp-buffer-show-hook)
|
|
756 (names (htype:names htype-sym))
|
|
757 (term (hargs:read-match
|
|
758 (concat (capitalize tstr)
|
70
|
759 " to describe (RTN for all): ")
|
0
|
760 (mapcar 'list (cons "" names))
|
|
761 nil t nil htype-sym))
|
|
762 nm-list
|
|
763 doc-list)
|
|
764 (setq nm-list
|
|
765 (if (string= term "")
|
|
766 (let ((type-names
|
|
767 (mapcar (function (lambda (nm) (concat tprefix nm)))
|
|
768 names)))
|
|
769 (if no-sort type-names
|
|
770 (sort type-names 'string<)))
|
|
771 (cons (concat tprefix term) nil))
|
|
772 doc-list (delq nil (mapcar
|
|
773 (function
|
|
774 (lambda (name)
|
|
775 (let ((doc (documentation
|
|
776 (intern-soft name))))
|
|
777 (if doc (cons name doc)))))
|
|
778 nm-list)))
|
|
779 (with-output-to-temp-buffer buf-name
|
|
780 (mapcar (function (lambda (nm-doc-cons)
|
|
781 (princ (car nm-doc-cons)) (terpri)
|
|
782 (princ (cdr nm-doc-cons)) (terpri)))
|
|
783 doc-list)))))
|
|
784
|
|
785 (defun hui:key-dir (but-buf)
|
|
786 "Returns button key src directory based on BUT-BUF, a buffer."
|
|
787 (if (bufferp but-buf)
|
|
788 (let ((file (buffer-file-name but-buf)))
|
|
789 (if file
|
|
790 (file-name-directory (hpath:symlink-referent file))
|
|
791 (cdr (assq 'default-directory (buffer-local-variables but-buf)))))
|
|
792 (hypb:error "(hui:key-dir): '%s' is not a valid buffer.")))
|
|
793
|
|
794 (defun hui:key-src (but-buf)
|
|
795 "Returns button key src location based on BUT-BUF, a buffer.
|
|
796 This is BUT-BUF when button data is stored in the buffer and the
|
|
797 button's source file name when the button data is stored externally."
|
|
798 (save-excursion
|
|
799 (set-buffer but-buf)
|
|
800 (cond ((hmail:mode-is-p) but-buf)
|
|
801 ((hpath:symlink-referent (buffer-file-name but-buf)))
|
|
802 (t but-buf))))
|
|
803
|
|
804 (defun hui:link-create (modify but-window lbl-key but-loc but-dir type-and-args)
|
|
805 "Creates or modifies a new Hyperbole button.
|
|
806 If MODIFY is non-nil, modifies button at point in BUT-WINDOW,
|
|
807 otherwise, prompts for button label and creates a button.
|
|
808 LBL-KEY is internal form of button label. BUT-LOC is file or buffer
|
|
809 in which to create button. BUT-DIR is directory of BUT-LOC.
|
|
810 TYPE-AND-ARGS is the action type for the button followed by any arguments it requires."
|
|
811 (hattr:set 'hbut:current 'loc but-loc)
|
|
812 (hattr:set 'hbut:current 'dir but-dir)
|
|
813 (hattr:set 'hbut:current 'actype (intern-soft
|
|
814 (concat "actypes::"
|
|
815 (symbol-name
|
|
816 (car type-and-args)))))
|
|
817 (hattr:set 'hbut:current 'args (cdr type-and-args))
|
|
818
|
|
819 (select-window but-window)
|
|
820 (let ((label (ebut:key-to-label lbl-key)))
|
|
821 (ebut:operate label (if modify label)))
|
|
822 )
|
|
823
|
|
824 (defun hui:link-possible-types ()
|
|
825 "Returns list of possible link types for a Hyperbole button link to point.
|
|
826 Each list element is a list of the link type and any arguments it requires.
|
|
827
|
|
828 The link types considered are fixed. Defining new link types will not alter
|
|
829 the possible types. The code must be changed to do that.
|
|
830
|
|
831 Referent Context Possible Link Type Returned
|
|
832 ----------------------------------------------------
|
|
833 Explicit Button link-to-ebut
|
|
834 or
|
|
835 Info Node link-to-Info-node
|
|
836 or
|
|
837 Mail Reader Msg link-to-mail
|
|
838
|
|
839 Outline Regexp Prefix link-to-string-match
|
|
840 or
|
|
841 Directory Name link-to-directory
|
|
842 or
|
|
843 File Name link-to-file
|
|
844 or
|
|
845 Koutline Cell link-to-kcell
|
|
846 or
|
|
847 Buffer attached to File link-to-file
|
|
848 or
|
|
849 Buffer without File link-to-buffer-tmp
|
|
850
|
|
851 Elisp Buffer at Start
|
|
852 or End of Sexpression eval-elisp
|
|
853 "
|
|
854 (let (val)
|
|
855 (delq nil
|
|
856 (list (if (ebut:at-p)
|
|
857 (list 'link-to-ebut buffer-file-name (ebut:label-p)))
|
|
858 (cond ((eq major-mode 'Info-mode)
|
|
859 (let ((hargs:reading-p 'Info-node))
|
|
860 (list 'link-to-Info-node (hargs:at-p))))
|
|
861 ((hmail:reader-p)
|
|
862 (list 'link-to-mail
|
|
863 (list (rmail:msg-id-get) buffer-file-name)))
|
|
864 )
|
|
865 (cond
|
|
866 ;; If link is within an outline-regexp prefix, use
|
|
867 ;; a link-to-string-match.
|
|
868 ((and (boundp 'outline-regexp)
|
|
869 (stringp outline-regexp)
|
|
870 (save-excursion
|
|
871 (<= (point)
|
|
872 (progn
|
|
873 (beginning-of-line)
|
|
874 (if (looking-at outline-regexp)
|
|
875 (match-end 0)
|
|
876 0)))))
|
|
877 (save-excursion
|
|
878 (end-of-line)
|
|
879 (let ((heading (buffer-substring
|
|
880 (point)
|
|
881 (progn (beginning-of-line) (point))))
|
|
882 (occur 1))
|
|
883 (while (search-backward heading nil t)
|
|
884 (setq occur (1+ occur)))
|
|
885 (list 'link-to-string-match
|
|
886 heading occur buffer-file-name))))
|
|
887 ((let ((hargs:reading-p 'directory))
|
|
888 (setq val (hargs:at-p t)))
|
|
889 (list 'link-to-directory val))
|
|
890 ((let ((hargs:reading-p 'file))
|
|
891 (setq val (hargs:at-p t)))
|
|
892 (list 'link-to-file val (point)))
|
|
893 ((eq major-mode 'kotl-mode)
|
|
894 (list 'link-to-kcell buffer-file-name (kcell-view:idstamp)))
|
|
895 (buffer-file-name
|
|
896 (list 'link-to-file buffer-file-name (point)))
|
|
897 (t (list 'link-to-buffer-tmp (buffer-name)))
|
|
898 )
|
|
899 (and (fboundp 'smart-emacs-lisp-mode-p)
|
|
900 (smart-emacs-lisp-mode-p)
|
|
901 (or (= (char-syntax (following-char)) ?\()
|
|
902 (= (char-syntax (preceding-char)) ?\)))
|
|
903 (setq val (hargs:sexpression-p))
|
|
904 (list 'eval-elisp val))
|
|
905 ))))
|
|
906
|
|
907
|
|
908 ;;; ************************************************************************
|
|
909 ;;; Private variables
|
|
910 ;;; ************************************************************************
|
|
911
|
|
912
|
|
913 (defvar hui:ebut-label-prev nil
|
|
914 "String value of previous button name during an explicit button rename.
|
|
915 At other times, values must be nil.")
|
|
916
|
|
917 (provide 'hui)
|