Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hact.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 929b76928fce
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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)