-
Notifications
You must be signed in to change notification settings - Fork 0
/
user.lisp
403 lines (360 loc) · 17 KB
/
user.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
;; Copyright (C) 2003-2008 Shawn Betts
;;
;; This file is part of thesiswm.
;;
;; thesiswm is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; thesiswm is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, see
;; <http://www.gnu.org/licenses/>.
;; Commentary:
;;
;; Window Manager commands that users can use to manipulate thesiswm.
;;
;; Code:
(in-package :thesiswm)
(export '(defprogram-shortcut
pathname-is-executable-p
programs-in-path
restarts-menu
run-or-raise
run-or-pull
run-shell-command
window-send-string))
(defun restarts-menu (err)
"Display a menu with the active restarts and let the user pick
one. Error is the error being recovered from. If the user aborts the
menu, the error is re-signalled."
(let ((restart (select-from-menu (current-screen)
(mapcar (lambda (r)
(list (format nil "[~a] ~a"
(restart-name r)
(substitute #\Space
#\Newline
(write-to-string r :escape nil)))
r))
;; a crusty way to get only
;; the restarts from
;; thesiswm's top-level
;; restart inward.
(reverse (member 'top-level
(reverse (compute-restarts))
:key 'restart-name)))
(format nil "Error: ~a"
(substitute #\Space
#\Newline
(write-to-string err :escape nil))))))
(when restart
(invoke-restart (second restart)))))
(defun banish-pointer (&optional (where *banish-pointer-to*))
"Move the pointer to the lower right corner of the head, or
WHEREever (one of :screen :head :frame or :window)"
(let* ((screen (current-screen))
(group (current-group))
(head (current-head))
(frame (tile-group-current-frame group))
(window (frame-window frame))
(x (1- (+ (frame-x frame) (frame-width frame))))
(y (1- (+ (frame-display-y group frame) (frame-display-height group frame)))))
(ecase where
(:screen
(setf x (1- (+ (screen-x screen) (screen-width screen)))
y (1- (+ (screen-y screen) (screen-height screen)))))
(:head
(setf x (1- (+ (head-x head) (head-width head)))
y (1- (+ (head-y head) (head-height head)))))
(:frame)
(:window
(when window
(let ((win (window-parent window)))
(setf x (1- (+ (xlib:drawable-x win) (xlib:drawable-width win)))
y (1- (+ (xlib:drawable-y win) (xlib:drawable-height win))))))))
(warp-pointer (group-screen group) x y)))
(defcommand banish (&optional where) (:rest)
"Warp the mouse the lower right corner of the current head."
(if where
(banish-pointer (intern1 where :keyword))
(banish-pointer)))
(defcommand ratwarp (x y) ((:number "X: ") (:number "Y: "))
"Warp the mouse to the specified location."
(warp-pointer (current-screen) x y))
(defcommand ratrelwarp (dx dy) ((:number "Delta X: ") (:number "Delta Y: "))
"Warp the mouse by the specified amount from its current position."
(warp-pointer-relative dx dy))
(defcommand ratclick (&optional (button 1)) (:number)
"Simulate a pointer button event at the current pointer
location. Note: this function is unlikely to work unless
your X server and CLX implementation support XTEST."
(when (current-window)
(send-fake-click (current-window) button)))
(defun programs-in-path (&optional full-path (path (split-string (getenv "PATH") ":")))
"Return a list of programs in the path. if @var{full-path} is
@var{t} then return the full path, otherwise just return the
filename. @var{path} is by default the @env{PATH} evironment variable
but can be specified. It should be a string containing each directory
seperated by a colon."
(sort
(loop for p in path
for dir = (probe-path p)
when dir
nconc (loop for file in (directory (merge-pathnames (make-pathname :name :wild :type :wild) dir)
:resolve-symlinks nil)
for namestring = (file-namestring file)
when (pathname-is-executable-p file)
collect (if full-path
(namestring file)
namestring)))
#'string<))
(defstruct path-cache
programs modification-dates paths)
(defvar *path-cache* nil
"A cache containing the programs in the path, used for completion.")
(defun rehash (&optional (paths (mapcar 'parse-namestring (split-string (getenv "PATH") ":"))))
"Update the cache of programs in the path stored in @var{*programs-list*} when needed."
(let ((dates (mapcar (lambda (p)
(when (probe-path p)
(file-write-date p)))
paths)))
(finish-output)
(unless (and *path-cache*
(equal (path-cache-paths *path-cache*) paths)
(equal (path-cache-modification-dates *path-cache*) dates))
(setf *path-cache* (make-path-cache :programs (programs-in-path nil paths)
:modification-dates dates
:paths paths)))))
(defun complete-program (base)
"return the list of programs in @var{*path-cache*} whose names begin
with base. Automagically update the cache."
(rehash)
(remove-if-not #'(lambda (p)
(when (<= (length base) (length p))
(string= base p
:end1 (length base)
:end2 (length base)))) (path-cache-programs *path-cache*)))
(defcommand run-shell-command (cmd &optional collect-output-p) ((:shell "/bin/sh -c "))
"Run the specified shell command. If @var{collect-output-p} is @code{T}
then run the command synchonously and collect the output. Be
careful. If the shell command doesn't return, it will hang StumpWM. In
such a case, kill the shell command to resume StumpWM."
(if collect-output-p
(run-prog-collect-output *shell-program* "-c" cmd)
(run-prog *shell-program* :args (list "-c" cmd) :wait nil)))
(defcommand-alias exec run-shell-command)
(defcommand eval-line (cmd) ((:rest "Eval: "))
"Evaluate the s-expression and display the result(s)."
(handler-case
(if cmd
(message "^20~{~a~^~%~}"
(mapcar 'prin1-to-string
(multiple-value-list (eval (read-from-string cmd)))))
(throw 'error :abort))
(error (c)
(err "^B^1*~A" c))))
(defcommand-alias eval eval-line)
(defcommand echo (string) ((:rest "Echo: "))
"Display @var{string} in the message bar."
;; The purpose of echo is always to pop up a message window.
(let ((*executing-thesiswm-command* nil))
(message "~a" string)))
(defun send-meta-key (screen key)
"Send the key to the current window on the specified screen."
(when (screen-current-window screen)
(send-fake-key (screen-current-window screen) key)))
(defcommand meta (key) ((:key "Key: "))
"Send a fake key to the current window. @var{key} is a typical StumpWM key, like @kbd{C-M-o}."
(send-meta-key (current-screen) key))
(defcommand loadrc () ()
"Reload the @file{~/.thesiswmrc} file."
(handler-case
(progn
(with-restarts-menu (load-rc-file nil)))
(error (c)
(message "^1*^BError loading rc file: ^n~A" c))
(:no-error (&rest args)
(declare (ignore args))
(message "rc file loaded successfully."))))
(defcommand keyboard-quit () ()
""
;; This way you can exit from command mode
(let ((in-command-mode (eq *top-map* *root-map*)))
(when (pop-top-map)
(if in-command-mode
(run-hook *command-mode-end-hook*)
(message "Exited.")))))
(defcommand-alias abort keyboard-quit)
(defcommand quit () ()
"Quit StumpWM."
(throw :top-level :quit))
(defcommand restart-soft () ()
"Soft Restart StumpWM. The lisp process isn't restarted. Instead,
control jumps to the very beginning of the thesiswm program. This
differs from RESTART, which restarts the unix process.
Since the process isn't restarted, existing customizations remain
after the restart."
(throw :top-level :restart))
(defcommand restart-hard () ()
"Restart thesiswm. This is handy if a new thesiswm executable has been
made and you wish to replace the existing process with it.
Any run-time customizations will be lost after the restart."
(throw :top-level :hup-process))
(defun find-matching-windows (props all-groups all-screens)
"Returns list of windows matching @var{props} (see run-or-raise
documentation for details). @var{all-groups} will find windows on all
groups. Same for @{all-screens}. Result is sorted by group and window
number, with group being more significant (think radix sort)."
(let* ((screens (if all-screens
*screen-list*
(list (current-screen))))
(winlist (if all-groups
(mapcan (lambda (s) (screen-windows s)) screens)
(group-windows (current-group))))
(matches (remove-if-not (lambda (w)
(apply 'window-matches-properties-p w props))
winlist)))
(stable-sort (sort matches #'< :key #'window-number)
#'< :key (lambda (w) (group-number (window-group w))))))
(defun run-or-raise (cmd props &optional (all-groups *run-or-raise-all-groups*)
(all-screens *run-or-raise-all-screens*))
"Run the shell command, @var{cmd}, unless an existing window
matches @var{props}. @var{props} is a property list with the following keys:
@table @code
@item :class
Match the window's class.
@item :instance
Match the window's instance or resource-name.
@item :role
Match the window's @code{WM_WINDOW_ROLE}.
@item :title
Match the window's title.
@end table
By default, the global @var{*run-or-raise-all-groups*} decides whether
to search all groups or the current one for a running
instance. @var{all-groups} overrides this default. Similarily for
@var{*run-or-raise-all-screens*} and @var{all-screens}."
(labels
;; Raise the window win and select its frame. For now, it
;; does not select the screen.
((goto-win (win)
(let* ((group (window-group win))
(frame (window-frame win))
(old-frame (tile-group-current-frame group)))
(focus-all win)
(unless (eq frame old-frame)
(show-frame-indicator group)))))
(let* ((matches (find-matching-windows props all-groups all-screens))
;; other-matches is list of matches "after" the current
;; win, if current win matches. getting 2nd element means
;; skipping over the current win, to cycle through matches
(other-matches (member (current-window) matches))
(win (if (> (length other-matches) 1)
(second other-matches)
(first matches))))
(if win
(if (eq (type-of (window-group win)) 'float-group)
(focus-all win)
(goto-win win))
(run-shell-command cmd)))))
(defun run-or-pull (cmd props &optional (all-groups *run-or-raise-all-groups*)
(all-screens *run-or-raise-all-screens*))
"Similar to run-or-raise, but move the matching window to the
current frame instead of switching to the window."
(let* ((matches (find-matching-windows props all-groups all-screens))
;; other-matches is for cycling through matches
(other-matches (member (current-window) matches))
(win (if (> (length other-matches) 1)
(second other-matches)
(first matches))))
(if win
(progn
(move-window-to-group win (current-group))
(pull-window win))
(run-shell-command cmd))))
(defcommand reload () ()
"Reload StumpWM using @code{asdf}."
(message "Reloading StumpWM...")
#+asdf (with-restarts-menu
(asdf:operate 'asdf:load-op :thesiswm))
#-asdf (message "^B^1*Sorry, StumpWM can only be reloaded with asdf (for now.)")
#+asdf (message "Reloading StumpWM...^B^2*Done^n."))
(defcommand emacs () ()
"Start emacs unless it is already running, in which case focus it."
(run-or-raise "emacs" '(:class "Emacs")))
(defcommand copy-unhandled-error () ()
"When an unhandled error occurs, StumpWM restarts and attempts to
continue. Unhandled errors should be reported to the mailing list so
they can be fixed. Use this command to copy the unhandled error and
backtrace to the X11 selection so you can paste in your email when
submitting the bug report."
(if *last-unhandled-error*
(progn
(set-x-selection (format nil "~a~%~a" (first *last-unhandled-error*) (second *last-unhandled-error*)))
(message "Copied to clipboard."))
(message "There was no 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))))
(pullp nil)
(pull-name (intern1 (concat (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
@var{pullp} 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)))
,(when pullp
`(progn
(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
used for matching windows with run-or-raise or window placement
rules."
(let ((w (current-window)))
(if (not w)
(message "No active window!")
(message-no-timeout "class: ~A~%instance: ~A~%type: :~A~%role: ~A~%title: ~A"
(window-class w)
(window-res w)
(string (window-type w))
(window-role w)
(window-title w)))))
(defcommand list-window-properties () ()
"List all the properties of the current window and their values,
like xprop."
(message-no-timeout
"~{~30a: ~a~^~%~}"
(let ((win (if (current-window)
(window-xwin (current-window))
(screen-root (current-screen)))))
(loop for i in (xlib:list-properties win)
collect i
collect (multiple-value-bind (values type)
(xlib:get-property win i)
(case type
(:wm_state (format nil "~{~a~^, ~}"
(loop for v in values
collect (case v (0 "Iconic") (1 "Normal") (2 "Withdrawn") (t "Unknown")))))
(:window i)
;; _NET_WM_ICON is huuuuuge
(:cardinal (if (> (length values) 20)
(format nil "~{~d~^, ~}..." (subseq values 0 15))
(format nil "~{~d~^, ~}" values)))
(:atom (format nil "~{~a~^, ~}"
(mapcar (lambda (v) (xlib:atom-name *display* v)) values)))
(:string (format nil "~{~s~^, ~}"
(mapcar (lambda (x) (coerce (mapcar 'xlib:card8->char x) 'string))
(split-seq values '(0)))))
(:utf8_string (format nil "~{~s~^, ~}"
(mapcar 'utf8-to-string
(split-seq values '(0)))))
(t values)))))))