[STUMP] [PATCH] Modify defprogram-shortcut to define a run-or-pull command/binding.

[John Li]

This is optional. Use the "pull?" keyword to enable. Defaults to old
behavior (no run-or-pull command defined).
---

This requires the run-or-pull patch.

Setting up pull-name is kind of icky. Commands must have distinct
names, so I want to append "-pull" to the name, so I need to convert
between symbols and strings and symbols. Seems like that code can be
stream-lined a bit, but I just want to get this out.


<3


 user.lisp |   15 ++++++++++++---
 1 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/user.lisp b/user.lisp
index 6d6106b..d416e86 100644
--- a/user.lisp
+++ b/user.lisp
@@ -323,12 +323,21 @@ (defcommand copy-unhandled-error () ()
 (defmacro defprogram-shortcut (name &key (command (string-downcase (string 
name)))
                                          (props `'(:class ,(string-capitalize 
command)))
                                          (map *top-map*)
-                                         (key (kbd (concat "H-" (subseq 
command 0 1)))))
-  "define a command and key binding to run or raise a program."
+                                         (key (kbd (concat "H-" (subseq 
command 0 1))))
+                                         (pull? nil)
+                                         (pull-name (intern (concat 
(string-downcase (string name)) "-pull")))
+                                         (pull-key (kbd (concat "H-M-" (subseq 
command 0 1)))))
+  "Define a command and key binding to run or raise a program. If
address@hidden is set, also define a command and key binding to run or
+pull the program."
   `(progn
      (defcommand ,name () ()
        (run-or-raise ,command ,props))
-     (define-key ,map ,key ,(string-downcase (string name)))))
+     (define-key ,map ,key ,(string-downcase (string name)))
+     (when ,pull?
+       (defcommand (,pull-name tile-group) () ()
+          (run-or-pull ,command ,props))
+       (define-key ,map ,pull-key ,(string-downcase (string pull-name))))))
 
 (defcommand show-window-properties () ()
   "Shows the properties of the current window. These properties can be
-- 
1.5.6.5