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