Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 555 lines (491 sloc) 20.932 kb
f394515c »
2008-05-25 break up user.lisp
1 ;; Copyright (C) 2003-2008 Shawn Betts
2 ;;
3 ;; This file is part of stumpwm.
4 ;;
5 ;; stumpwm is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation; either version 2, or (at your option)
8 ;; any later version.
9
10 ;; stumpwm is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;; GNU General Public License for more details.
14
15 ;; You should have received a copy of the GNU General Public License
d8f75d5b »
2011-09-30 Update FSF address
16 ;; along with this software; see the file COPYING. If not, see
17 ;; <http://www.gnu.org/licenses/>.
f394515c »
2008-05-25 break up user.lisp
18
19 ;; Commentary:
20 ;;
21 ;; implementation of commands
22 ;;
23 ;; Code:
24
25 (in-package #:stumpwm)
26
27 (export '(argument-line-end-p
28 argument-pop
29 argument-pop-or-read
30 argument-pop-rest
31 define-stumpwm-command
32 defcommand
33 defcommand-alias
34 define-stumpwm-type
35 run-commands))
36
37 (defstruct command-alias
38 from to)
39
40 (defstruct command
236a89f4 »
2008-08-03 allow commands to belong to a class and tag commands appropriately
41 name class args)
f394515c »
2008-05-25 break up user.lisp
42
43 (defvar *command-hash* (make-hash-table :test 'eq)
44 "A list of interactive stumpwm commands.")
45
46 (defvar *max-command-alias-depth* 10
47 "")
48
35c29fd1 »
2008-07-17 new condition command-docstring-warning
49 ;; XXX: I'd like to just use straight warn, but sbcl drops to the
50 ;; debugger when compiling so i've made a style warning instead
51 ;; -sabetts
52 (define-condition command-docstring-warning (style-warning)
53 ((command :initarg :command))
54 (:report
55 (lambda (c s)
56 (format s "command ~a doesn't have a docstring" (slot-value c 'command)))))
57
f394515c »
2008-05-25 break up user.lisp
58 (defmacro defcommand (name (&rest args) (&rest interactive-args) &body body)
4626dc58 »
2008-07-15 update NEWS and documentation for defcommand
59 "Create a command function and store its interactive hints in
60 *command-hash*. The local variable %interactivep% can be used to check
61 if the command was called interactively. If it is non-NIL then it was
60417523 »
2008-10-04 document defcommand
62 called from a keybinding or from the colon command.
63
64 INTERACTIVE-ARGS is a list of the following form: ((TYPE PROMPT) (TYPE PROMPT) ...)
65
66 each element in INTERACTIVE-ARGS declares the type and prompt for the
67 command's arguments.
68
69 TYPE can be one of the following:
70
71 @table @var
72 @item :y-or-n
73 A yes or no question returning T or NIL.
74 @item :variable
75 A lisp variable
76 @item :function
77 A lisp function
78 @item :command
79 A stumpwm command as a string.
80 @item :key-seq
81 A key sequence starting from *TOP-MAP*
82 @item :window-number
83 An existing window number
84 @item :number
85 An integer number
86 @item :string
87 A string
88 @item :key
89 A single key chord
90 @item :window-name
91 An existing window's name
92 @item :direction
93 A direction symbol. One of :UP :DOWN :LEFT :RIGHT
94 @item :gravity
95 A gravity symbol. One of :center :top :right :bottom :left :top-right :top-left :bottom-right :bottom-left
96 @item :group
97 An existing group
98 @item :frame
99 A frame
100 @item :shell
101 A shell command
102 @item :rest
103 The rest of the input yes to be parsed.
104 @item :module
105 An existing stumpwm module
106 @end table
107
108 Note that new argument types can be created with DEFINE-STUMPWM-TYPE.
109
110 PROMPT can be string. In this case, if the corresponding argument is
111 missing from an interactive call, stumpwm will use prompt for its
112 value using PROMPT. If PROMPT is missing or nil, then the argument is
113 considered an optional interactive argument and is not prompted for
114 when missing.
115
116 Alternatively, instead of specifying nil for PROMPT or leaving it
117 out, an element can just be the argument type."
e65bd69c »
2008-10-21 fix two minor borkups from the merge
118 (check-type name (or symbol list))
a6732d72 »
2008-07-17 put the command's docstring in the right place
119 (let ((docstring (if (stringp (first body))
120 (first body)
35c29fd1 »
2008-07-17 new condition command-docstring-warning
121 (warn (make-condition 'command-docstring-warning :command name))))
a6732d72 »
2008-07-17 put the command's docstring in the right place
122 (body (if (stringp (first body))
236a89f4 »
2008-08-03 allow commands to belong to a class and tag commands appropriately
123 (cdr body) body))
124 (name (if (atom name)
125 name
126 (first name)))
127 (group (if (atom name)
128 t
129 (second name))))
f394515c »
2008-05-25 break up user.lisp
130 `(progn
41989a16 »
2008-07-15 Modified implementation of defcommand to add a local %interactivep% v…
131 (defun ,name ,args
a6732d72 »
2008-07-17 put the command's docstring in the right place
132 ,docstring
41989a16 »
2008-07-15 Modified implementation of defcommand to add a local %interactivep% v…
133 (let ((%interactivep% *interactivep*)
134 (*interactivep* nil))
9ff9e45f »
2008-07-16 interactive-command renamed to eval-command; new argument "interactivep"
135 (declare (ignorable %interactivep%))
41989a16 »
2008-07-15 Modified implementation of defcommand to add a local %interactivep% v…
136 ,@body))
f394515c »
2008-05-25 break up user.lisp
137 (setf (gethash ',name *command-hash*)
138 (make-command :name ',name
236a89f4 »
2008-08-03 allow commands to belong to a class and tag commands appropriately
139 :class ',group
a6732d72 »
2008-07-17 put the command's docstring in the right place
140 :args ',interactive-args)))))
f394515c »
2008-05-25 break up user.lisp
141
142 (defmacro define-stumpwm-command (name (&rest args) &body body)
143 "Deprecated. use `defcommand' instead."
144 (check-type name string)
2aed028c »
2009-04-24 implement intern1 and use it instead of intern
145 (setf name (intern1 name))
f394515c »
2008-05-25 break up user.lisp
146 `(progn
147 (defun ,name ,(mapcar 'car args) ,@body)
148 (setf (gethash ',name *command-hash*)
149 (make-command :name ',name
150 :args ',(mapcar 'rest args)))))
151
152 (defmacro defcommand-alias (alias original)
153 "Since interactive commands are functions and can conflict with
154 package symbols. But for backwards compatibility this macro creates an
155 alias name for the command that is only accessible interactively."
156 `(setf (gethash ',alias *command-hash*)
157 (make-command-alias :from ',alias
158 :to ',original)))
159
11f665c0 »
2008-08-04 don't allow inactive commands to be called or tab completed
160 (defun dereference-command-symbol (command)
161 "Given a string or symbol look it up in the command database and return
162 whatever it finds: a command, an alias, or nil."
163 (maphash (lambda (k v)
164 (when (string-equal k command)
165 (return-from dereference-command-symbol v)))
166 *command-hash*))
167
168 (defun command-active-p (command)
169 (typep (current-group) (command-class command))
170 ;; TODO: minor modes
171 )
172
173 (defun get-command-structure (command &optional (only-active t))
174 "Return the command structure for COMMAND. COMMAND can be a string,
175 symbol, command, or command-alias. By default only search active
176 commands."
177 (declare (type (or string symbol command command-alias) command))
178 (when (or (stringp command) (symbolp command))
179 (setf command (dereference-command-symbol command)))
180 (when (command-alias-p command)
181 (setf command (loop for c = (gethash (command-alias-to command) *command-hash*)
182 then (gethash (command-alias-to c) *command-hash*)
183 for depth from 1
184 until (or (null c)
185 (command-p c))
186 when (> depth *max-command-alias-depth*)
187 do (error "Maximum command alias depth exceded")
188 finally (return c))))
189 (when (and command
190 (or (not only-active)
191 (command-active-p command)))
192 command))
193
194 (defun all-commands (&optional (only-active t))
195 "Return a list of all interactive commands as strings. By default
196 only return active commands."
f394515c »
2008-05-25 break up user.lisp
197 (let (acc)
198 (maphash (lambda (k v)
11f665c0 »
2008-08-04 don't allow inactive commands to be called or tab completed
199 ;; make sure its an active command
200 (when (get-command-structure v only-active)
201 (push (string-downcase k) acc)))
f394515c »
2008-05-25 break up user.lisp
202 *command-hash*)
203 (sort acc 'string<)))
204
205 ;;; command arguments
206
207 (defstruct argument-line
208 string start)
209
210 (defvar *command-type-hash* (make-hash-table)
211 "A hash table of types and functions to deal with these types.")
212
213 (defun argument-line-end-p (input)
214 "Return T if we're outta arguments from the input line."
215 (>= (argument-line-start input)
216 (length (argument-line-string input))))
217
218 (defun argument-pop (input)
219 "Pop the next argument off."
220 (unless (argument-line-end-p input)
221 (let* ((p1 (position-if-not (lambda (ch)
222 (char= ch #\Space))
223 (argument-line-string input)
224 :start (argument-line-start input)))
225 (p2 (or (and p1 (position #\Space (argument-line-string input) :start p1))
226 (length (argument-line-string input)))))
227 (prog1
228 ;; we wanna return nil if they're the same
229 (unless (= p1 p2)
230 (subseq (argument-line-string input) p1 p2))
231 (setf (argument-line-start input) (1+ p2))))))
232
233 (defun argument-pop-or-read (input prompt &optional completions)
234 (or (argument-pop input)
235 (if completions
236 (completing-read (current-screen) prompt completions)
237 (read-one-line (current-screen) prompt))
238 (throw 'error :abort)))
239
240 (defun argument-pop-rest (input)
241 "Return the remainder of the argument text."
242 (unless (argument-line-end-p input)
243 (prog1
244 (subseq (argument-line-string input) (argument-line-start input))
245 (setf (argument-line-start input) (length (argument-line-string input))))))
246
247 (defun argument-pop-rest-or-read (input prompt &optional completions)
248 (or (argument-pop-rest input)
249 (if completions
250 (completing-read (current-screen) prompt completions)
251 (read-one-line (current-screen) prompt))
252 (throw 'error :abort)))
253
254 (defmacro define-stumpwm-type (type (input prompt) &body body)
6dd2cd30 »
2008-06-22 Auto generate macro documentation from source code docstrings
255 "Create a new type that can be used for command arguments. @var{type} can be any symbol.
256
257 When @var{body} is evaluated @var{input} is bound to the
258 argument-line. It is passed to @code{argument-pop},
259 @code{argument-pop-rest}, etc. @var{prompt} is the prompt that should
260 be used when prompting the user for the argument.
261
262 @example
263 \(define-stumpwm-type :symbol (input prompt)
264 (or (find-symbol (string-upcase
265 (or (argument-pop input)
266 ;; Whitespace messes up find-symbol.
267 (string-trim \" \"
268 (completing-read (current-screen)
269 prompt
270 ;; find all symbols in the
271 ;; stumpwm package.
272 (let (acc)
273 (do-symbols (s (find-package \"STUMPWM\"))
274 (push (string-downcase (symbol-name s)) acc))
275 acc)))
276 (throw 'error \"Abort.\")))
277 \"STUMPWM\")
278 (throw 'error \"Symbol not in STUMPWM package\")))
279
280 \(defcommand \"symbol\" (sym) ((:symbol \"Pick a symbol: \"))
281 (message \"~a\" (with-output-to-string (s)
282 (describe sym s))))
283 @end example
284
285 This code creates a new type called @code{:symbol} which finds the
286 symbol in the stumpwm package. The command @code{symbol} uses it and
287 then describes the symbol."
f394515c »
2008-05-25 break up user.lisp
288 `(setf (gethash ,type *command-type-hash*)
289 (lambda (,input ,prompt)
290 ,@body)))
291
292 (define-stumpwm-type :y-or-n (input prompt)
293 (let ((s (or (argument-pop input)
294 (read-one-line (current-screen) (concat prompt "(y/n): ")))))
295 (when s
296 (values (list (equal s "y"))))))
297
298 (defun lookup-symbol (string)
299 ;; FIXME: should we really use string-upcase?
300 (let* ((ofs (split-string string ":"))
301 (pkg (if (> (length ofs) 1)
302 (find-package (string-upcase (pop ofs)))
303 *package*))
304 (var (string-upcase (pop ofs)))
305 (ret (find-symbol var pkg)))
306 (when (plusp (length ofs))
307 (throw 'error "Too many :'s"))
308 (if ret
309 (values ret pkg var)
310 (throw 'error (format nil "No such symbol: ~a::~a."
311 (package-name pkg) var)))))
312
313 (define-stumpwm-type :variable (input prompt)
314 (lookup-symbol (argument-pop-or-read input prompt)))
315
316 (define-stumpwm-type :function (input prompt)
317 (multiple-value-bind (sym pkg var)
318 (lookup-symbol (argument-pop-or-read input prompt))
319 (if (symbol-function sym)
320 (symbol-function sym)
321 (throw 'error (format nil "the symbol ~a::~a has no function."
322 (package-name pkg) var)))))
323
324 (define-stumpwm-type :command (input prompt)
325 (or (argument-pop input)
3c4a53cd »
2009-07-13 make completing-read trim spaces off the beginning and end of the input
326 (completing-read (current-screen)
327 prompt
328 (all-commands))))
f394515c »
2008-05-25 break up user.lisp
329
330 (define-stumpwm-type :key-seq (input prompt)
331 (labels ((update (seq)
332 (message "~a: ~{~a ~}"
333 prompt
334 (mapcar 'print-key (reverse seq)))))
335 (let ((rest (argument-pop-rest input)))
336 (or (and rest (parse-key-seq rest))
337 ;; read a key sequence from the user
338 (with-focus (screen-key-window (current-screen))
339 (message "~a" prompt)
340 (nreverse (second (multiple-value-list
9fe89bb4 »
2008-08-27 fix :key-seq type to work with read-from-keymap
341 (read-from-keymap (top-maps) #'update)))))))))
f394515c »
2008-05-25 break up user.lisp
342
343 (define-stumpwm-type :window-number (input prompt)
344 (let ((n (or (argument-pop input)
345 (completing-read (current-screen)
346 prompt
cdc3d038 »
2011-03-28 make window-number work appropriately
347 (mapcar 'window-map-number
348 (group-windows (current-group)))))))
f394515c »
2008-05-25 break up user.lisp
349 (when n
cdc3d038 »
2011-03-28 make window-number work appropriately
350 (let ((win (find n (group-windows (current-group))
351 :test #'string=
352 :key #'window-map-number)))
353 (if win
354 (window-number win)
355 (throw 'error "No Such Window."))))))
f394515c »
2008-05-25 break up user.lisp
356
357 (define-stumpwm-type :number (input prompt)
358 (let ((n (or (argument-pop input)
359 (read-one-line (current-screen) prompt))))
360 (when n
361 (handler-case
362 (parse-integer n)
363 (parse-error (c)
364 (declare (ignore c))
365 (throw 'error "Number required."))))))
366
367
368 (define-stumpwm-type :string (input prompt)
369 (or (argument-pop input)
370 (read-one-line (current-screen) prompt)))
371
2fc9af68 »
2011-04-13 Add a password mode to read-one-line and a new :password stumpwm-type.
372 (define-stumpwm-type :password (input prompt)
373 (or (argument-pop input)
374 (read-one-line (current-screen) prompt :password t)))
375
f394515c »
2008-05-25 break up user.lisp
376 (define-stumpwm-type :key (input prompt)
377 (let ((s (or (argument-pop input)
378 (read-one-line (current-screen) prompt))))
379 (when s
380 (kbd s))))
381
382 (define-stumpwm-type :window-name (input prompt)
383 (or (argument-pop input)
384 (completing-read (current-screen) prompt
385 (mapcar 'window-name
386 (group-windows (current-group))))))
387
388 (define-stumpwm-type :direction (input prompt)
389 (let* ((values '(("up" :up)
390 ("down" :down)
391 ("left" :left)
392 ("right" :right)))
3c4a53cd »
2009-07-13 make completing-read trim spaces off the beginning and end of the input
393 (dir (second (assoc (argument-pop-or-read input prompt values)
f394515c »
2008-05-25 break up user.lisp
394 values :test 'string-equal))))
395 (or dir
396 (throw 'error "No matching direction."))))
397
398 (define-stumpwm-type :gravity (input prompt)
399 "Set the current window's gravity."
400 (let* ((values '(("center" :center)
401 ("top" :top)
402 ("right" :right)
403 ("bottom" :bottom)
404 ("left" :left)
405 ("top-right" :top-right)
406 ("top-left" :top-left)
407 ("bottom-right" :bottom-right)
408 ("bottom-left" :bottom-left)))
2f052dbd »
2009-10-05 Fixed a paren typo introduced by 'make completing-read trim spaces of…
409 (gravity (second (assoc (argument-pop-or-read input prompt values) values :test 'string-equal))))
f394515c »
2008-05-25 break up user.lisp
410 (or gravity
411 (throw 'error "No matching gravity."))))
412
413 (defun select-group (screen query)
414 "Attempt to match string QUERY against group number or partial name."
03751622 »
2011-03-17 Use *group-number-map* in select-group.
415 (labels ((match-num (grp)
931adde2 »
2011-11-19 Return strings from window-map-number and group-map-number.
416 (string-equal (group-map-number grp) query))
03751622 »
2011-03-17 Use *group-number-map* in select-group.
417 (match-whole (grp)
418 (string-equal (group-name grp) query))
419 (match-partial (grp)
420 (let* ((end (min (length (group-name grp)) (length query))))
421 (string-equal (group-name grp) query :end1 end :end2 end))))
422 (when query
423 (or (find-if #'match-num (screen-groups screen))
424 (find-if #'match-whole (screen-groups screen))
425 (find-if #'match-partial (screen-groups screen))))))
f394515c »
2008-05-25 break up user.lisp
426
427 (define-stumpwm-type :group (input prompt)
428 (let ((match (select-group (current-screen)
429 (or (argument-pop input)
430 (completing-read (current-screen) prompt
431 (mapcar 'group-name
432 (screen-groups (current-screen))))))))
433 (or match
434 (throw 'error "No Such Group."))))
435
436 (define-stumpwm-type :frame (input prompt)
437 (declare (ignore prompt))
438 (let ((arg (argument-pop input)))
439 (if arg
440 (or (find arg (group-frames (current-group))
441 :key (lambda (f)
442 (string (get-frame-number-translation f)))
443 :test 'string=)
444 (throw 'error "Frame not found."))
445 (or (choose-frame-by-number (current-group))
446 (throw 'error :abort)))))
447
448 (define-stumpwm-type :shell (input prompt)
449 (or (argument-pop-rest input)
450 (completing-read (current-screen) prompt 'complete-program)))
451
452 (define-stumpwm-type :rest (input prompt)
453 (or (argument-pop-rest input)
454 (read-one-line (current-screen) prompt)))
455
456 ;;;
457
458 (defun call-interactively (command &optional (input ""))
459 "Parse the command's arguments from input given the command's
460 argument specifications then execute it. Returns a string or nil if
461 user aborted."
462 (declare (type (or string symbol) command)
463 (type (or string argument-line) input))
464 ;; Catch parse errors
465 (catch 'error
466 (let* ((arg-line (if (stringp input)
467 (make-argument-line :string input
468 :start 0)
469 input))
470 (cmd-data (or (get-command-structure command)
471 (throw 'error (format nil "Command '~a' not found." command))))
472 (arg-specs (command-args cmd-data))
473 (args (loop for spec in arg-specs
474 collect (let* ((type (if (listp spec)
475 (first spec)
476 spec))
477 (prompt (when (listp spec)
478 (second spec)))
479 (fn (gethash type *command-type-hash*)))
480 (unless fn
481 (throw 'error (format nil "Bad argument type: ~s" type)))
482 ;; If the prompt is NIL then it's
483 ;; considered an optional argument and
484 ;; we shouldn't prompt for it if the
485 ;; arg line is empty.
486 (if (and (null prompt)
487 (argument-line-end-p arg-line))
488 (loop-finish)
489 ;; FIXME: Is it presumptuous to assume NIL means abort?
490 (or (funcall fn arg-line prompt)
491 (throw 'error :abort)))))))
492 ;; Did the whole string get parsed?
493 (unless (or (argument-line-end-p arg-line)
494 (position-if 'alphanumericp (argument-line-string arg-line) :start (argument-line-start arg-line)))
495 (throw 'error (format nil "Trailing garbage: ~{~A~^ ~}" (subseq (argument-line-string arg-line)
496 (argument-line-start arg-line)))))
497 ;; Success
498 (prog1
499 (apply (command-name cmd-data) args)
500 (setf *last-command* command)))))
501
9ff9e45f »
2008-07-16 interactive-command renamed to eval-command; new argument "interactivep"
502 (defun eval-command (cmd &optional interactivep)
f394515c »
2008-05-25 break up user.lisp
503 "exec cmd and echo the result."
504 (labels ((parse-and-run-command (input)
505 (let* ((arg-line (make-argument-line :string input
506 :start 0))
507 (cmd (argument-pop arg-line)))
9ff9e45f »
2008-07-16 interactive-command renamed to eval-command; new argument "interactivep"
508 (let ((*interactivep* interactivep))
509 (call-interactively cmd arg-line)))))
f394515c »
2008-05-25 break up user.lisp
510 (multiple-value-bind (result error-p)
511 ;; this fancy footwork lets us grab the backtrace from where the
512 ;; error actually happened.
513 (restart-case
514 (handler-bind
515 ((error (lambda (c)
9ff9e45f »
2008-07-16 interactive-command renamed to eval-command; new argument "interactivep"
516 (invoke-restart 'eval-command-error
f394515c »
2008-05-25 break up user.lisp
517 (format nil "^B^1*Error In Command '^b~a^B': ^n~A~a"
518 cmd c (if *show-command-backtrace*
519 (backtrace-string) ""))))))
520 (parse-and-run-command cmd))
9ff9e45f »
2008-07-16 interactive-command renamed to eval-command; new argument "interactivep"
521 (eval-command-error (err-text)
f394515c »
2008-05-25 break up user.lisp
522 (values err-text t)))
523 ;; interactive commands update the modeline
524 (update-all-mode-lines)
525 (cond ((stringp result)
526 (if error-p
527 (message-no-timeout "~a" result)
528 (message "~a" result)))
529 ((eq result :abort)
530 (unless *suppress-abort-messages*
531 (message "Abort.")))))))
532
533 (defun run-commands (&rest commands)
534 "Run each stumpwm command in sequence. This could be used if you're
535 used to ratpoison's rc file and you just want to run commands or don't
536 know lisp very well. One might put the following in one's rc file:
537
538 @example
539 \(stumpwm:run-commands
540 \"escape C-z\"
541 \"exec firefox\"
542 \"split\")
543 @end example"
544 (loop for i in commands do
9ff9e45f »
2008-07-16 interactive-command renamed to eval-command; new argument "interactivep"
545 (eval-command i)))
f394515c »
2008-05-25 break up user.lisp
546
547 (defcommand colon (&optional initial-input) (:rest)
548 "Read a command from the user. @var{initial-text} is optional. When
549 supplied, the text will appear in the prompt."
0a745aec »
2010-12-28 Fix passing arguments with 'colon'.
550 (let ((cmd (completing-read (current-screen) ": " (all-commands) :initial-input (or initial-input ""))))
f394515c »
2008-05-25 break up user.lisp
551 (unless cmd
552 (throw 'error :abort))
553 (when (plusp (length cmd))
9ff9e45f »
2008-07-16 interactive-command renamed to eval-command; new argument "interactivep"
554 (eval-command cmd t))))
Something went wrong with that request. Please try again.