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: