Mercurial > hg > xemacs-beta
diff lisp/hyperbole/hargs.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:45:50 +0200 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/hyperbole/hargs.el Mon Aug 13 08:45:50 2007 +0200 @@ -0,0 +1,738 @@ +;;!emacs +;; +;; FILE: hargs.el +;; SUMMARY: Obtains user input through Emacs for Hyperbole +;; USAGE: GNU Emacs Lisp Library +;; KEYWORDS: extensions, hypermedia +;; +;; AUTHOR: Bob Weiner +;; ORG: Brown U. +;; +;; ORIG-DATE: 31-Oct-91 at 23:17:35 +;; LAST-MOD: 11-Sep-95 at 16:34:32 by Bob Weiner +;; +;; This file is part of Hyperbole. +;; Available for use and distribution under the same terms as GNU Emacs. +;; +;; Copyright (C) 1991-1995, Free Software Foundation, Inc. +;; Developed with support from Motorola Inc. +;; +;; DESCRIPTION: +;; +;; This module should be used for any interactive prompting and +;; argument reading that Hyperbole does through Emacs. +;; +;; 'hargs:iform-read' provides a complete Lisp-based replacement for +;; interactive argument reading (most of what 'call-interactively' does). +;; It also supports prompting for new argument values with defaults drawn +;; from current button arguments. A few extensions to interactive argument +;; types are also provided, see 'hargs:iforms-extensions' for details. +;; +;; DESCRIP-END. + +;;; ************************************************************************ +;;; Other required Elisp libraries +;;; ************************************************************************ + +(require 'hpath) +(require 'set) + +;;; ************************************************************************ +;;; Public variables +;;; ************************************************************************ + +(defvar hargs:reading-p nil + "t only when Hyperbole is prompting user for input, else nil.") + +;;; ************************************************************************ +;;; Public functions +;;; ************************************************************************ + +(defun hargs:actype-get (actype &optional modifying) + "Interactively gets and returns list of arguments for ACTYPE's parameters. +Current button is being modified when MODIFYING is non-nil." + (hargs:action-get (actype:action actype) modifying)) + +(defun hargs:at-p (&optional no-default) + "Returns thing at point, if of hargs:reading-p type, or default. +If optional argument NO-DEFAULT is non-nil, nil is returned instead of any +default values. + +Caller should have checked whether an argument is presently being read +and set 'hargs:reading-p' to an appropriate argument type. +Handles all of the interactive argument types that 'hargs:iform-read' does." + (cond ((and (eq hargs:reading-p 'kcell) + (eq major-mode 'kotl-mode) + (not (looking-at "^$"))) + (kcell-view:label)) + ((and (eq hargs:reading-p 'klink) + (not (looking-at "^$"))) + (if (eq major-mode 'kotl-mode) + (kcell-view:reference + nil (and (boundp 'default-dir) default-dir)) + (let ((hargs:reading-p 'file)) + (list (hargs:at-p))))) + ((eolp) nil) + ((and (eq hargs:reading-p 'hmenu) + (eq (selected-window) (minibuffer-window))) + (save-excursion + (char-to-string + (if (search-backward " " nil t) + (progn (skip-chars-forward " ") + (following-char)) + 0)))) + ((hargs:completion t)) + ((eq hargs:reading-p 'ebut) (ebut:label-p 'as-label)) + ((ebut:label-p) nil) + ((eq hargs:reading-p 'file) + (cond ((hpath:at-p nil 'non-exist)) + ((eq major-mode 'dired-mode) + (let ((file (dired-get-filename nil t))) + (and file (hpath:absolute-to file)))) + ((eq major-mode 'monkey-mode) + (let ((file (monkey-filename t))) + (and file (hpath:absolute-to file)))) + ;; Delimited file name. + ((hpath:at-p 'file)) + ;; Unquoted remote file name. + ((hpath:is-p (hpath:ange-ftp-at-p) 'file)) + (no-default nil) + ((buffer-file-name)) + )) + ((eq hargs:reading-p 'directory) + (cond ((hpath:at-p 'directory 'non-exist)) + ((eq major-mode 'dired-mode) + (let ((dir (dired-get-filename nil t))) + (and dir (setq dir (hpath:absolute-to dir)) + (file-directory-p dir) dir))) + ((eq major-mode 'monkey-mode) + (let ((dir (monkey-filename t))) + (and dir (setq dir (hpath:absolute-to dir)) + (file-directory-p dir) dir))) + ;; Delimited directory name. + ((hpath:at-p 'directory)) + ;; Unquoted remote directory name. + ((hpath:is-p (hpath:ange-ftp-at-p) 'directory)) + (no-default nil) + (default-directory) + )) + ((eq hargs:reading-p 'string) + (or (hargs:delimited "\"" "\"") (hargs:delimited "'" "'") + (hargs:delimited "`" "'") + )) + ((or (eq hargs:reading-p 'actype) + (eq hargs:reading-p 'actypes)) + (let ((name (find-tag-default))) + (car (set:member name (htype:names 'actypes))))) + ((or (eq hargs:reading-p 'ibtype) + (eq hargs:reading-p 'ibtypes)) + (let ((name (find-tag-default))) + (car (set:member name (htype:names 'ibtypes))))) + ((eq hargs:reading-p 'sexpression) (hargs:sexpression-p)) + ((eq hargs:reading-p 'Info-node) + (and (eq major-mode 'Info-mode) + (let ((file (hpath:relative-to Info-current-file + Info-directory))) + (and (stringp file) (string-match "^\\./" file) + (setq file (substring file (match-end 0)))) + (concat "(" file ")" Info-current-node)))) + ((eq hargs:reading-p 'mail) + (and (hmail:reader-p) buffer-file-name + (prin1-to-string (list (rmail:msg-id-get) buffer-file-name)))) + ((eq hargs:reading-p 'symbol) + (let ((sym (find-tag-default))) + (if (or (fboundp sym) (boundp sym)) sym))) + ((eq hargs:reading-p 'buffer) + (find-tag-default)) + ((eq hargs:reading-p 'character) + (following-char)) + ((eq hargs:reading-p 'key) + (require 'hib-kbd) + (let ((key-seq (hbut:label-p 'as-label "{" "}"))) + (and key-seq (kbd-key:normalize key-seq)))) + ((eq hargs:reading-p 'integer) + (save-excursion (skip-chars-backward "-0-9") + (if (looking-at "-?[0-9]+") + (read (current-buffer))))) + )) + +(defun hargs:completion (&optional no-insert) + "If in the completions buffer, return completion at point. Also insert unless optional NO-INSERT is non-nil. +Insert in minibuffer if active or in other window if minibuffer is inactive." + (interactive '(nil)) + (if (or (equal (buffer-name) "*Completions*") ;; V19 + (equal (buffer-name) " *Completions*")) ;; V18 + (let ((opoint (point)) + (owind (selected-window))) + (if (re-search-backward "^\\|[ \t][ \t]" nil t) + (let ((insert-window + (cond ((> (minibuffer-depth) 0) + (minibuffer-window)) + ((not (eq (selected-window) (next-window nil))) + (next-window nil)))) + (bury-completions) + (entry)) + (skip-chars-forward " \t") + (if (and insert-window (looking-at "[^\t\n]+")) + (progn (setq entry (buffer-substring (match-beginning 0) + (match-end 0))) + (select-window insert-window) + (let ((str (buffer-substring + (point) + (save-excursion (beginning-of-line) + (point))))) + (if (and (eq (selected-window) (minibuffer-window))) + ;; If entry matches tail of minibuffer prefix + ;; already, then return minibuffer contents + ;; as entry. + (progn + (setq entry + (if (string-match + (concat + (regexp-quote entry) "\\'") + str) + str + (concat + (if (string-match + "/[^/]+\\'" str) + (substring + str 0 (1+ (match-beginning 0))) + str) + entry))) + (or no-insert (if entry (insert entry))) + ) + ;; In buffer, non-minibuffer completion. + ;; Only insert entry if last buffer line does + ;; not end in entry. + (cond (no-insert) + ((or (string-match + (concat + (regexp-quote entry) "\\'") str) + (null entry)) + (setq bury-completions t)) + (t (insert entry))) + )))) + (select-window owind) (goto-char opoint) + (if bury-completions + (progn (bury-buffer nil) (delete-window))) + entry))))) + +(defun hargs:iform-read (iform &optional modifying) + "Reads action arguments according to IFORM, a list with car = 'interactive. +Optional MODIFYING non-nil indicates current button is being modified, so +button's current values should be presented as defaults. Otherwise, uses +hargs:defaults as list of defaults, if any. +See also documentation for 'interactive'." + ;; This is mostly a translation of 'call-interactively' to Lisp. + ;; + ;; Save this now, since use of minibuffer will clobber it. + (setq prefix-arg current-prefix-arg) + (if (not (and (listp iform) (eq (car iform) 'interactive))) + (error + "(hargs:iform-read): arg must be a list whose car = 'interactive.") + (setq iform (car (cdr iform))) + (if (or (null iform) (and (stringp iform) (equal iform ""))) + nil + (let ((prev-reading-p hargs:reading-p)) + (unwind-protect + (progn + (setq hargs:reading-p t) + (if (not (stringp iform)) + (let ((defaults (if modifying + (hattr:get 'hbut:current 'args) + (and (boundp 'hargs:defaults) + (listp hargs:defaults) + hargs:defaults) + ))) + (eval iform)) + (let ((i 0) (start 0) (end (length iform)) + (ientry) (results) (val) (default) + (defaults (if modifying + (hattr:get 'hbut:current 'args) + (and (boundp 'hargs:defaults) + (listp hargs:defaults) + hargs:defaults) + ))) + ;; + ;; Handle special initial interactive string chars. + ;; + ;; '*' means error if buffer is read-only. + ;; Notion of when action cannot be performed due to + ;; read-only buffer is view-specific, so here, we just + ;; ignore a read-only specification since it is checked for + ;; earlier by any ebut edit code. + ;; + ;; '@' means select window of last mouse event. + ;; + ;; '_' means keep region in same state (active or inactive) + ;; after this command. (XEmacs only.) + ;; + (while (cond + ((eq (aref iform i) ?*)) + ((eq (aref iform i) ?@) + (hargs:select-event-window) + t) + ((eq (aref iform i) ?_) + (setq zmacs-region-stays t))) + (setq i (1+ i) start i)) + ;; + (while (and (< start end) + (string-match "\n\\|\\'" iform start)) + (setq start (match-end 0) + ientry (substring iform i (match-beginning 0)) + i start + default (car defaults) + default (if (or (null default) (stringp default)) + default + (prin1-to-string default)) + val (hargs:get ientry default (car results)) + defaults (cdr defaults) + results (cond ((or (null val) (not (listp val))) + (cons val results)) + ;; Is a list of args? + ((eq (car val) 'args) + (append (nreverse (cdr val)) results)) + (t;; regular list value + (cons val results))))) + (nreverse results)))) + (setq hargs:reading-p prev-reading-p)))))) + +(defun hargs:read (prompt &optional predicate default err val-type) + "PROMPTs without completion for a value matching PREDICATE and returns it. +PREDICATE is an optional boolean function of one argument. Optional DEFAULT +is a string to insert after PROMPT as the default return value. Optional +ERR is a string to display temporarily when an invalid value is given. +Optional VAL-TYPE is a symbol indicating type of value to be read. If +VAL-TYPE is not equal to 'sexpression' or 'klink' and is non-nil, value is +returned as a string." + (let ((bad-val) (val) (stringify) + (prev-reading-p hargs:reading-p) (read-func) + (owind (selected-window)) + (obuf (current-buffer))) + (unwind-protect + (progn + (cond ((or (null val-type) (eq val-type 'sexpression)) + (setq read-func 'read-minibuffer + hargs:reading-p 'sexpression)) + (t (setq read-func 'read-string hargs:reading-p val-type + stringify t))) + (while (progn (and default (not (stringp default)) + (setq default (prin1-to-string default))) + (condition-case () + (or bad-val + (setq val (funcall read-func prompt default))) + (error (setq bad-val t))) + (if bad-val t + (and stringify + ;; Remove any double quoting of strings. + (string-match + "\\`\"\\([^\"]*\\)\"\\'" val) + (setq val (substring val (match-beginning 1) + (match-end 1)))) + (and predicate (not (funcall predicate val))))) + (if bad-val (setq bad-val nil) (setq default val)) + (beep) + (if err (progn (message err) (sit-for 3)))) + val) + (setq hargs:reading-p prev-reading-p) + (select-window owind) + (switch-to-buffer obuf) + ))) + +(defun hargs:read-match (prompt table &optional + predicate must-match default val-type) + "PROMPTs with completion for a value in TABLE and returns it. +TABLE is an alist where each element's car is a string, or it may be an +obarray for symbol-name completion. +Optional PREDICATE limits table entries to match against. +Optional MUST-MATCH means value returned must be from TABLE. +Optional DEFAULT is a string inserted after PROMPT as default value. +Optional VAL-TYPE is a symbol indicating type of value to be read." + (if (and must-match (null table)) + nil + (let ((prev-reading-p hargs:reading-p) + (completion-ignore-case t) + (owind (selected-window)) + (obuf (current-buffer))) + (unwind-protect + (progn + (setq hargs:reading-p (or val-type t)) + (completing-read prompt table predicate must-match default)) + (setq hargs:reading-p prev-reading-p) + (select-window owind) + (switch-to-buffer obuf) + )))) + +(defun hargs:select-p (&optional value assist-flag) + "Returns optional VALUE or value selected at point if any, else nil. +If value is the same as the contents of the minibuffer, it is used as +the current minibuffer argument, otherwise, the minibuffer is erased +and value is inserted there. +Optional ASSIST-FLAG non-nil triggers display of Hyperbole menu item help when +appropriate." + (if (and (> (minibuffer-depth) 0) (or value (setq value (hargs:at-p)))) + (let ((owind (selected-window)) (back-to) + (str-value (and value (format "%s" value)))) + (unwind-protect + (progn + (select-window (minibuffer-window)) + (set-buffer (window-buffer (minibuffer-window))) + (cond + ;; Selecting a menu item + ((eq hargs:reading-p 'hmenu) + (if assist-flag (setq hargs:reading-p 'hmenu-help)) + (hui:menu-enter str-value)) + ;; Use value for parameter. + ((string= str-value (buffer-string)) + (exit-minibuffer)) + ;; Clear minibuffer and insert value. + (t (setq buffer-read-only nil) + (erase-buffer) (insert str-value) + (setq back-to t))) + value) + (if back-to (select-window owind)))))) + +;;; ************************************************************************ +;;; Private functions +;;; ************************************************************************ + +;;; From etags.el, so don't have to load the whole thing. +(or (fboundp 'find-tag-default) + (defun find-tag-default () + (or (and (boundp 'find-tag-default-hook) + (not (memq find-tag-default-hook '(nil find-tag-default))) + (condition-case data + (funcall find-tag-default-hook) + (error + (message "value of find-tag-default-hook signalled error: %s" + data) + (sit-for 1) + nil))) + (save-excursion + (if (not (memq (char-syntax (preceding-char)) '(?w ?_))) + (while (not (looking-at "\\sw\\|\\s_\\|\\'")) + (forward-char 1))) + (while (looking-at "\\sw\\|\\s_") + (forward-char 1)) + (if (re-search-backward "\\sw\\|\\s_" nil t) + (regexp-quote + (progn (forward-char 1) + (buffer-substring (point) + (progn (forward-sexp -1) + (while (looking-at "\\s'") + (forward-char 1)) + (point))))) + nil))))) + +(defun hargs:action-get (action modifying) + "Interactively gets list of arguments for ACTION's parameters. +Current button is being modified when MODIFYING is non-nil. +Returns nil if ACTION is not a list or byte-code object, has no interactive +form or takes no arguments." + (and (or (hypb:v19-byte-code-p action) (listp action)) + (let ((interactive-form (action:commandp action))) + (if interactive-form + (action:path-args-rel + (hargs:iform-read interactive-form modifying)))))) + +(defun hargs:delimited (start-delim end-delim + &optional start-regexp-flag end-regexp-flag) + "Returns a single line, delimited argument that point is within, or nil. +START-DELIM and END-DELIM are strings that specify the argument delimiters. +With optional START-REGEXP-FLAG non-nil, START-DELIM is treated as a regular +expression. END-REGEXP-FLAG is similar." + (let* ((opoint (point)) + (limit (if start-regexp-flag opoint + (+ opoint (1- (length start-delim))))) + (start-search-func (if start-regexp-flag 're-search-forward + 'search-forward)) + (end-search-func (if end-regexp-flag 're-search-forward + 'search-forward)) + start end) + (save-excursion + (beginning-of-line) + (while (and (setq start (funcall start-search-func start-delim limit t)) + (< (point) opoint) + ;; This is not to find the real end delimiter but to find + ;; end delimiters that precede the current argument and are + ;; therefore false matches, hence the search is limited to + ;; prior to the original point. + (funcall end-search-func end-delim opoint t)) + (setq start nil)) + (if start + (progn + (end-of-line) (setq limit (1+ (point))) + (goto-char opoint) + (and (funcall end-search-func end-delim limit t) + (setq end (match-beginning 0)) + (buffer-substring start end))))))) + +(defun hargs:get (interactive-entry &optional default prior-arg) + "Prompts for an argument, if need be, from INTERACTIVE-ENTRY, a string. +Optional DEFAULT is inserted after prompt. +First character of INTERACTIVE-ENTRY must be a command character from +the list in the documentation for 'interactive' or a `+' which indicates that +the following character is a Hyperbole interactive extension command +character. + +May return a single value or a list of values, in which case the first +element of the list is always the symbol 'args." + (let (func cmd prompt) + (cond ((or (null interactive-entry) (equal interactive-entry "")) + (error "(hargs:get): Empty interactive-entry arg.")) + ((= (aref interactive-entry 0) ?+) + ;; Hyperbole / user extension command character. The next + ;; character is the actual command character. + (setq cmd (aref interactive-entry 1) + prompt (format (substring interactive-entry 2) prior-arg) + func (if (< cmd (length hargs:iform-extensions-vector)) + (aref hargs:iform-extensions-vector cmd))) + (if func + (funcall func prompt default) + (error + "(hargs:get): Bad interactive-entry extension character: '%c'." + cmd))) + (t (setq cmd (aref interactive-entry 0) + prompt + (format (substring interactive-entry 1) prior-arg) + func (if (< cmd (length hargs:iform-vector)) + (aref hargs:iform-vector cmd))) + (if func + (funcall func prompt default) + (error + "(hargs:get): Bad interactive-entry command character: '%c'." + cmd)))))) + +(defun hargs:make-iform-vector (iform-alist) + "Return a vector built from IFORM-ALIST used for looking up interactive command code characters." + ;; Vector needs to have 1 more elts than the highest char code for + ;; interactive commands. + (let* ((size (1+ (car (sort (mapcar 'car iform-alist) '>)))) + (vec (make-vector size nil))) + (mapcar (function + (lambda (elt) + (aset vec (car elt) + (` (lambda (prompt default) + (setq hargs:reading-p '(, (car (cdr elt)))) + (, (cdr (cdr elt)))))))) + iform-alist) + vec)) + +(defun hargs:prompt (prompt default &optional default-prompt) + "Returns string of PROMPT including DEFAULT. +Optional DEFAULT-PROMPT is used to describe default value." + (if default + (format "%s(%s%s%s) " prompt (or default-prompt "default") + (if (equal default "") "" " ") + default) + prompt)) + +(defun hargs:select-event-window () + "Select window, if any, that mouse was over during last event." + (if hyperb:lemacs-p + (if current-mouse-event + (select-window + (or (event-window current-mouse-event) + (selected-window)))) + (let* ((event last-command-event) + (window (posn-window (event-start event)))) + (if (and (eq window (minibuffer-window)) + (not (minibuffer-window-active-p + (minibuffer-window)))) + (error "Attempt to select inactive minibuffer window") + (select-window + (or window (selected-window))))))) + +(defun hargs:sexpression-p (&optional no-recurse) + "Returns an sexpression at point as a string. +If point follows an sexpression end character, the preceding sexpression +is returned. If point precedes an sexpression start character, the +following sexpression is returned. Otherwise, the innermost sexpression +that point is within is returned or nil if none." + (save-excursion + (condition-case () + (let ((not-quoted + '(not (and (= (char-syntax (char-after (- (point) 2))) ?\\) + (/= (char-syntax (char-after (- (point) 3))) ?\\))))) + (cond ((and (= (char-syntax (preceding-char)) ?\)) + ;; Ignore quoted end chars. + (eval not-quoted)) + (buffer-substring (point) + (progn (forward-sexp -1) (point)))) + ((and (= (char-syntax (following-char)) ?\() + ;; Ignore quoted begin chars. + (eval not-quoted)) + (buffer-substring (point) + (progn (forward-sexp) (point)))) + (no-recurse nil) + (t (save-excursion (up-list 1) (hargs:sexpression-p t))))) + (error nil)))) + +;;; ************************************************************************ +;;; Private variables +;;; ************************************************************************ + +(defvar hargs:iforms nil + "Alist of (interactive-cmd-chr . (argument-type . get-argument-form)) elts.") +(setq hargs:iforms + '( + ;; Get function symbol. + (?a . (symbol . + (intern (completing-read prompt obarray 'fboundp t default)))) + ;; Get name of existing buffer. + (?b . (buffer . + (progn + (or default (setq default (other-buffer (current-buffer)))) + (read-buffer prompt default t)))) + ;; Get name of possibly nonexistent buffer. + (?B . (buffer . + (progn + (or default (setq default (other-buffer (current-buffer)))) + (read-buffer prompt default nil)))) + ;; Get character. + (?c . (character . + (progn (message + (if default + (hargs:prompt prompt + (if (integerp default) + (char-to-string default) + default) + "Curr:") + prompt)) + (char-to-string (read-char))))) + ;; Get symbol for interactive function, a command. + (?C . (symbol . + (intern + (completing-read prompt obarray 'commandp t default)))) + ;; Get value of point; does not do I/O. + (?d . (integer . (point))) + ;; Get directory name. + (?D . (directory . + (progn + (or default (setq default default-directory)) + (read-file-name prompt default default 'existing)))) + ;; Get existing file name. + (?f . (file . + (read-file-name prompt default default + (if (eq system-type 'vax-vms) + nil 'existing)))) + ;; Get possibly nonexistent file name. + (?F . (file . (read-file-name prompt default default nil))) + ;; Get key sequence. + (?k . (key . + (key-description (read-key-sequence + (if default + (hargs:prompt prompt default "Curr:") + prompt))))) + ;; Get key sequence without converting uppercase or shifted + ;; function keys to their unshifted equivalents. + (?K . (key . + (key-description (read-key-sequence + (if default + (hargs:prompt prompt default "Curr:") + prompt) + nil t)))) + ;; Get value of mark. Does not do I/O. + (?m . (integer . (marker-position (hypb:mark-marker t)))) + ;; Get numeric prefix argument or a number from the minibuffer. + (?N . (integer . + (if prefix-arg + (prefix-numeric-value prefix-arg) + (let ((arg)) + (while (not (integerp + (setq arg (read-minibuffer prompt default)))) + (beep)) + arg)))) + ;; Get number from minibuffer. + (?n . (integer . + (let ((arg)) + (while (not (integerp + (setq arg (read-minibuffer prompt default)))) + (beep)) + arg))) + ;; Get numeric prefix argument. No I/O. + (?p . (prefix-arg . + (prefix-numeric-value prefix-arg))) + ;; Get prefix argument in raw form. No I/O. + (?P . (prefix-arg . prefix-arg)) + ;; Get region, point and mark as 2 args. No I/O + (?r . (region . + (if (marker-position (hypb:mark-marker t)) + (list 'args (min (point) (hypb:mark t)) + (max (point) (hypb:mark t))) + (list 'args nil nil)))) + ;; Get string. + (?s . (string . (read-string prompt default))) + ;; Get symbol. + (?S . (symbol . + (read-from-minibuffer + prompt default minibuffer-local-ns-map 'sym))) + ;; Get variable name: symbol that is user-variable-p. + (?v . (symbol . (read-variable + (if default + (hargs:prompt prompt default "Curr:") + prompt)))) + ;; Get Lisp expression but don't evaluate. + (?x . (sexpression . (read-minibuffer prompt default))) + ;; Get Lisp expression and evaluate. + (?X . (sexpression . (eval-minibuffer prompt default))) + )) + +(defvar hargs:iform-vector nil + "Vector of forms for each interactive command character code.") +(setq hargs:iform-vector (hargs:make-iform-vector hargs:iforms)) + +(defvar hargs:iforms-extensions nil + "Hyperbole extension alist of (interactive-cmd-chr . (argument-type . get-argument-form)) elts.") +(setq hargs:iforms-extensions + '( + ;; Get existing Info node name and file. + (?I . (Info-node . + (let (file) + (require 'info) + (hargs:read + prompt + (function + (lambda (node) + (and (string-match "^(\\([^\)]+\\))" node) + (setq file (substring node (match-beginning 1) + (match-end 1))) + (memq t (mapcar + (function + (lambda (dir) + (file-readable-p + (hpath:absolute-to file dir)))) + (if (boundp 'Info-directory-list) + Info-directory-list + (list Info-directory)) + ))))) + default + "(hargs:read): Use (readable-filename)nodename." + 'Info-node)))) + ;; Get kcell from koutline. + (?K . (kcell . (hargs:read prompt nil default nil 'kcell))) + ;; Get kcell or path reference for use in a link. + (?L . (klink . (hargs:read prompt nil default nil 'klink))) + ;; Get existing mail msg date and file. + (?M . (mail . (progn + (while + (or (not (listp + (setq default + (read-minibuffer + (hargs:prompt + prompt "" + "list of (date mail-file)") + default)))) + (/= (length default) 2) + (not (and (stringp (car (cdr default))) + (file-exists-p + (car (cdr default)))))) + (beep)) + default))))) + +(defvar hargs:iform-extensions-vector nil + "Vector of forms for each interactive command character code.") +(setq hargs:iform-extensions-vector + (hargs:make-iform-vector hargs:iforms-extensions)) + +(provide 'hargs)