Kde/Utils: Add krunscript tool
[emacsstuff.git] / lib / varcmd.el
1 ;;; varcmd.el --- Flexible command handling
2 ;;
3 ;; $Id: varcmd.el,v 1.14 2000/02/26 10:20:47 bund Exp $
4 ;;
5 ;; Copyright (C) 1998 Stefan Bund
6
7 ;; varcmd.el is free software; you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published
9 ;; by the Free Software Foundation; either version 2, or (at your
10 ;; option) any later version.
11
12 ;; varcmd.el is distributed in the hope that it will be useful, but
13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15 ;; General Public License for more details.
16
17 ;;; Commentary:
18
19 ;;; Change-Log:
20
21 ;; $Log: varcmd.el,v $
22 ;; Revision 1.14  2000/02/26 10:20:47  bund
23 ;; Support für separator und undefine aktualisiert
24 ;;
25 ;; Revision 1.13  2000/02/13 21:17:49  bund
26 ;; define-key-last implementiert und verwendet
27 ;; vcmd-define-menu implementiert
28 ;;
29 ;; Revision 1.12  2000/01/26 15:32:08  bund
30 ;; call-interactively anstelle von command-execute verwenden
31 ;; backquote in vcmd-bind-menu
32 ;;
33 ;; Revision 1.11  2000/01/08 16:13:23  bund
34 ;; vcmd-flag-handler implementiert
35 ;;
36 ;; Revision 1.10  1999/11/22 14:30:18  bund
37 ;; Weitere XEmacs anpassungen
38 ;;
39 ;; Revision 1.9  1999/08/03 07:55:33  bund
40 ;; erste (alpha) anpassung an xemacs
41 ;;
42 ;; Revision 1.8  1999/05/07 11:40:31  bund
43 ;; noforms implementiert
44 ;;
45 ;; Revision 1.7  1998/09/03 11:25:29  bund
46 ;; added 'expression vcmd type
47 ;;
48 ;; Revision 1.6  1998/07/11 19:17:53  bund
49 ;; BUGFIX: seperator->separator :-)
50 ;;
51 ;; Revision 1.5  1998/07/06 09:08:37  bund
52 ;; added 'separator to vcmd-bind-menu
53 ;;
54 ;; Revision 1.4  1998/07/03 08:56:16  bund
55 ;; add menu-bar items added by vcmd-define-entry to menu-bar-final-items
56 ;;
57 ;; Revision 1.3  1998/06/26 15:41:29  bund
58 ;; BUGFIX: nil-command interpreted correctly
59 ;;
60 ;; Revision 1.2  1998/06/22 08:55:34  bund
61 ;; new semantics for handlers: Call with the args to the handler symbol
62 ;; as arguments, not with a list of the arguments
63 ;; modulized vcmd-define-key
64 ;;
65 ;; Revision 1.1  1998/06/19 10:44:50  bund
66 ;; added varcmd.el
67 ;;
68 ;;
69
70 ;;; Variables:
71
72 (defvar vcmd-handlers 
73   '((function . vcmd-call-function)
74     (lambda . vcmd-call-lambda-expression)
75     (macro . cvmd-call-kbd-macro)
76     (value . vcmd-return-value)
77     (expression . vcmd-expression))
78   "Alist of handlers for different command types")
79
80 (defvar vcmd-flag-handlers nil
81   "Alist of flag handlers for differnt flags")
82
83 (defvar vcmd-command-symbol 0
84   "Sequence number for generation of unique command names")
85
86 ;;; Code:
87
88 (defun vcmd (command &optional value interactive)
89   "Call COMMAND as en extended command as defined in vcmd-handlers.
90
91 If COMMAND is a cons cell and the car of COMMAND can be found in vcmd-handlers,
92 the COMMAND is executed by passing the cdr of COMMAND to the handler found in 
93 vcmd-handlers. vcmd then returns the return value of the handler.
94
95 If no handler is found, and optional VALUE is non-nil, the return value of 
96 vcmd is COMMAND. 
97
98 If VALUE is not given or is nil, then COMMAND should be an executable entry, 
99 e.g. a symbol or an array (keyboard macro).
100
101 If INTERACTIVE is non-nil, then the function is called interactively. If 
102 a handler is used to execute the command, the handler is passed t as second arg."
103   (if (consp command)
104       (let ((handler (cdr (assq (car command) vcmd-handlers))))
105         (if handler
106             (apply handler interactive (cdr command))
107           command))
108     (if value
109         command
110       (if (arrayp command)
111           (execute-kbd-macro command)
112         (if interactive
113             (if (commandp command)
114                 (call-interactively command)
115               (funcall command))
116           (funcall command))))))
117               
118 (defun vcmd-call-function (interactive fn &rest args)
119   "Call (car ARG) or ARG as function, suplying (cdr ARG) as arguments.
120 If ARG is a consp then if INTERACTIVE is non-nil, (cdr ARG) is non-nil
121 and (car ARG) is a command, call function with command-execute otherwise
122 use apply.
123
124 If ARG is not a cons cell, call ARG with command-execute, if it is a
125 command, otherwise use funcall."
126   (if (and interactive
127            (null args)
128            (commandp fn))
129       (command-execute fn)
130     (apply fn args)))
131
132 (defun vcmd-call-lambda-expression (interactive &rest body)
133   "call ARG as a lambda expression (without leading lambda).
134 If INTERACTIVE is non-nil and (cons 'lambda ARG) is a command, use
135 command-execute, otherwise use funcall."
136   (if (and interactive
137            (commandp (cons 'lambda body)))
138       (command-execute (cons 'lambda body))
139     (funcall (cons 'lambda body))))
140
141 (defun vcmd-call-kbd-macro (interactive macro)
142   "call ARG as keyboard macro"
143   (execute-kbd-macro macro))
144
145 (defun vcmd-return-value (interactive value)
146   "return ARG as return value"
147   value)
148
149 (defun vcmd-expression (interactive &rest expression)
150   (eval (cons 'progn expression)))
151
152 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
153
154 (defun vcmd-encapsulate-fn (definition forms)
155   "Encapsulate call of DEFINITION using vcmd and return the
156 lambda expression."
157   (let ((flag (and (consp definition) 
158                    (assq (car definition) vcmd-flag-handlers))))
159     (if flag
160         (funcall (cdr flag) (cdr definition) forms)
161       (append forms
162               (list (list 'vcmd
163                           (list 'quote
164                                 definition)
165                           nil
166                           t))))))
167
168 (defun vcmd-get-symbol (definition &rest forms)
169   "Fetch a new symbol and set it's function definition to a call of 
170 DEFINITION. If FORMS is non-nil, theese forms are executed prior to 
171 calling DEFINITION. If DEFINITION is nil, an unbound symbol is returned."
172   (setq vcmd-command-symbol (1+ vcmd-command-symbol))
173   (let ((sym (intern (concat "vcmd-cmd-"
174                              (number-to-string vcmd-command-symbol)))))
175     (fset sym `(lambda ()
176                  (interactive)
177                  (let ((current-prefix-arg current-prefix-arg))
178                    ,@(vcmd-encapsulate-fn definition forms))))
179     sym))
180
181 (defun define-key-last (keymap key def)
182   "Like define-key, mat make KEY the last entry in KEYMAP instead of
183 the first. KEY must contain just one event."
184   (let ((last-key (loop for def in (reverse keymap)
185                         if (and (consp def)
186                                 (not (eq (car def) t)))
187                           return (car def)
188                         finally return nil)))
189     (if last-key
190         (define-key-after keymap key def last-key)
191       (define-key keymap key def))))
192
193 (defun vcmd-bind-menu-FSF (keymap binding &rest menu)
194   "Define the menu entry descripbed by MENU in KEYMAP to BINDING.
195 If (car MENU) is a consp, use (car MENU) as menu list, otherwise use
196 MENU."
197   (setq menu (apply 'append
198                     (mapcar '(lambda (x)
199                                (if (consp x)
200                                    x
201                                  (list x)))
202                             menu)))
203   (while (cdr menu)
204     (let* ((menu-symbol (if (symbolp (car menu))
205                             (car menu)
206                           (intern (car menu))))
207            (menu-name (if (symbolp (car menu))
208                           (symbol-name (car menu))
209                         (car menu)))
210            (next-keymap (lookup-key keymap (vector menu-symbol))))
211       (if next-keymap
212           (setq keymap next-keymap)
213         (define-key-last 
214           keymap 
215           (vector menu-symbol) 
216           (cons menu-name
217                 (setq next-keymap (make-sparse-keymap menu-name))))
218         (setq keymap next-keymap))
219       (setq menu (cdr menu))))
220   (if menu
221       (if (eq (car menu) 'separator)
222           (define-key-last 
223             keymap 
224             (vector (vcmd-get-symbol nil)) 
225             '("--" . nil))
226         (if binding
227             (if (symbolp (car menu))
228                 (define-key-last
229                   keymap
230                   (vector (car menu))
231                   (cons (symbol-name (car menu))
232                         binding))
233               (define-key-last
234                 keymap
235                 (vector (intern (car menu)))
236                 (cons (car menu)
237                       binding)))))))
238
239 (defun vcmd-bind-menu-lucid (keymap binding &rest menu)
240   "Define the menu entry descripbed by MENU in KEYMAP to BINDING.
241 If (car MENU) is a consp, use (car MENU) as menu list, otherwise use
242 MENU."
243   (setq menu (apply 'append
244                     (mapcar '(lambda (x)
245                                (if (consp x)
246                                    x
247                                  (list x)))
248                             menu)))
249   (setq menu (nreverse (cdr menu)))
250   (apply 'add-menu-button
251          (reverse (cdr menu))
252          (list (vector (if (eq (car menu) 'separator)
253                            "--"
254                          (if (symbolp (car menu))
255                              (symbol-name (car menu))
256                            (car menu)))
257                        binding
258                        ':active t)))
259   (set-menubar-dirty-flag))
260
261 (defun vcmd-bind-key (keymap binding sequence)
262   (if binding
263       (define-key keymap sequence binding)))
264
265 (defun vcmd-bind-entry (keymap sequence command forms menu) 
266   "Bind SEQUENCE and MENU in KEYMAP to COMMAND. Before calling
267 COMMAND, FORMS will be executed."
268   (let ((fn (if command (apply 'vcmd-get-symbol command forms))))
269     (if sequence
270         (vcmd-bind-key keymap fn sequence))
271     (if menu
272         (let ((symbol (if (symbolp (car menu))
273                           (car menu)
274                         (intern (car menu)))))
275           (vcmd-bind-menu keymap fn (cons 'menu-bar menu))))))
276
277 (defun vcmd-define-key (keymap sequence command &rest menu)
278   "Bind key SEQUENCE in KEYMAP to COMMAND indirectly using vcmd."
279   (vcmd-bind-entry keymap sequence command nil menu))
280
281 (defun vcmd-global-set-key (sequence command &rest menu)
282   "Bind SEQUENCE to COMMAND and possibly MENU in the global keymap.
283
284 See vvmd-define-key for further documentation."
285   (apply 'vcmd-define-key global-map sequence command menu))
286
287 ;;;###autoload
288 (defun vcmd-define-menu (keymap sequence commands &rest menu)
289   "COMMANDS must be a list of lists of the form
290
291     (tag menu command)
292
293 SEQUENCE is bound to a function, which alows the user to select a
294 tag. The menu entries of the commands will appear as a submenu under
295 MENU."
296   (let ((menu-keymap (and (car menu) (make-sparse-keymap (car menu)))))
297     (if (and menu-keymap commands)
298         (progn
299           (loop for command in (reverse commands)
300                 do (define-key 
301                      menu-keymap
302                      (vector (intern (car command)))
303                      (cons (cadr command)
304                            (vcmd-get-symbol (caddr command)))))
305           (if sequence
306               (setf (car (last menu))
307                     (concat (car (last menu))
308                             "    ("
309                             (key-description sequence)
310                             ")")))
311           (vcmd-bind-menu keymap
312                           menu-keymap
313                           (cons 'menu-bar menu))))
314     (if (and sequence commands)
315         (vcmd-bind-key global-map
316                        `(lambda () (interactive) (vcmd-select-command ',commands))
317                        sequence))))
318
319 (defun vcmd-select-command (commands)
320   (let ((tag (completing-read "Command: "
321                               (mapcar (function (lambda (x) (cons (car x) (cadr x))))
322                                       commands)
323                               nil t)))
324     (vcmd (caddr (assoc tag commands)) nil t)))
325
326 (defun vcmd-handler (type handler)
327   "Install HANDLER as handler for TYPE.
328
329 HANDLER must be a function callable with two arguments, the additional
330 arguments from the vcmd call and an interactive flag, which is set
331 on interactive call."
332   (let ((h (assq type vcmd-handlers)))
333     (if h
334         (setcdr h handler)
335       (setq vcmd-handlers (cons (cons type handler)
336                                 vcmd-handlers)))))
337
338 (defun vcmd-flag-handler (flag handler)
339   "Install HANDLER as flag-handler for FLAG.
340
341 HANDLER must be a function callable with two arguments: the definition
342 of a vcmd binding and an aditional list of lisp-forms to evaluate
343 before the vcmd binding. The return value of HANDLER must be a lisp
344 form evaluating the above mentioned expressions. Normally HANDLER will
345 call vcmd-encapsulate-fn on its arguments and wrap the result into
346 additional lisp forms."
347   (let ((h (assq flag vcmd-flag-handlers)))
348     (if h
349         (setcdr h handler)
350       (setq vcmd-flag-handlers (cons (cons flag handler)
351                                      vcmd-flag-handlers)))))
352
353 (fset 'vcmd-bind-menu
354       (if (string-match "XEmacs" emacs-version)
355           (symbol-function 'vcmd-bind-menu-lucid)
356         (symbol-function 'vcmd-bind-menu-FSF)))
357
358 (provide 'varcmd)
359
360 \f
361 ;;; Local Variables:
362 ;;; elisp-project-autoload-file-name: "varcmd-autoload.el"
363 ;;; End: