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

   1 ;;; hact.el --- Hyperbole button action handling.
   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: 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 ;;; Code:
  30
  31 ;;;
  32 ;;; Other required Elisp libraries
  33 ;;;
  34 (require 'hhist)
  35
  36 ;;;
  37 ;;; Public variables
  38 ;;;
  39
  40 (defvar hrule:action 'actype:act
  41   "Value is a function of any number of arguments that executes actions.
  42 Variable is used to vary actual effect of evaluating a Hyperbole action,
  43 e.g. to inhibit actions.")
  44
  45 ;;;
  46 ;;; Public functions
  47 ;;;
  48
  49 ;;;
  50 ;;; action class
  51 ;;;
  52
  53 (defun action:commandp (function)
  54   "Return interactive calling form if FUNCTION has one, else nil."
  55   (let ((action
  56          (cond ((null function) nil)
  57                ((symbolp function)
  58                 (and (fboundp function)
  59                      (hypb:indirect-function function)))
  60                ((and (listp function)
  61                      (eq (car function) 'autoload))
  62                 (error "(action:commandp): Autoload not supported: %s" function))
  63                (t function))))
  64     (if (hypb:v19-byte-code-p action)
  65         (if (commandp action)
  66             (if (fboundp 'compiled-function-interactive)
  67                 (compiled-function-interactive action)
  68               (list 'interactive (aref action 5))))
  69       (commandp action))))
  70
  71 (defun action:create (param-list body)
  72   "Create an action defined by PARAM-LIST and BODY, a list of Lisp forms."
  73   (if (symbolp body)
  74       body
  75     (list 'function (cons 'lambda (cons param-list body)))))
  76
  77 (defun action:kbd-macro (macro &optional repeat-count)
  78   "Returns Hyperbole action that executes a keyboard MACRO REPEAT-COUNT times."
  79   (list 'execute-kbd-macro macro repeat-count))
  80
  81 (defun action:params (action)
  82   "Returns unmodified ACTION parameter list."
  83   (cond ((null action) nil)
  84         ((symbolp action)
  85          (car (cdr
  86                (and (fboundp action) (hypb:indirect-function action)))))
  87         ((listp action)
  88          (if (eq (car action) 'autoload)
  89              (error "(action:params): Autoload not supported: %s" action)
  90            (car (cdr action))))
  91         ((hypb:v19-byte-code-p action)
  92          (if (fboundp 'compiled-function-arglist)
  93              (compiled-function-arglist action)
  94            ;; Turn into a list for extraction
  95            (car (cdr (cons nil (append action nil))))))))
  96
  97 (defun action:param-list (action)
  98   "Returns list of actual ACTION parameters (removes '&' special forms)."
  99   (delq nil (mapcar
 100               (function
 101                 (lambda (param)
 102                   (if (= (aref (symbol-name param)
 103                                0) ?&)
 104                       nil param)))
 105               (action:params action))))
 106
 107 (defun action:path-args-abs (args-list &optional default-dirs)
 108   "Return any paths in ARGS-LIST made absolute.
 109 Uses optional DEFAULT-DIRS or 'default-directory'.
 110 Other arguments are returned unchanged."
 111   (mapcar (function (lambda (arg) (hpath:absolute-to arg default-dirs)))
 112           args-list))
 113
 114 (defun action:path-args-rel (args-list)
 115   "Return any paths in ARGS-LIST below current directory made relative.
 116 Other paths are simply expanded.  Non-path arguments are returned unchanged."
 117   (let ((dir (hattr:get 'hbut:current 'dir)))
 118     (mapcar (function (lambda (arg) (hpath:relative-to arg dir)))
 119             args-list)))
 120
 121
 122 ;;;
 123 ;;; actype class
 124 ;;;
 125
 126 (defmacro hact (&rest args)
 127   "Performs action formed from rest of ARGS.
 128 First arg may be a symbol or symbol name for either an action type or a
 129 function.  Runs 'action:act-hook' before performing action."
 130   (eval (` (cons 'funcall (cons 'hrule:action (quote (, args)))))))
 131
 132 (defun    actype:act (actype &rest args)
 133   "Performs action formed from ACTYPE and rest of ARGS and returns value.
 134 If value is nil, however, t is returned instead, to ensure that implicit button
 135 types register the performance of the action.  ACTYPE may be a symbol or symbol
 136 name for either an action type or a function.  Runs 'action:act-hook' before
 137 performing ACTION."
 138   ;; Needed so relative paths are expanded properly.
 139   (setq args (action:path-args-abs args))
 140   (let ((prefix-arg current-prefix-arg)
 141         (action (actype:action actype))
 142         (act '(apply action args)))
 143     (if (null action)
 144         (error "(actype:act): Null action for: '%s'" actype)
 145       (let ((hist-elt (hhist:element)))
 146         (run-hooks 'action:act-hook)
 147         (prog1 (or (cond ((or (symbolp action) (listp action)
 148                               (hypb:v19-byte-code-p action))
 149                           (eval act))
 150                          ((and (stringp action)
 151                                (let ((func (key-binding action)))
 152                                  (if (not (integerp action))
 153                                      (setq action func))))
 154                           (eval act))
 155                          (t (eval action)))
 156                    t)
 157           (hhist:add hist-elt))
 158         ))))
 159
 160 (defun    actype:action (actype)
 161   "Returns action part of ACTYPE (a symbol or symbol name).
 162 ACTYPE may be a Hyperbole actype or Emacs Lisp function."
 163   (let (actname)
 164     (if (stringp actype)
 165         (setq actname actype
 166               actype (intern actype))
 167       (setq actname (symbol-name actype)))
 168     (cond ((htype:body (if (string-match "^actypes::" actname)
 169                            actype
 170                          (intern-soft (concat "actypes::" actname)))))
 171           ((fboundp actype) actype)
 172           )))
 173
 174 (defmacro actype:create (type params doc &rest default-action)
 175   "Creates an action TYPE (an unquoted symbol) with PARAMS, described by DOC.
 176 The type uses PARAMS to perform DEFAULT-ACTION (list of the rest of the
 177 arguments).  A call to this function is syntactically the same as for
 178 'defun',  but a doc string is required.
 179 Returns symbol created when successful, else nil."
 180  (list 'htype:create type 'actypes doc params default-action nil))
 181
 182 (fset    'defact 'actype:create)
 183 (put     'actype:create 'lisp-indent-function 'defun)
 184
 185 (defun    actype:delete (type)
 186   "Deletes an action TYPE (a symbol).  Returns TYPE's symbol if it existed."
 187   (htype:delete type 'actypes))
 188
 189 (defun    actype:doc (hbut &optional full)
 190   "Returns first line of act doc for HBUT (a Hyperbole button symbol).
 191 With optional FULL, returns full documentation string.
 192 Returns nil when no documentation."
 193   (let* ((act (and (hbut:is-p hbut) (or (hattr:get hbut 'action)
 194                                         (hattr:get hbut 'actype))))
 195          (but-type (hattr:get hbut 'categ))
 196          (sym-p (and act (symbolp act)))
 197          (end-line) (doc))
 198     (cond ((and but-type (fboundp but-type)
 199                 (setq doc (htype:doc but-type)))
 200            ;; Is an implicit button, so use its doc string if any.
 201            )
 202           (sym-p
 203            (setq doc (htype:doc act))))
 204     (if (null doc)
 205         nil
 206       (setq doc (substitute-command-keys doc))
 207       (or full (setq end-line (string-match "[\n]" doc)
 208                      doc (substring doc 0 end-line))))
 209     doc))
 210
 211 (defun    actype:identity (&rest args)
 212   "Returns list of ARGS unchanged or if no ARGS, returns t.
 213 Used as the setting of 'hrule:action' to inhibit action evaluation."
 214   (or args t))
 215
 216 (defun    actype:interact (actype)
 217   "Interactively calls default action for ACTYPE.
 218 ACTYPE is a symbol that was previously defined with 'defact'.
 219 Returns nil only when no action is found or the action has no interactive
 220 calling form."
 221
 222   (let ((action (htype:body
 223                  (intern-soft (concat "actypes::" (symbol-name actype))))))
 224     (and action (action:commandp action) (or (call-interactively action) t))))
 225
 226 (defun    actype:params (actype)
 227   "Returns list of ACTYPE's parameters."
 228   (action:params (actype:action actype)))
 229
 230 (provide 'hact)
 231
 232 ;;; hact.el ends here