-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathroot-gmgmt.lisp
127 lines (116 loc) · 6.15 KB
/
root-gmgmt.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
;;; -*- Mode:Lisp; Package:CLUEI; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
;;;----------------------------------------------------------------------------------+
;;; |
;;; TEXAS INSTRUMENTS INCORPORATED |
;;; P.O. BOX 149149 |
;;; AUSTIN, TEXAS 78714-9149 |
;;; |
;;; Copyright (C)1989,1990 Texas Instruments Incorporated. |
;;; |
;;; Permission is granted to any individual or institution to use, copy, modify, and |
;;; distribute this software, provided that this complete copyright and permission |
;;; notice is maintained, intact, in all copies and supporting documentation. |
;;; |
;;; Texas Instruments Incorporated provides this software "as is" without express or |
;;; implied warranty. |
;;; |
;;;----------------------------------------------------------------------------------+
(in-package "CLUEI")
;;;----------------------------------------------------------------------------+
;;; |
;;; Geometry management methods for ROOT contacts |
;;; |
;;;----------------------------------------------------------------------------+
(defmethod add-child ((parent root) (child shell) &key)
;; No problem...
(with-slots (children) parent
(setf children (nconc children (cons child nil)))))
(defmethod add-child ((parent root) non-shell &key)
;; Big problem...
(error "~a cannot be top-level because it is not a shell." non-shell))
(defmethod manage-geometry ((parent root) (shell wm-shell) x y width height border-width &key)
(with-slots ((contact-x x)
(contact-y y)
(contact-width width)
(contact-height height)
(contact-border-width border-width)) shell
;; Reconfigure top-level window, if necessary
(let (changed-p (display (contact-display parent)))
;; Wait for any previous :configure-notify events to be handled.
;; Don't update-state to avoid infinite recursion during realization.
(process-all-events display nil)
(with-state (shell)
(when (and x (/= x contact-x)
(setf (drawable-x shell) x))
(setf changed-p t))
(when (and y (/= y contact-y)
(setf (drawable-y shell) y))
(setf changed-p t))
(when (and width (/= width contact-width)
(setf (drawable-width shell) width))
(setf changed-p t))
(when (and height (/= height contact-height)
(setf (drawable-height shell) height))
(setf changed-p t))
(when (and border-width (/= border-width contact-border-width)
(setf (drawable-border-width shell) border-width))
(setf changed-p t)))
;; Return approved geometry
(values
(or
;; Null changed approved immediately
(not changed-p)
;; Actual change approved if it is not modified by window mgr.
(progn
;; Wait for :configure-notify to report actual new window geometry.
;; wm-shell's handle-event will update geometry slots in
;; response to :configure-notify.
(with-event-mode (shell '(:configure-notify (throw-action :configure-notify)))
(catch :configure-notify
;; Don't update-state to avoid infinite recursion during realization.
(loop (process-next-event display nil nil))))
;; Assert: shell slots now contain actual (wm-approved) geometry
;; Return approval of original geometry request
(and
(not (and x (/= x contact-x)))
(not (and y (/= y contact-y)))
(not (and width (/= width contact-width)))
(not (and height (/= height contact-height)))
(not (and border-width (/= border-width contact-border-width))))))
contact-x contact-y contact-width contact-height contact-border-width))))
(defmethod manage-geometry :around ((parent root) (shell override-shell) x y width height border-width &key)
;; Approve and perform change immediately. We could let
;; change-geometry do the move/resize normally, but doing them here
;; allows change-geometry to assume consistently that the change to
;; a realized shell has already been done. See (manage-geometry root
;; wm-shell) method. This must be an :around method in order to
;; override less specific :around methods.
(with-slots
((contact-x x)
(contact-y y)
(contact-width width)
(contact-height height)
(contact-border-width border-width))
(the contact shell)
(let
((approved-x (or x contact-x))
(approved-y (or y contact-y))
(approved-width (or width contact-width))
(approved-height (or height contact-height))
(approved-border-width (or border-width contact-border-width)))
(with-state (shell)
(move shell approved-x approved-y)
(resize shell approved-width approved-height approved-border-width))
(values t approved-x approved-y approved-width approved-height approved-border-width))))
(defmethod manage-priority ((parent root) (shell wm-shell) priority sibling &key)
;; Shrug..just return approval, because ICCCM doesn't require the
;; window manager to report the result of an attempt to change
;; priority. Besides, even if we did get a :configure-notify saying
;; what really happened, we can't always tell if the request was
;; successful or not. That's because only an above-sibling comes
;; back in the :configure-notify, and we may not own this window or
;; know its place in the hierarchy.
(values t priority sibling))
;; Adding/deleting root children has no effect on sibling layout
(defmethod change-layout ((parent root) &optional newly-managed)
(declare (ignore newly-managed)))