|
0
|
1 ;;!emacs
|
|
|
2 ;;
|
|
|
3 ;; FILE: hargs.el
|
|
|
4 ;; SUMMARY: Obtains user input through Emacs for Hyperbole
|
|
|
5 ;; USAGE: GNU Emacs Lisp Library
|
|
|
6 ;; KEYWORDS: extensions, hypermedia
|
|
|
7 ;;
|
|
|
8 ;; AUTHOR: Bob Weiner
|
|
|
9 ;; ORG: Brown U.
|
|
|
10 ;;
|
|
|
11 ;; ORIG-DATE: 31-Oct-91 at 23:17:35
|
|
|
12 ;; LAST-MOD: 11-Sep-95 at 16:34:32 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 should be used for any interactive prompting and
|
|
|
23 ;; argument reading that Hyperbole does through Emacs.
|
|
|
24 ;;
|
|
|
25 ;; 'hargs:iform-read' provides a complete Lisp-based replacement for
|
|
|
26 ;; interactive argument reading (most of what 'call-interactively' does).
|
|
|
27 ;; It also supports prompting for new argument values with defaults drawn
|
|
|
28 ;; from current button arguments. A few extensions to interactive argument
|
|
|
29 ;; types are also provided, see 'hargs:iforms-extensions' for details.
|
|
|
30 ;;
|
|
|
31 ;; DESCRIP-END.
|
|
|
32
|
|
|
33 ;;; ************************************************************************
|
|
|
34 ;;; Other required Elisp libraries
|
|
|
35 ;;; ************************************************************************
|
|
|
36
|
|
|
37 (require 'hpath)
|
|
|
38 (require 'set)
|
|
|
39
|
|
|
40 ;;; ************************************************************************
|
|
|
41 ;;; Public variables
|
|
|
42 ;;; ************************************************************************
|
|
|
43
|
|
|
44 (defvar hargs:reading-p nil
|
|
|
45 "t only when Hyperbole is prompting user for input, else nil.")
|
|
|
46
|
|
|
47 ;;; ************************************************************************
|
|
|
48 ;;; Public functions
|
|
|
49 ;;; ************************************************************************
|
|
|
50
|
|
|
51 (defun hargs:actype-get (actype &optional modifying)
|
|
|
52 "Interactively gets and returns list of arguments for ACTYPE's parameters.
|
|
|
53 Current button is being modified when MODIFYING is non-nil."
|
|
|
54 (hargs:action-get (actype:action actype) modifying))
|
|
|
55
|
|
|
56 (defun hargs:at-p (&optional no-default)
|
|
|
57 "Returns thing at point, if of hargs:reading-p type, or default.
|
|
|
58 If optional argument NO-DEFAULT is non-nil, nil is returned instead of any
|
|
|
59 default values.
|
|
|
60
|
|
|
61 Caller should have checked whether an argument is presently being read
|
|
|
62 and set 'hargs:reading-p' to an appropriate argument type.
|
|
|
63 Handles all of the interactive argument types that 'hargs:iform-read' does."
|
|
|
64 (cond ((and (eq hargs:reading-p 'kcell)
|
|
|
65 (eq major-mode 'kotl-mode)
|
|
|
66 (not (looking-at "^$")))
|
|
|
67 (kcell-view:label))
|
|
|
68 ((and (eq hargs:reading-p 'klink)
|
|
|
69 (not (looking-at "^$")))
|
|
|
70 (if (eq major-mode 'kotl-mode)
|
|
|
71 (kcell-view:reference
|
|
|
72 nil (and (boundp 'default-dir) default-dir))
|
|
|
73 (let ((hargs:reading-p 'file))
|
|
|
74 (list (hargs:at-p)))))
|
|
|
75 ((eolp) nil)
|
|
|
76 ((and (eq hargs:reading-p 'hmenu)
|
|
|
77 (eq (selected-window) (minibuffer-window)))
|
|
|
78 (save-excursion
|
|
|
79 (char-to-string
|
|
|
80 (if (search-backward " " nil t)
|
|
|
81 (progn (skip-chars-forward " ")
|
|
|
82 (following-char))
|
|
|
83 0))))
|
|
|
84 ((hargs:completion t))
|
|
|
85 ((eq hargs:reading-p 'ebut) (ebut:label-p 'as-label))
|
|
|
86 ((ebut:label-p) nil)
|
|
|
87 ((eq hargs:reading-p 'file)
|
|
|
88 (cond ((hpath:at-p nil 'non-exist))
|
|
|
89 ((eq major-mode 'dired-mode)
|
|
|
90 (let ((file (dired-get-filename nil t)))
|
|
|
91 (and file (hpath:absolute-to file))))
|
|
|
92 ((eq major-mode 'monkey-mode)
|
|
|
93 (let ((file (monkey-filename t)))
|
|
|
94 (and file (hpath:absolute-to file))))
|
|
|
95 ;; Delimited file name.
|
|
|
96 ((hpath:at-p 'file))
|
|
|
97 ;; Unquoted remote file name.
|
|
|
98 ((hpath:is-p (hpath:ange-ftp-at-p) 'file))
|
|
|
99 (no-default nil)
|
|
|
100 ((buffer-file-name))
|
|
|
101 ))
|
|
|
102 ((eq hargs:reading-p 'directory)
|
|
|
103 (cond ((hpath:at-p 'directory 'non-exist))
|
|
|
104 ((eq major-mode 'dired-mode)
|
|
|
105 (let ((dir (dired-get-filename nil t)))
|
|
|
106 (and dir (setq dir (hpath:absolute-to dir))
|
|
|
107 (file-directory-p dir) dir)))
|
|
|
108 ((eq major-mode 'monkey-mode)
|
|
|
109 (let ((dir (monkey-filename t)))
|
|
|
110 (and dir (setq dir (hpath:absolute-to dir))
|
|
|
111 (file-directory-p dir) dir)))
|
|
|
112 ;; Delimited directory name.
|
|
|
113 ((hpath:at-p 'directory))
|
|
|
114 ;; Unquoted remote directory name.
|
|
|
115 ((hpath:is-p (hpath:ange-ftp-at-p) 'directory))
|
|
|
116 (no-default nil)
|
|
|
117 (default-directory)
|
|
|
118 ))
|
|
|
119 ((eq hargs:reading-p 'string)
|
|
|
120 (or (hargs:delimited "\"" "\"") (hargs:delimited "'" "'")
|
|
|
121 (hargs:delimited "`" "'")
|
|
|
122 ))
|
|
|
123 ((or (eq hargs:reading-p 'actype)
|
|
|
124 (eq hargs:reading-p 'actypes))
|
|
|
125 (let ((name (find-tag-default)))
|
|
|
126 (car (set:member name (htype:names 'actypes)))))
|
|
|
127 ((or (eq hargs:reading-p 'ibtype)
|
|
|
128 (eq hargs:reading-p 'ibtypes))
|
|
|
129 (let ((name (find-tag-default)))
|
|
|
130 (car (set:member name (htype:names 'ibtypes)))))
|
|
|
131 ((eq hargs:reading-p 'sexpression) (hargs:sexpression-p))
|
|
|
132 ((eq hargs:reading-p 'Info-node)
|
|
|
133 (and (eq major-mode 'Info-mode)
|
|
|
134 (let ((file (hpath:relative-to Info-current-file
|
|
|
135 Info-directory)))
|
|
|
136 (and (stringp file) (string-match "^\\./" file)
|
|
|
137 (setq file (substring file (match-end 0))))
|
|
|
138 (concat "(" file ")" Info-current-node))))
|
|
|
139 ((eq hargs:reading-p 'mail)
|
|
|
140 (and (hmail:reader-p) buffer-file-name
|
|
|
141 (prin1-to-string (list (rmail:msg-id-get) buffer-file-name))))
|
|
|
142 ((eq hargs:reading-p 'symbol)
|
|
|
143 (let ((sym (find-tag-default)))
|
|
|
144 (if (or (fboundp sym) (boundp sym)) sym)))
|
|
|
145 ((eq hargs:reading-p 'buffer)
|
|
|
146 (find-tag-default))
|
|
|
147 ((eq hargs:reading-p 'character)
|
|
|
148 (following-char))
|
|
|
149 ((eq hargs:reading-p 'key)
|
|
|
150 (require 'hib-kbd)
|
|
|
151 (let ((key-seq (hbut:label-p 'as-label "{" "}")))
|
|
|
152 (and key-seq (kbd-key:normalize key-seq))))
|
|
|
153 ((eq hargs:reading-p 'integer)
|
|
|
154 (save-excursion (skip-chars-backward "-0-9")
|
|
|
155 (if (looking-at "-?[0-9]+")
|
|
|
156 (read (current-buffer)))))
|
|
|
157 ))
|
|
|
158
|
|
|
159 (defun hargs:completion (&optional no-insert)
|
|
|
160 "If in the completions buffer, return completion at point. Also insert unless optional NO-INSERT is non-nil.
|
|
|
161 Insert in minibuffer if active or in other window if minibuffer is inactive."
|
|
|
162 (interactive '(nil))
|
|
|
163 (if (or (equal (buffer-name) "*Completions*") ;; V19
|
|
|
164 (equal (buffer-name) " *Completions*")) ;; V18
|
|
|
165 (let ((opoint (point))
|
|
|
166 (owind (selected-window)))
|
|
|
167 (if (re-search-backward "^\\|[ \t][ \t]" nil t)
|
|
|
168 (let ((insert-window
|
|
|
169 (cond ((> (minibuffer-depth) 0)
|
|
|
170 (minibuffer-window))
|
|
|
171 ((not (eq (selected-window) (next-window nil)))
|
|
|
172 (next-window nil))))
|
|
|
173 (bury-completions)
|
|
|
174 (entry))
|
|
|
175 (skip-chars-forward " \t")
|
|
|
176 (if (and insert-window (looking-at "[^\t\n]+"))
|
|
|
177 (progn (setq entry (buffer-substring (match-beginning 0)
|
|
|
178 (match-end 0)))
|
|
|
179 (select-window insert-window)
|
|
|
180 (let ((str (buffer-substring
|
|
|
181 (point)
|
|
|
182 (save-excursion (beginning-of-line)
|
|
|
183 (point)))))
|
|
|
184 (if (and (eq (selected-window) (minibuffer-window)))
|
|
|
185 ;; If entry matches tail of minibuffer prefix
|
|
|
186 ;; already, then return minibuffer contents
|
|
|
187 ;; as entry.
|
|
|
188 (progn
|
|
|
189 (setq entry
|
|
|
190 (if (string-match
|
|
|
191 (concat
|
|
|
192 (regexp-quote entry) "\\'")
|
|
|
193 str)
|
|
|
194 str
|
|
|
195 (concat
|
|
|
196 (if (string-match
|
|
|
197 "/[^/]+\\'" str)
|
|
|
198 (substring
|
|
|
199 str 0 (1+ (match-beginning 0)))
|
|
|
200 str)
|
|
|
201 entry)))
|
|
|
202 (or no-insert (if entry (insert entry)))
|
|
|
203 )
|
|
|
204 ;; In buffer, non-minibuffer completion.
|
|
|
205 ;; Only insert entry if last buffer line does
|
|
|
206 ;; not end in entry.
|
|
|
207 (cond (no-insert)
|
|
|
208 ((or (string-match
|
|
|
209 (concat
|
|
|
210 (regexp-quote entry) "\\'") str)
|
|
|
211 (null entry))
|
|
|
212 (setq bury-completions t))
|
|
|
213 (t (insert entry)))
|
|
|
214 ))))
|
|
|
215 (select-window owind) (goto-char opoint)
|
|
|
216 (if bury-completions
|
|
|
217 (progn (bury-buffer nil) (delete-window)))
|
|
|
218 entry)))))
|
|
|
219
|
|
|
220 (defun hargs:iform-read (iform &optional modifying)
|
|
|
221 "Reads action arguments according to IFORM, a list with car = 'interactive.
|
|
|
222 Optional MODIFYING non-nil indicates current button is being modified, so
|
|
|
223 button's current values should be presented as defaults. Otherwise, uses
|
|
|
224 hargs:defaults as list of defaults, if any.
|
|
|
225 See also documentation for 'interactive'."
|
|
|
226 ;; This is mostly a translation of 'call-interactively' to Lisp.
|
|
|
227 ;;
|
|
|
228 ;; Save this now, since use of minibuffer will clobber it.
|
|
|
229 (setq prefix-arg current-prefix-arg)
|
|
|
230 (if (not (and (listp iform) (eq (car iform) 'interactive)))
|
|
|
231 (error
|
|
|
232 "(hargs:iform-read): arg must be a list whose car = 'interactive.")
|
|
|
233 (setq iform (car (cdr iform)))
|
|
|
234 (if (or (null iform) (and (stringp iform) (equal iform "")))
|
|
|
235 nil
|
|
|
236 (let ((prev-reading-p hargs:reading-p))
|
|
|
237 (unwind-protect
|
|
|
238 (progn
|
|
|
239 (setq hargs:reading-p t)
|
|
|
240 (if (not (stringp iform))
|
|
|
241 (let ((defaults (if modifying
|
|
|
242 (hattr:get 'hbut:current 'args)
|
|
|
243 (and (boundp 'hargs:defaults)
|
|
|
244 (listp hargs:defaults)
|
|
|
245 hargs:defaults)
|
|
|
246 )))
|
|
|
247 (eval iform))
|
|
|
248 (let ((i 0) (start 0) (end (length iform))
|
|
|
249 (ientry) (results) (val) (default)
|
|
|
250 (defaults (if modifying
|
|
|
251 (hattr:get 'hbut:current 'args)
|
|
|
252 (and (boundp 'hargs:defaults)
|
|
|
253 (listp hargs:defaults)
|
|
|
254 hargs:defaults)
|
|
|
255 )))
|
|
|
256 ;;
|
|
|
257 ;; Handle special initial interactive string chars.
|
|
|
258 ;;
|
|
|
259 ;; '*' means error if buffer is read-only.
|
|
|
260 ;; Notion of when action cannot be performed due to
|
|
|
261 ;; read-only buffer is view-specific, so here, we just
|
|
|
262 ;; ignore a read-only specification since it is checked for
|
|
|
263 ;; earlier by any ebut edit code.
|
|
|
264 ;;
|
|
|
265 ;; '@' means select window of last mouse event.
|
|
|
266 ;;
|
|
|
267 ;; '_' means keep region in same state (active or inactive)
|
|
|
268 ;; after this command. (XEmacs only.)
|
|
|
269 ;;
|
|
|
270 (while (cond
|
|
|
271 ((eq (aref iform i) ?*))
|
|
|
272 ((eq (aref iform i) ?@)
|
|
|
273 (hargs:select-event-window)
|
|
|
274 t)
|
|
|
275 ((eq (aref iform i) ?_)
|
|
|
276 (setq zmacs-region-stays t)))
|
|
|
277 (setq i (1+ i) start i))
|
|
|
278 ;;
|
|
|
279 (while (and (< start end)
|
|
|
280 (string-match "\n\\|\\'" iform start))
|
|
|
281 (setq start (match-end 0)
|
|
|
282 ientry (substring iform i (match-beginning 0))
|
|
|
283 i start
|
|
|
284 default (car defaults)
|
|
|
285 default (if (or (null default) (stringp default))
|
|
|
286 default
|
|
|
287 (prin1-to-string default))
|
|
|
288 val (hargs:get ientry default (car results))
|
|
|
289 defaults (cdr defaults)
|
|
|
290 results (cond ((or (null val) (not (listp val)))
|
|
|
291 (cons val results))
|
|
|
292 ;; Is a list of args?
|
|
|
293 ((eq (car val) 'args)
|
|
|
294 (append (nreverse (cdr val)) results))
|
|
|
295 (t;; regular list value
|
|
|
296 (cons val results)))))
|
|
|
297 (nreverse results))))
|
|
|
298 (setq hargs:reading-p prev-reading-p))))))
|
|
|
299
|
|
|
300 (defun hargs:read (prompt &optional predicate default err val-type)
|
|
|
301 "PROMPTs without completion for a value matching PREDICATE and returns it.
|
|
|
302 PREDICATE is an optional boolean function of one argument. Optional DEFAULT
|
|
|
303 is a string to insert after PROMPT as the default return value. Optional
|
|
|
304 ERR is a string to display temporarily when an invalid value is given.
|
|
|
305 Optional VAL-TYPE is a symbol indicating type of value to be read. If
|
|
|
306 VAL-TYPE is not equal to 'sexpression' or 'klink' and is non-nil, value is
|
|
|
307 returned as a string."
|
|
|
308 (let ((bad-val) (val) (stringify)
|
|
|
309 (prev-reading-p hargs:reading-p) (read-func)
|
|
|
310 (owind (selected-window))
|
|
|
311 (obuf (current-buffer)))
|
|
|
312 (unwind-protect
|
|
|
313 (progn
|
|
|
314 (cond ((or (null val-type) (eq val-type 'sexpression))
|
|
|
315 (setq read-func 'read-minibuffer
|
|
|
316 hargs:reading-p 'sexpression))
|
|
|
317 (t (setq read-func 'read-string hargs:reading-p val-type
|
|
|
318 stringify t)))
|
|
|
319 (while (progn (and default (not (stringp default))
|
|
|
320 (setq default (prin1-to-string default)))
|
|
|
321 (condition-case ()
|
|
|
322 (or bad-val
|
|
|
323 (setq val (funcall read-func prompt default)))
|
|
|
324 (error (setq bad-val t)))
|
|
|
325 (if bad-val t
|
|
|
326 (and stringify
|
|
|
327 ;; Remove any double quoting of strings.
|
|
|
328 (string-match
|
|
|
329 "\\`\"\\([^\"]*\\)\"\\'" val)
|
|
|
330 (setq val (substring val (match-beginning 1)
|
|
|
331 (match-end 1))))
|
|
|
332 (and predicate (not (funcall predicate val)))))
|
|
|
333 (if bad-val (setq bad-val nil) (setq default val))
|
|
|
334 (beep)
|
|
|
335 (if err (progn (message err) (sit-for 3))))
|
|
|
336 val)
|
|
|
337 (setq hargs:reading-p prev-reading-p)
|
|
|
338 (select-window owind)
|
|
|
339 (switch-to-buffer obuf)
|
|
|
340 )))
|
|
|
341
|
|
|
342 (defun hargs:read-match (prompt table &optional
|
|
|
343 predicate must-match default val-type)
|
|
|
344 "PROMPTs with completion for a value in TABLE and returns it.
|
|
|
345 TABLE is an alist where each element's car is a string, or it may be an
|
|
|
346 obarray for symbol-name completion.
|
|
|
347 Optional PREDICATE limits table entries to match against.
|
|
|
348 Optional MUST-MATCH means value returned must be from TABLE.
|
|
|
349 Optional DEFAULT is a string inserted after PROMPT as default value.
|
|
|
350 Optional VAL-TYPE is a symbol indicating type of value to be read."
|
|
|
351 (if (and must-match (null table))
|
|
|
352 nil
|
|
|
353 (let ((prev-reading-p hargs:reading-p)
|
|
|
354 (completion-ignore-case t)
|
|
|
355 (owind (selected-window))
|
|
|
356 (obuf (current-buffer)))
|
|
|
357 (unwind-protect
|
|
|
358 (progn
|
|
|
359 (setq hargs:reading-p (or val-type t))
|
|
|
360 (completing-read prompt table predicate must-match default))
|
|
|
361 (setq hargs:reading-p prev-reading-p)
|
|
|
362 (select-window owind)
|
|
|
363 (switch-to-buffer obuf)
|
|
|
364 ))))
|
|
|
365
|
|
|
366 (defun hargs:select-p (&optional value assist-flag)
|
|
|
367 "Returns optional VALUE or value selected at point if any, else nil.
|
|
|
368 If value is the same as the contents of the minibuffer, it is used as
|
|
|
369 the current minibuffer argument, otherwise, the minibuffer is erased
|
|
|
370 and value is inserted there.
|
|
|
371 Optional ASSIST-FLAG non-nil triggers display of Hyperbole menu item help when
|
|
|
372 appropriate."
|
|
|
373 (if (and (> (minibuffer-depth) 0) (or value (setq value (hargs:at-p))))
|
|
|
374 (let ((owind (selected-window)) (back-to)
|
|
|
375 (str-value (and value (format "%s" value))))
|
|
|
376 (unwind-protect
|
|
|
377 (progn
|
|
|
378 (select-window (minibuffer-window))
|
|
|
379 (set-buffer (window-buffer (minibuffer-window)))
|
|
|
380 (cond
|
|
|
381 ;; Selecting a menu item
|
|
|
382 ((eq hargs:reading-p 'hmenu)
|
|
|
383 (if assist-flag (setq hargs:reading-p 'hmenu-help))
|
|
|
384 (hui:menu-enter str-value))
|
|
|
385 ;; Use value for parameter.
|
|
|
386 ((string= str-value (buffer-string))
|
|
|
387 (exit-minibuffer))
|
|
|
388 ;; Clear minibuffer and insert value.
|
|
|
389 (t (setq buffer-read-only nil)
|
|
|
390 (erase-buffer) (insert str-value)
|
|
|
391 (setq back-to t)))
|
|
|
392 value)
|
|
|
393 (if back-to (select-window owind))))))
|
|
|
394
|
|
|
395 ;;; ************************************************************************
|
|
|
396 ;;; Private functions
|
|
|
397 ;;; ************************************************************************
|
|
|
398
|
|
|
399 ;;; From etags.el, so don't have to load the whole thing.
|
|
|
400 (or (fboundp 'find-tag-default)
|
|
|
401 (defun find-tag-default ()
|
|
|
402 (or (and (boundp 'find-tag-default-hook)
|
|
|
403 (not (memq find-tag-default-hook '(nil find-tag-default)))
|
|
|
404 (condition-case data
|
|
|
405 (funcall find-tag-default-hook)
|
|
|
406 (error
|
|
|
407 (message "value of find-tag-default-hook signalled error: %s"
|
|
|
408 data)
|
|
|
409 (sit-for 1)
|
|
|
410 nil)))
|
|
|
411 (save-excursion
|
|
|
412 (if (not (memq (char-syntax (preceding-char)) '(?w ?_)))
|
|
|
413 (while (not (looking-at "\\sw\\|\\s_\\|\\'"))
|
|
|
414 (forward-char 1)))
|
|
|
415 (while (looking-at "\\sw\\|\\s_")
|
|
|
416 (forward-char 1))
|
|
|
417 (if (re-search-backward "\\sw\\|\\s_" nil t)
|
|
|
418 (regexp-quote
|
|
|
419 (progn (forward-char 1)
|
|
|
420 (buffer-substring (point)
|
|
|
421 (progn (forward-sexp -1)
|
|
|
422 (while (looking-at "\\s'")
|
|
|
423 (forward-char 1))
|
|
|
424 (point)))))
|
|
|
425 nil)))))
|
|
|
426
|
|
|
427 (defun hargs:action-get (action modifying)
|
|
|
428 "Interactively gets list of arguments for ACTION's parameters.
|
|
|
429 Current button is being modified when MODIFYING is non-nil.
|
|
|
430 Returns nil if ACTION is not a list or byte-code object, has no interactive
|
|
|
431 form or takes no arguments."
|
|
|
432 (and (or (hypb:v19-byte-code-p action) (listp action))
|
|
|
433 (let ((interactive-form (action:commandp action)))
|
|
|
434 (if interactive-form
|
|
|
435 (action:path-args-rel
|
|
|
436 (hargs:iform-read interactive-form modifying))))))
|
|
|
437
|
|
|
438 (defun hargs:delimited (start-delim end-delim
|
|
|
439 &optional start-regexp-flag end-regexp-flag)
|
|
|
440 "Returns a single line, delimited argument that point is within, or nil.
|
|
|
441 START-DELIM and END-DELIM are strings that specify the argument delimiters.
|
|
|
442 With optional START-REGEXP-FLAG non-nil, START-DELIM is treated as a regular
|
|
|
443 expression. END-REGEXP-FLAG is similar."
|
|
|
444 (let* ((opoint (point))
|
|
|
445 (limit (if start-regexp-flag opoint
|
|
|
446 (+ opoint (1- (length start-delim)))))
|
|
|
447 (start-search-func (if start-regexp-flag 're-search-forward
|
|
|
448 'search-forward))
|
|
|
449 (end-search-func (if end-regexp-flag 're-search-forward
|
|
|
450 'search-forward))
|
|
|
451 start end)
|
|
|
452 (save-excursion
|
|
|
453 (beginning-of-line)
|
|
|
454 (while (and (setq start (funcall start-search-func start-delim limit t))
|
|
|
455 (< (point) opoint)
|
|
|
456 ;; This is not to find the real end delimiter but to find
|
|
|
457 ;; end delimiters that precede the current argument and are
|
|
|
458 ;; therefore false matches, hence the search is limited to
|
|
|
459 ;; prior to the original point.
|
|
|
460 (funcall end-search-func end-delim opoint t))
|
|
|
461 (setq start nil))
|
|
|
462 (if start
|
|
|
463 (progn
|
|
|
464 (end-of-line) (setq limit (1+ (point)))
|
|
|
465 (goto-char opoint)
|
|
|
466 (and (funcall end-search-func end-delim limit t)
|
|
|
467 (setq end (match-beginning 0))
|
|
|
468 (buffer-substring start end)))))))
|
|
|
469
|
|
|
470 (defun hargs:get (interactive-entry &optional default prior-arg)
|
|
|
471 "Prompts for an argument, if need be, from INTERACTIVE-ENTRY, a string.
|
|
|
472 Optional DEFAULT is inserted after prompt.
|
|
|
473 First character of INTERACTIVE-ENTRY must be a command character from
|
|
|
474 the list in the documentation for 'interactive' or a `+' which indicates that
|
|
|
475 the following character is a Hyperbole interactive extension command
|
|
|
476 character.
|
|
|
477
|
|
|
478 May return a single value or a list of values, in which case the first
|
|
|
479 element of the list is always the symbol 'args."
|
|
|
480 (let (func cmd prompt)
|
|
|
481 (cond ((or (null interactive-entry) (equal interactive-entry ""))
|
|
|
482 (error "(hargs:get): Empty interactive-entry arg."))
|
|
|
483 ((= (aref interactive-entry 0) ?+)
|
|
|
484 ;; Hyperbole / user extension command character. The next
|
|
|
485 ;; character is the actual command character.
|
|
|
486 (setq cmd (aref interactive-entry 1)
|
|
|
487 prompt (format (substring interactive-entry 2) prior-arg)
|
|
|
488 func (if (< cmd (length hargs:iform-extensions-vector))
|
|
|
489 (aref hargs:iform-extensions-vector cmd)))
|
|
|
490 (if func
|
|
|
491 (funcall func prompt default)
|
|
|
492 (error
|
|
|
493 "(hargs:get): Bad interactive-entry extension character: '%c'."
|
|
|
494 cmd)))
|
|
|
495 (t (setq cmd (aref interactive-entry 0)
|
|
|
496 prompt
|
|
|
497 (format (substring interactive-entry 1) prior-arg)
|
|
|
498 func (if (< cmd (length hargs:iform-vector))
|
|
|
499 (aref hargs:iform-vector cmd)))
|
|
|
500 (if func
|
|
|
501 (funcall func prompt default)
|
|
|
502 (error
|
|
|
503 "(hargs:get): Bad interactive-entry command character: '%c'."
|
|
|
504 cmd))))))
|
|
|
505
|
|
|
506 (defun hargs:make-iform-vector (iform-alist)
|
|
|
507 "Return a vector built from IFORM-ALIST used for looking up interactive command code characters."
|
|
|
508 ;; Vector needs to have 1 more elts than the highest char code for
|
|
|
509 ;; interactive commands.
|
|
|
510 (let* ((size (1+ (car (sort (mapcar 'car iform-alist) '>))))
|
|
|
511 (vec (make-vector size nil)))
|
|
|
512 (mapcar (function
|
|
|
513 (lambda (elt)
|
|
|
514 (aset vec (car elt)
|
|
|
515 (` (lambda (prompt default)
|
|
|
516 (setq hargs:reading-p '(, (car (cdr elt))))
|
|
|
517 (, (cdr (cdr elt))))))))
|
|
|
518 iform-alist)
|
|
|
519 vec))
|
|
|
520
|
|
|
521 (defun hargs:prompt (prompt default &optional default-prompt)
|
|
|
522 "Returns string of PROMPT including DEFAULT.
|
|
|
523 Optional DEFAULT-PROMPT is used to describe default value."
|
|
|
524 (if default
|
|
|
525 (format "%s(%s%s%s) " prompt (or default-prompt "default")
|
|
|
526 (if (equal default "") "" " ")
|
|
|
527 default)
|
|
|
528 prompt))
|
|
|
529
|
|
|
530 (defun hargs:select-event-window ()
|
|
|
531 "Select window, if any, that mouse was over during last event."
|
|
|
532 (if hyperb:lemacs-p
|
|
|
533 (if current-mouse-event
|
|
|
534 (select-window
|
|
|
535 (or (event-window current-mouse-event)
|
|
|
536 (selected-window))))
|
|
|
537 (let* ((event last-command-event)
|
|
|
538 (window (posn-window (event-start event))))
|
|
|
539 (if (and (eq window (minibuffer-window))
|
|
|
540 (not (minibuffer-window-active-p
|
|
|
541 (minibuffer-window))))
|
|
|
542 (error "Attempt to select inactive minibuffer window")
|
|
|
543 (select-window
|
|
|
544 (or window (selected-window)))))))
|
|
|
545
|
|
|
546 (defun hargs:sexpression-p (&optional no-recurse)
|
|
|
547 "Returns an sexpression at point as a string.
|
|
|
548 If point follows an sexpression end character, the preceding sexpression
|
|
|
549 is returned. If point precedes an sexpression start character, the
|
|
|
550 following sexpression is returned. Otherwise, the innermost sexpression
|
|
|
551 that point is within is returned or nil if none."
|
|
|
552 (save-excursion
|
|
|
553 (condition-case ()
|
|
|
554 (let ((not-quoted
|
|
|
555 '(not (and (= (char-syntax (char-after (- (point) 2))) ?\\)
|
|
|
556 (/= (char-syntax (char-after (- (point) 3))) ?\\)))))
|
|
|
557 (cond ((and (= (char-syntax (preceding-char)) ?\))
|
|
|
558 ;; Ignore quoted end chars.
|
|
|
559 (eval not-quoted))
|
|
|
560 (buffer-substring (point)
|
|
|
561 (progn (forward-sexp -1) (point))))
|
|
|
562 ((and (= (char-syntax (following-char)) ?\()
|
|
|
563 ;; Ignore quoted begin chars.
|
|
|
564 (eval not-quoted))
|
|
|
565 (buffer-substring (point)
|
|
|
566 (progn (forward-sexp) (point))))
|
|
|
567 (no-recurse nil)
|
|
|
568 (t (save-excursion (up-list 1) (hargs:sexpression-p t)))))
|
|
|
569 (error nil))))
|
|
|
570
|
|
|
571 ;;; ************************************************************************
|
|
|
572 ;;; Private variables
|
|
|
573 ;;; ************************************************************************
|
|
|
574
|
|
|
575 (defvar hargs:iforms nil
|
|
|
576 "Alist of (interactive-cmd-chr . (argument-type . get-argument-form)) elts.")
|
|
|
577 (setq hargs:iforms
|
|
|
578 '(
|
|
|
579 ;; Get function symbol.
|
|
|
580 (?a . (symbol .
|
|
|
581 (intern (completing-read prompt obarray 'fboundp t default))))
|
|
|
582 ;; Get name of existing buffer.
|
|
|
583 (?b . (buffer .
|
|
|
584 (progn
|
|
|
585 (or default (setq default (other-buffer (current-buffer))))
|
|
|
586 (read-buffer prompt default t))))
|
|
|
587 ;; Get name of possibly nonexistent buffer.
|
|
|
588 (?B . (buffer .
|
|
|
589 (progn
|
|
|
590 (or default (setq default (other-buffer (current-buffer))))
|
|
|
591 (read-buffer prompt default nil))))
|
|
|
592 ;; Get character.
|
|
|
593 (?c . (character .
|
|
|
594 (progn (message
|
|
|
595 (if default
|
|
|
596 (hargs:prompt prompt
|
|
|
597 (if (integerp default)
|
|
|
598 (char-to-string default)
|
|
|
599 default)
|
|
|
600 "Curr:")
|
|
|
601 prompt))
|
|
|
602 (char-to-string (read-char)))))
|
|
|
603 ;; Get symbol for interactive function, a command.
|
|
|
604 (?C . (symbol .
|
|
|
605 (intern
|
|
|
606 (completing-read prompt obarray 'commandp t default))))
|
|
|
607 ;; Get value of point; does not do I/O.
|
|
|
608 (?d . (integer . (point)))
|
|
|
609 ;; Get directory name.
|
|
|
610 (?D . (directory .
|
|
|
611 (progn
|
|
|
612 (or default (setq default default-directory))
|
|
|
613 (read-file-name prompt default default 'existing))))
|
|
|
614 ;; Get existing file name.
|
|
|
615 (?f . (file .
|
|
|
616 (read-file-name prompt default default
|
|
|
617 (if (eq system-type 'vax-vms)
|
|
|
618 nil 'existing))))
|
|
|
619 ;; Get possibly nonexistent file name.
|
|
|
620 (?F . (file . (read-file-name prompt default default nil)))
|
|
|
621 ;; Get key sequence.
|
|
|
622 (?k . (key .
|
|
|
623 (key-description (read-key-sequence
|
|
|
624 (if default
|
|
|
625 (hargs:prompt prompt default "Curr:")
|
|
|
626 prompt)))))
|
|
|
627 ;; Get key sequence without converting uppercase or shifted
|
|
|
628 ;; function keys to their unshifted equivalents.
|
|
|
629 (?K . (key .
|
|
|
630 (key-description (read-key-sequence
|
|
|
631 (if default
|
|
|
632 (hargs:prompt prompt default "Curr:")
|
|
|
633 prompt)
|
|
|
634 nil t))))
|
|
|
635 ;; Get value of mark. Does not do I/O.
|
|
|
636 (?m . (integer . (marker-position (hypb:mark-marker t))))
|
|
|
637 ;; Get numeric prefix argument or a number from the minibuffer.
|
|
|
638 (?N . (integer .
|
|
|
639 (if prefix-arg
|
|
|
640 (prefix-numeric-value prefix-arg)
|
|
|
641 (let ((arg))
|
|
|
642 (while (not (integerp
|
|
|
643 (setq arg (read-minibuffer prompt default))))
|
|
|
644 (beep))
|
|
|
645 arg))))
|
|
|
646 ;; Get number from minibuffer.
|
|
|
647 (?n . (integer .
|
|
|
648 (let ((arg))
|
|
|
649 (while (not (integerp
|
|
|
650 (setq arg (read-minibuffer prompt default))))
|
|
|
651 (beep))
|
|
|
652 arg)))
|
|
|
653 ;; Get numeric prefix argument. No I/O.
|
|
|
654 (?p . (prefix-arg .
|
|
|
655 (prefix-numeric-value prefix-arg)))
|
|
|
656 ;; Get prefix argument in raw form. No I/O.
|
|
|
657 (?P . (prefix-arg . prefix-arg))
|
|
|
658 ;; Get region, point and mark as 2 args. No I/O
|
|
|
659 (?r . (region .
|
|
|
660 (if (marker-position (hypb:mark-marker t))
|
|
|
661 (list 'args (min (point) (hypb:mark t))
|
|
|
662 (max (point) (hypb:mark t)))
|
|
|
663 (list 'args nil nil))))
|
|
|
664 ;; Get string.
|
|
|
665 (?s . (string . (read-string prompt default)))
|
|
|
666 ;; Get symbol.
|
|
|
667 (?S . (symbol .
|
|
|
668 (read-from-minibuffer
|
|
|
669 prompt default minibuffer-local-ns-map 'sym)))
|
|
|
670 ;; Get variable name: symbol that is user-variable-p.
|
|
|
671 (?v . (symbol . (read-variable
|
|
|
672 (if default
|
|
|
673 (hargs:prompt prompt default "Curr:")
|
|
|
674 prompt))))
|
|
|
675 ;; Get Lisp expression but don't evaluate.
|
|
|
676 (?x . (sexpression . (read-minibuffer prompt default)))
|
|
|
677 ;; Get Lisp expression and evaluate.
|
|
|
678 (?X . (sexpression . (eval-minibuffer prompt default)))
|
|
|
679 ))
|
|
|
680
|
|
|
681 (defvar hargs:iform-vector nil
|
|
|
682 "Vector of forms for each interactive command character code.")
|
|
|
683 (setq hargs:iform-vector (hargs:make-iform-vector hargs:iforms))
|
|
|
684
|
|
|
685 (defvar hargs:iforms-extensions nil
|
|
|
686 "Hyperbole extension alist of (interactive-cmd-chr . (argument-type . get-argument-form)) elts.")
|
|
|
687 (setq hargs:iforms-extensions
|
|
|
688 '(
|
|
|
689 ;; Get existing Info node name and file.
|
|
|
690 (?I . (Info-node .
|
|
|
691 (let (file)
|
|
|
692 (require 'info)
|
|
|
693 (hargs:read
|
|
|
694 prompt
|
|
|
695 (function
|
|
|
696 (lambda (node)
|
|
|
697 (and (string-match "^(\\([^\)]+\\))" node)
|
|
|
698 (setq file (substring node (match-beginning 1)
|
|
|
699 (match-end 1)))
|
|
|
700 (memq t (mapcar
|
|
|
701 (function
|
|
|
702 (lambda (dir)
|
|
|
703 (file-readable-p
|
|
|
704 (hpath:absolute-to file dir))))
|
|
|
705 (if (boundp 'Info-directory-list)
|
|
|
706 Info-directory-list
|
|
|
707 (list Info-directory))
|
|
|
708 )))))
|
|
|
709 default
|
|
|
710 "(hargs:read): Use (readable-filename)nodename."
|
|
|
711 'Info-node))))
|
|
|
712 ;; Get kcell from koutline.
|
|
|
713 (?K . (kcell . (hargs:read prompt nil default nil 'kcell)))
|
|
|
714 ;; Get kcell or path reference for use in a link.
|
|
|
715 (?L . (klink . (hargs:read prompt nil default nil 'klink)))
|
|
|
716 ;; Get existing mail msg date and file.
|
|
|
717 (?M . (mail . (progn
|
|
|
718 (while
|
|
|
719 (or (not (listp
|
|
|
720 (setq default
|
|
|
721 (read-minibuffer
|
|
|
722 (hargs:prompt
|
|
|
723 prompt ""
|
|
|
724 "list of (date mail-file)")
|
|
|
725 default))))
|
|
|
726 (/= (length default) 2)
|
|
|
727 (not (and (stringp (car (cdr default)))
|
|
|
728 (file-exists-p
|
|
|
729 (car (cdr default))))))
|
|
|
730 (beep))
|
|
|
731 default)))))
|
|
|
732
|
|
|
733 (defvar hargs:iform-extensions-vector nil
|
|
|
734 "Vector of forms for each interactive command character code.")
|
|
|
735 (setq hargs:iform-extensions-vector
|
|
|
736 (hargs:make-iform-vector hargs:iforms-extensions))
|
|
|
737
|
|
|
738 (provide 'hargs)
|
