cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/hargs.el

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