Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hargs.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: 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)