|
0
|
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)
|
