-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathprimitives.lisp
1241 lines (1031 loc) · 42.3 KB
/
primitives.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
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;; 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:
;;
;; This file contains primitive data structures and functions used
;; throughout thesiswm.
;;
;; Code:
(in-package :thesiswm)
(export '(*suppress-abort-messages*
*suppress-frame-indicator*
*suppress-window-placement-indicator*
*timeout-wait*
*timeout-frame-indicator-wait*
*frame-indicator-text*
*frame-indicator-timer*
*message-window-timer*
*command-mode-start-hook*
*command-mode-end-hook*
*urgent-window-hook*
*new-window-hook*
*destroy-window-hook*
*focus-window-hook*
*place-window-hook*
*start-hook*
*restart-hook*
*quit-hook*
*internal-loop-hook*
*event-processing-hook*
*focus-frame-hook*
*new-frame-hook*
*split-frame-hook*
*message-hook*
*top-level-error-hook*
*focus-group-hook*
*key-press-hook*
*root-click-hook*
*new-mode-line-hook*
*destroy-mode-line-hook*
*mode-line-click-hook*
*pre-command-hook*
*post-command-hook*
*selection-notify-hook*
*display*
*shell-program*
*maxsize-border-width*
*transient-border-width*
*normal-border-width*
*text-color*
*window-events*
*window-parent-events*
*message-window-padding*
*message-window-gravity*
*editor-bindings*
*input-window-gravity*
*normal-gravity*
*maxsize-gravity*
*transient-gravity*
*top-level-error-action*
*window-name-source*
*frame-number-map*
*all-modifiers*
*modifiers*
*screen-list*
*initializing*
*processing-existing-windows*
*executing-thesiswm-command*
*debug-level*
*debug-expose-events*
*debug-stream*
*window-formatters*
*window-format*
*group-formatters*
*group-format*
*list-hidden-groups*
*x-selection*
*last-command*
*max-last-message-size*
*record-last-msg-override*
*suppress-echo-timeout*
*run-or-raise-all-groups*
*run-or-raise-all-screens*
*deny-map-request*
*deny-raise-request*
*suppress-deny-messages*
*honor-window-moves*
*resize-hides-windows*
*min-frame-width*
*min-frame-height*
*new-frame-action*
*new-window-preferred-frame*
*startup-message*
*default-package*
*window-placement-rules*
*mouse-focus-policy*
*root-click-focuses-frame*
*banish-pointer-to*
*xwin-to-window*
*resize-map*
*default-group-name*
*window-border-style*
*data-dir*
add-hook
clear-window-placement-rules
concat
data-dir-file
dformat
define-frame-preference
redirect-all-output
remove-hook
remove-all-hooks
run-hook
run-hook-with-args
command-mode-start-message
command-mode-end-message
split-string
with-restarts-menu
with-data-file
move-to-head
format-expand
;; Frame accessors
frame-x
frame-y
frame-width
frame-height
;; Screen accessors
screen-heads
screen-root
screen-focus
screen-float-focus-color
screen-float-unfocus-color
;; Window states
+withdrawn-state+
+normal-state+
+iconic-state+
;; Modifiers
modifiers
modifiers-p
modifiers-alt
modifiers-altgr
modifiers-super
modifiers-meta
modifiers-hyper
modifiers-numlock
;; Conditions
thesiswm-condition
thesiswm-error
thesiswm-warning))
;;; Message Timer
(defvar *suppress-abort-messages* nil
"Suppress abort message when non-nil.")
(defvar *timeout-wait* 5
"Specifies, in seconds, how long a message will appear for. This must
be an integer.")
(defvar *timeout-frame-indicator-wait* 1
"The amount of time a frame indicator timeout takes.")
(defvar *frame-indicator-timer* nil
"Keep track of the timer that hides the frame indicator.")
(defvar *frame-indicator-text* " Current Frame "
"What appears in the frame indicator window?")
(defvar *suppress-frame-indicator* nil
"Set this to T if you never want to see the frame indicator.")
(defvar *suppress-window-placement-indicator* nil
"Set to T if you never want to see messages that windows were placed
according to rules.")
(defvar *message-window-timer* nil
"Keep track of the timer that hides the message window.")
;;; Grabbed pointer
(defvar *grab-pointer-count* 0
"The number of times the pointer has been grabbed.")
(defvar *grab-pointer-font* "cursor"
"The font used for the grabbed pointer.")
(defvar *grab-pointer-character* 64
"ID of a character used for the grabbed pointer.")
(defvar *grab-pointer-character-mask* 65
"ID of a character mask used for the grabbed pointer.")
(defvar *grab-pointer-foreground*
(xlib:make-color :red 0.0 :green 0.0 :blue 0.0)
"The foreground color of the grabbed pointer.")
(defvar *grab-pointer-background*
(xlib:make-color :red 1.0 :green 1.0 :blue 1.0)
"The background color of the grabbed pointer.")
;;; Hooks
(defvar *command-mode-start-hook* '(command-mode-start-message)
"A hook called whenever command mode is started")
(defvar *command-mode-end-hook* '(command-mode-end-message)
"A hook called whenever command mode is ended")
(defvar *urgent-window-hook* '()
"A hook called whenever a window sets the property indicating that
it demands the user's attention")
(defvar *map-window-hook* '()
"A hook called whenever a window is mapped.")
(defvar *unmap-window-hook* '()
"A hook called whenever a window is withdrawn.")
(defvar *new-window-hook* '()
"A hook called whenever a window is added to the window list. This
includes a genuinely new window as well as bringing a withdrawn window
back into the window list.")
(defvar *destroy-window-hook* '()
"A hook called whenever a window is destroyed or withdrawn.")
(defvar *focus-window-hook* '()
"A hook called when a window is given focus. It is called with 2
arguments: the current window and the last window (could be nil).")
(defvar *place-window-hook* '()
"A hook called whenever a window is placed by rule. Arguments are
window group and frame")
(defvar *start-hook* '()
"A hook called when thesiswm starts.")
(defvar *quit-hook* '()
"A hook called when thesiswm quits.")
(defvar *restart-hook* '()
"A hook called when thesiswm restarts.")
(defvar *internal-loop-hook* '()
"A hook called inside thesiswm's inner loop.")
(defvar *event-processing-hook* '()
"A hook called inside thesiswm's inner loop, before the default event
processing takes place. This hook is run inside (with-event-queue ...).")
(defvar *focus-frame-hook* '()
"A hook called when a frame is given focus. The hook functions are
called with 2 arguments: the current frame and the last frame.")
(defvar *new-frame-hook* '()
"A hook called when a new frame is created. the hook is called with
the frame as an argument.")
(defvar *split-frame-hook* '()
"A hook called when a frame is split. the hook is called with
the old frame (window is removed), and two new frames as arguments.")
(defvar *message-hook* '()
"A hook called whenever thesiswm displays a message. The hook
function is passed any number of arguments. Each argument is a
line of text.")
(defvar *top-level-error-hook* '()
"Called when a top level error occurs. Note that this hook is
run before the error is dealt with according to
*top-level-error-action*.")
(defvar *focus-group-hook* '()
"A hook called whenever thesiswm switches groups. It is called with 2 arguments: the current group and the last group.")
(defvar *key-press-hook* '()
"A hook called whenever a key under *top-map* is pressed.
It is called with 3 argument: the key, the (possibly incomplete) key
sequence it is a part of, and command value bound to the key.")
(defvar *root-click-hook* '()
"A hook called whenever there is a mouse click on the root
window. Called with 4 arguments, the screen containing the root
window, the button clicked, and the x and y of the pointer.")
(defvar *new-mode-line-hook* '()
"Called whenever the mode-line is created. It is called with argument,
the mode-line")
(defvar *destroy-mode-line-hook* '()
"Called whenever the mode-line is destroyed. It is called with argument,
the mode-line")
(defvar *mode-line-click-hook* '()
"Called whenever the mode-line is clicked. It is called with 4 arguments,
the mode-line, the button clicked, and the x and y of the pointer.")
(defvar *pre-command-hook* '()
"Called before a command is called. It is called with 1 argument:
the command as a symbol.")
(defvar *post-command-hook* '()
"Called after a command is called. It is called with 1 argument:
the command as a symbol.")
(defvar *selection-notify-hook* '()
"Called after a :selection-notify event is processed. It is called
with 1 argument: the selection as a string.")
;; Data types and globals used by thesiswm
(defvar *display* nil
"The display for the X server")
(defvar *shell-program* "/bin/sh"
"The shell program used by @code{run-shell-command}.")
(defvar *maxsize-border-width* 1
"The width in pixels given to the borders of windows with maxsize or ratio hints.")
(defvar *transient-border-width* 1
"The width in pixels given to the borders of transient or pop-up windows.")
(defvar *normal-border-width* 1
"The width in pixels given to the borders of regular windows.")
(defvar *text-color* "white"
"The color of message text.")
(defvar *menu-maximum-height* nil
"Defines the maxium number of lines to display in the menu before enabling
scrolling. If NIL scrolling is disabled.")
(defvar *menu-scrolling-step* 1
"Number of lines to scroll when hitting the menu list limit.")
(defparameter +netwm-supported+
'(:_NET_SUPPORTING_WM_CHECK
:_NET_NUMBER_OF_DESKTOPS
:_NET_DESKTOP_GEOMETRY
:_NET_DESKTOP_VIEWPORT
:_NET_CURRENT_DESKTOP
:_NET_WM_WINDOW_TYPE
:_NET_WM_STATE
:_NET_WM_STATE_MODAL
:_NET_WM_ALLOWED_ACTIONS
:_NET_WM_STATE_FULLSCREEN
:_NET_WM_STATE_HIDDEN
:_NET_WM_STATE_DEMANDS_ATTENTION
:_NET_WM_FULL_WINDOW_PLACEMENT
:_NET_CLOSE_WINDOW
:_NET_CLIENT_LIST
:_NET_CLIENT_LIST_STACKING
:_NET_ACTIVE_WINDOW
:_NET_WM_DESKTOP
:_KDE_NET_SYSTEM_TRAY_WINDOW_FOR)
"Supported NETWM properties.
Window types are in +WINDOW-TYPES+.")
(defparameter +netwm-allowed-actions+
'(:_NET_WM_ACTION_CHANGE_DESKTOP
:_NET_WM_ACTION_FULLSCREEN
:_NET_WM_ACTION_CLOSE)
"Allowed NETWM actions for managed windows")
(defparameter +netwm-window-types+
'(
;; (:_NET_WM_WINDOW_TYPE_DESKTOP . :desktop)
(:_NET_WM_WINDOW_TYPE_DOCK . :dock)
;; (:_NET_WM_WINDOW_TYPE_TOOLBAR . :toolbar)
;; (:_NET_WM_WINDOW_TYPE_MENU . :menu)
;; (:_NET_WM_WINDOW_TYPE_UTILITY . :utility)
;; (:_NET_WM_WINDOW_TYPE_SPLASH . :splash)
(:_NET_WM_WINDOW_TYPE_DIALOG . :dialog)
(:_NET_WM_WINDOW_TYPE_NORMAL . :normal))
"Alist mapping NETWM window types to keywords.
Include only those we are ready to support.")
;; Window states
(defconstant +withdrawn-state+ 0)
(defconstant +normal-state+ 1)
(defconstant +iconic-state+ 3)
(defvar *window-events* '(:structure-notify
:property-change
:colormap-change
:focus-change
:enter-window)
"The events to listen for on managed windows.")
(defvar *window-parent-events* '(:substructure-notify
:substructure-redirect)
"The events to listen for on managed windows' parents.")
;; Message window variables
(defvar *message-window-padding* 5
"The number of pixels that pad the text in the message window.")
(defvar *message-window-gravity* :top-right
"This variable controls where the message window appears. The follow
are valid values.
@table @asis
@item :top-left
@item :top-right
@item :bottom-left
@item :bottom-right
@item :center
@item :top
@item :left
@item :right
@item :bottom
@end table")
;; line editor
(defvar *editor-bindings* nil
"A list of key-bindings for line editing.")
(defvar *input-window-gravity* :top-right
"This variable controls where the input window appears. The follow
are valid values.
@table @asis
@item :top-left
@item :top-right
@item :bottom-left
@item :bottom-right
@item :center
@item :top
@item :left
@item :right
@item :bottom
@end table")
;; default values. use the set-* functions to these attributes
(defparameter +default-foreground-color+ "White")
(defparameter +default-background-color+ "Black")
(defparameter +default-window-background-color+ "Black")
(defparameter +default-border-color+ "White")
(defparameter +default-font-name+ "9x15")
(defparameter +default-focus-color+ "White")
(defparameter +default-unfocus-color+ "Black")
(defparameter +default-float-focus-color+ "Orange")
(defparameter +default-float-unfocus-color+ "SteelBlue4")
(defparameter +default-frame-outline-width+ 2)
;; Don't set these variables directly, use set-<var name> instead
(defvar *normal-gravity* :center)
(defvar *maxsize-gravity* :center)
(defvar *transient-gravity* :center)
(defvar *top-level-error-action* :abort
"If an error is encountered at the top level, in
STUMPWM-INTERNAL-LOOP, then this variable decides what action
shall be taken. By default it will print a message to the screen
and to *standard-output*.
Valid values are :message, :break, :abort. :break will break to the
debugger. This can be problematic because if the user hit's a
mapped key the ENTIRE keyboard will be frozen and you will have
to login remotely to regain control. :abort quits thesiswm.")
(defvar *window-name-source* :title
"This variable controls what is used for the window's name. The default is @code{:title}.
@table @code
@item :title
Use the window's title given to it by its owner.
@item :class
Use the window's resource class.
@item :resource-name
Use the window's resource name.
@end table")
(defstruct frame
(number nil :type integer)
x
y
width
height
window)
(defstruct (head (:include frame)))
(defclass screen ()
((id :initarg :id :reader screen-id)
(host :initarg :host :reader screen-host)
(number :initarg :number :reader screen-number)
(heads :initform () :accessor screen-heads)
(groups :initform () :accessor screen-groups)
(current-group :accessor screen-current-group)
;; various colors (as returned by alloc-color)
(border-color :initarg :border-color :accessor screen-border-color)
(fg-color :initarg :fg-color :accessor screen-fg-color)
(bg-color :initarg :bg-color :accessor screen-bg-color)
(win-bg-color :initarg :win-bg-color :accessor screen-win-bg-color)
(focus-color :initarg :focus-color :accessor screen-focus-color)
(unfocus-color :initarg :unfocus-color :accessor screen-unfocus-color)
(float-focus-color :initarg :float-focus-color :accessor screen-float-focus-color)
(float-unfocus-color :initarg :float-unfocus-color :accessor screen-float-unfocus-color)
(msg-border-width :initarg :msg-border-width :accessor screen-msg-border-width)
(frame-outline-width :initarg :frame-outline-width :accessor screen-frame-outline-width)
(fonts :initarg :fonts :accessor screen-fonts)
(mapped-windows :initform () :accessor screen-mapped-windows :documentation
"A list of all mapped windows. These are the raw xlib:window's. window structures are stored in groups.")
(withdrawn-windows :initform () :accessor screen-withdrawn-windows :documentation
"A list of withdrawn windows. These are of type thesiswm::window
and when they're mapped again they'll be put back in the group
they were in when they were unmapped unless that group doesn't
exist, in which case they go into the current group.")
(urgent-windows :initform () :accessor screen-urgent-windows :documentation
"a list of windows for which (window-urgent-p) currently true.")
(input-window :initarg :input-window :reader screen-input-window)
(key-window :initarg :key-window :reader screen-key-window :documentation
"the window that accepts further keypresses after a toplevel key has been pressed.")
(focus-window :initarg :focus-window :reader screen-focus-window :documentation
"The window that gets focus when no window has focus")
(frame-window :initarg :frame-window :reader screen-frame-window)
(frame-outline-gc :initarg :frame-outline-gc :reader screen-frame-outline-gc)
;; color contexts
(message-cc :initarg :message-cc :reader screen-message-cc)
;; color maps
(color-map-normal :initform nil :accessor screen-color-map-normal)
(color-map-bright :initform nil :accessor screen-color-map-bright)
(ignore-msg-expose :initform 0 :accessor screen-ignore-msg-expose :documentation
"used to ignore the first expose even when mapping the message window.")
;; the window that has focus
(focus :initform nil :accessor screen-focus)
(current-msg :initform nil :accessor screen-current-msg)
(current-msg-highlights :initform nil :accessor screen-current-msg-highlights)
(last-msg :initform nil :accessor screen-last-msg)
(last-msg-highlights :initform nil :accessor screen-last-msg-highlights)))
(defstruct ccontext
screen
win
px
gc
default-fg
default-bright
default-bg
fg
bg
brightp
reversep
color-stack
font)
(defmethod print-object ((object frame) stream)
(format stream "#S(frame ~d ~a ~d ~d ~d ~d)"
(frame-number object) (frame-window object) (frame-x object) (frame-y object) (frame-width object) (frame-height object)))
(defvar *window-number-map* "0123456789"
"Set this to a string to remap the window numbers to something more convenient.")
(defvar *group-number-map* "1234567890"
"Set this to a string to remap the group numbers to something more convenient.")
(defvar *frame-number-map* "0123456789abcdefghijklmnopqrstuvxwyz"
"Set this to a string to remap the frame numbers to more convenient keys.
For instance,
\"hutenosa\"
would map frame 0 to 7 to be selectable by hitting the appropriate
homerow key on a dvorak keyboard. Currently, only single char keys are
supported. By default, the frame labels are the 36 (lower-case)
alphanumeric characters, starting with numbers 0-9.")
(defun get-frame-number-translation (frame)
"Given a frame return its number translation using *frame-number-map* as a
char."
(let ((num (frame-number frame)))
(if (< num (length *frame-number-map*))
(char *frame-number-map* num)
;; translate the frame number to a char. FIXME: it loops after 9
(char (prin1-to-string num) 0))))
(defstruct modifiers
(meta nil)
(alt nil)
(hyper nil)
(super nil)
(altgr nil)
(numlock nil))
(defvar *all-modifiers* nil
"A list of all keycodes that are considered modifiers")
(defvar *modifiers* nil
"A mapping from modifier type to x11 modifier.")
(defmethod print-object ((object screen) stream)
(format stream "#S<screen ~s>" (screen-number object)))
(defvar *screen-list* '()
"The list of screens managed by thesiswm.")
(defvar *initializing* nil
"True when starting thesiswm. Use this variable in your rc file to
run code that should only be executed once, when thesiswm starts up and
loads the rc file.")
(defvar *processing-existing-windows* nil
"True when processing pre-existing windows at startup.")
(defvar *executing-thesiswm-command* nil
"True when executing external commands.")
(defvar *interactivep* nil
"True when a defcommand is executed from colon or a keybinding")
;;; The restarts menu macro
(defmacro with-restarts-menu (&body body)
"Execute BODY. If an error occurs allow the user to pick a
restart from a menu of possible restarts. If a restart is not
chosen, resignal the error."
(let ((c (gensym)))
`(handler-bind
((warning #'muffle-warning)
((or serious-condition error)
(lambda (,c)
(restarts-menu ,c)
(signal ,c))))
,@body)))
;;; Hook functionality
(defun run-hook-with-args (hook &rest args)
"Call each function in HOOK and pass args to it."
(handler-case
(with-simple-restart (abort-hooks "Abort running the remaining hooks.")
(with-restarts-menu
(dolist (fn hook)
(with-simple-restart (continue-hooks "Continue running the remaining hooks.")
(apply fn args)))))
(t (c) (message "^B^1*Error on hook ^b~S^B!~% ^n~A" hook c) (values nil c))))
(defun run-hook (hook)
"Call each function in HOOK."
(run-hook-with-args hook))
(defmacro add-hook (hook fn)
"Add @var{function} to the hook @var{hook-variable}. For example, to
display a message whenever you switch frames:
@example
\(defun my-rad-fn (to-frame from-frame)
(thesiswm:message \"Mustard!\"))
\(thesiswm:add-hook thesiswm:*focus-frame-hook* 'my-rad-fn)
@end example"
`(setf ,hook (adjoin ,fn ,hook)))
(defmacro remove-hook (hook fn)
"Remove the specified function from the hook."
`(setf ,hook (remove ,fn ,hook)))
(defmacro remove-all-hooks (hook)
"Remove all functions from a hook"
`(setf ,hook NIL))
;; Misc. utility functions
(defun sort1 (list sort-fn &rest keys &key &allow-other-keys)
"Return a sorted copy of list."
(let ((copy (copy-list list)))
(apply 'sort copy sort-fn keys)))
(defun find-free-number (l &optional (min 0) dir)
"Return a number that is not in the list l. If dir is :negative then
look for a free number in the negative direction. anything else means
positive direction."
(let* ((dirfn (if (eq dir :negative) '> '<))
;; sort it and crop numbers below/above min depending on dir
(nums (sort (remove-if (lambda (n)
(funcall dirfn n min))
l) dirfn))
(max (car (last nums)))
(inc (if (eq dir :negative) -1 1))
(new-num (loop for n = min then (+ n inc)
for i in nums
when (/= n i)
do (return n))))
(dformat 3 "Free number: ~S~%" nums)
(if new-num
new-num
;; there was no space between the numbers, so use the max+inc
(if max
(+ inc max)
min))))
(defun split-seq (seq separators &key test default-value)
"split a sequence into sub sequences given the list of seperators."
(let ((seps separators))
(labels ((sep (c)
(find c seps :test test)))
(or (loop for i = (position-if (complement #'sep) seq)
then (position-if (complement #'sep) seq :start j)
as j = (position-if #'sep seq :start (or i 0))
while i
collect (subseq seq i j)
while j)
;; the empty seq causes the above to return NIL, so help
;; it out a little.
default-value))))
(defun split-string (string &optional (separators "
"))
"Splits STRING into substrings where there are matches for SEPARATORS.
Each match for SEPARATORS is a splitting point.
The substrings between the splitting points are made into a list
which is returned.
***If SEPARATORS is absent, it defaults to \"[ \f\t\n\r\v]+\".
If there is match for SEPARATORS at the beginning of STRING, we do not
include a null substring for that. Likewise, if there is a match
at the end of STRING, we don't include a null substring for that.
Modifies the match data; use `save-match-data' if necessary."
(split-seq string separators :test #'char= :default-value '("")))
(defun match-all-regexps (regexps target-string &key (case-insensitive t))
"Return T if TARGET-STRING matches all regexps in REGEXPS.
REGEXPS can be a list of strings (one regexp per element) or a single
string which is split to obtain the individual regexps. "
(let* ((regexps (if (listp regexps)
regexps
(split-string regexps " "))))
(loop for pattern in regexps
always (let ((scanner (ppcre:create-scanner pattern
:case-insensitive-mode case-insensitive)))
(ppcre:scan scanner target-string)))))
(defun insert-before (list item nth)
"Insert ITEM before the NTH element of LIST."
(declare (type (integer 0 *) nth))
(let* ((nth (min nth (length list)))
(pre (subseq list 0 nth))
(post (subseq list nth)))
(nconc pre (list item) post)))
(defvar *debug-level* 0
"Set this variable to a number > 0 to turn on debugging. The greater the number the more debugging output.")
(defvar *debug-expose-events* nil
"Set this variable for a visual indication of expose events on internal StumpWM windows.")
(defvar *debug-stream* (make-synonym-stream '*error-output*)
"This is the stream debugging output is sent to. It defaults to
*error-output*. It may be more convenient for you to pipe debugging
output directly to a file.")
(defun dformat (level fmt &rest args)
(when (>= *debug-level* level)
(multiple-value-bind (sec m h) (decode-universal-time (get-universal-time))
(format *debug-stream* "~2,'0d:~2,'0d:~2,'0d " h m sec))
;; strip out non base-char chars quick-n-dirty like
(write-string (map 'string (lambda (ch)
(if (typep ch 'standard-char)
ch #\?))
(apply 'format nil fmt args))
*debug-stream*)
(force-output *debug-stream*)))
(defvar *redirect-stream* nil
"This variable Keeps track of the stream all output is sent to when
`redirect-all-output' is called so if it changes we can close it
before reopening.")
(defun redirect-all-output (file)
"Elect to redirect all output to the specified file. For instance,
if you want everything to go to ~/.thesiswm.d/debug-output.txt you would
do:
@example
(redirect-all-output (data-dir-file \"debug-output\" \"txt\"))
@end example
"
(when (typep *redirect-stream* 'file-stream)
(close *redirect-stream*))
(setf *redirect-stream* (open file :direction :output :if-exists :append :if-does-not-exist :create)
*error-output* *redirect-stream*
*standard-output* *redirect-stream*
*trace-output* *redirect-stream*
*debug-stream* *redirect-stream*))
;;;
;;; formatting routines
(defun format-expand (fmt-alist fmt &rest args)
(let* ((chars (coerce fmt 'list))
(output "")
(cur chars))
;; FIXME: this is horribly inneficient
(loop
(cond ((null cur)
(return-from format-expand output))
;; if % is the last char in the string then it's a literal.
((and (char= (car cur) #\%)
(cdr cur))
(setf cur (cdr cur))
(let* ((tmp (loop while (and cur (char<= #\0 (car cur) #\9))
collect (pop cur)))
(len (and tmp (parse-integer (coerce tmp 'string))))
;; So that eg "%25^t" will trim from the left
(from-left-p (when (char= #\^ (car cur)) (pop cur))))
(if (null cur)
(format t "%~a~@[~a~]" len from-left-p)
(let* ((fmt (cadr (assoc (car cur) fmt-alist :test 'char=)))
(str (cond (fmt
;; it can return any type, not jut as string.
(format nil "~a" (apply fmt args)))
((char= (car cur) #\%)
(string #\%))
(t
(concatenate 'string (string #\%) (string (car cur)))))))
;; crop string if needed
(setf output (concatenate 'string output
(cond ((null len) str)
((not from-left-p) ; Default behavior
(subseq str 0 (min len (length str))))
;; New behavior -- trim from the left
(t (subseq str (max 0 (- (length str) len)))))))
(setf cur (cdr cur))))))
(t
(setf output (concatenate 'string output (string (car cur)))
cur (cdr cur)))))))
(defvar *window-formatters* '((#\n window-map-number)
(#\s fmt-window-status)
(#\t window-name)
(#\c window-class)
(#\i window-res)
(#\r window-role)
(#\m fmt-window-marked)
(#\h window-height)
(#\w window-width)
(#\g gravity-for-window))
"an alist containing format character format function pairs for formatting window lists.")
(defvar *window-format* "%m%n%s%50t"
"This variable decides how the window list is formatted. It is a string
with the following formatting options:
@table @asis
@item %n
Substitutes the windows number translated via *window-number-map*, if there
are more windows than *window-number-map* then will use the window-number.
@item %s
Substitute the window's status. * means current window, + means last
window, and - means any other window.
@item %t
Substitute the window's name.
@item %c
Substitute the window's class.
@item %i
Substitute the window's resource ID.
@item %m
Draw a # if the window is marked.
@end table
Note, a prefix number can be used to crop the argument to a specified
size. For instance, @samp{%20t} crops the window's title to 20
characters.")
(defvar *window-info-format* "%wx%h %n (%t)"
"The format used in the info command.
@var{*window-format*} for formatting details.")
(defparameter *window-format-by-class* "%m%n %c %s%50t"
"The format used in the info winlist-by-class command.
@var{*window-format*} for formatting details.")
(defvar *group-formatters* '((#\n group-map-number)
(#\s fmt-group-status)
(#\t group-name))
"An alist of characters and formatter functions. The character can be
used as a format character in @var{*group-format*}. When the character
is encountered in the string, the corresponding function is called
with a group as an argument. The functions return value is inserted
into the string. If the return value isn't a string it is converted to
one using @code{prin1-to-string}.")
(defvar *group-format* "%n%s%t"
"The format string that decides what information will show up in the
group listing. The following format options are available:
@table @asis
@item %n
Substitutes the group number translated via *group-number-map*, if there
are more windows than *group-number-map* then will use the group-number.
@item %s
The group's status. Similar to a window's status.
@item %t
The group's name.
@end table")
(defvar *list-hidden-groups* nil
"Controls whether hidden groups are displayed by 'groups' and 'vgroups' commands")
;; (defun font-height (font)
;; (+ (font-descent font)
;; (font-ascent font)))
(defvar *x-selection* nil
"This is a plist of thesiswm's current selections. The different properties are
generally set when killing text in the input bar.")
(defvar *last-command* nil
"Set to the last interactive command run.")
(defvar *max-last-message-size* 20
"how many previous messages to keep.")
(defvar *record-last-msg-override* nil
"assign this to T and messages won't be recorded. It is
recommended this is assigned using LET.")
(defvar *suppress-echo-timeout* nil
"Assign this T and messages will not time out. It is recommended this is assigned using LET.")
(defvar *ignore-echo-timeout* nil
"Assign this T and the message time out won't be touched. It is recommended this is assigned using LET.")
(defvar *run-or-raise-all-groups* t
"When this is @code{T} the @code{run-or-raise} function searches all groups for a
running instance. Set it to NIL to search only the current group.")
(defvar *run-or-raise-all-screens* nil
"When this is @code{T} the @code{run-or-raise} function searches all screens for a
running instance. Set it to @code{NIL} to search only the current screen. If
@var{*run-or-raise-all-groups*} is @code{NIL} this variable has no effect.")
(defvar *deny-map-request* nil
"A list of window properties that thesiswm should deny matching windows'
requests to become mapped for the first time.")
(defvar *deny-raise-request* nil
"Exactly the same as @var{*deny-map-request*} but for raise requests.
Note that no denial message is displayed if the window is already visible.")
(defvar *suppress-deny-messages* nil
"For complete focus on the task at hand, set this to @code{T} and no
raise/map denial messages will be seen.")
(defvar *honor-window-moves* t
"Allow windows to move between frames.")
(defvar *resize-hides-windows* nil
"Set to T to hide windows during interactive resize")
(defun deny-request-p (window deny-list)
(or (eq deny-list t)
(and
(listp deny-list)
(find-if (lambda (props)
(apply 'window-matches-properties-p window props))
deny-list)
t)))
(defun list-splice-replace (item list &rest replacements)
"splice REPLACEMENTS into LIST where ITEM is, removing
ITEM. Return the new list."
(let ((p (position item list)))
(if p
(nconc (subseq list 0 p) replacements (subseq list (1+ p)))
list)))
(defvar *min-frame-width* 50
"The minimum width a frame can be. A frame will not shrink below this
width. Splitting will not affect frames if the new frame widths are
less than this value.")
(defvar *min-frame-height* 50