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