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