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
|
;;; ---------------------------------------------------------------------------
;;; License: LGPL-2.1+ (See file 'Copyright' for details).
;;; ---------------------------------------------------------------------------
;;;
;;; (c) copyright 1998,1999,2000 Michael McDonald <mikemac@mikemac.com>
;;; (c) copyright 2000,2001 Iban Hatchondo <hatchond@emi.u-bordeaux.fr>
;;; (c) copyright 2000,2001 Julien Boninfante <boninfan@emi.u-bordeaux.fr>
;;; (c) copyright 2000,2001,2014,2016 Robert Strandh <robert.strandh@gmail.com>
;;; (c) copyright 2019 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
;;; (c) copyright 2016-2024 Daniel Kochmański <daniel@turtleware.eu>
;;;
;;; ---------------------------------------------------------------------------
;;;
;;; Server path processing, port initialization and mirroring functions.
(in-package #:clim-clx)
;;; CLX-PORT class
(defclass clx-port (clim-xcommon:keysym-port-mixin
clx-selection-mixin
clx-basic-port)
((color-table
:initform (make-hash-table :test #'eq))
;; The design cache maintains pixmaps that are shared between drawables on
;; the same display. To avoid race conditions they are immutable.
(design-cache
:initform (trivial-garbage:make-weak-hash-table :weakness :key :test #'eq)
:reader port-design-cache)))
;;; CLX-RENDER-PORT is also subclassed by CLX-FREETYPE-PORT.
(defclass clx-render-port (clx-port) ())
(defun server-options-from-environment ()
(let ((name (get-environment-variable "DISPLAY")))
(assert name (name)
"Environment variable DISPLAY is not set")
;; this code courtesy telent-clx.
(let* ((slash-i (or (position #\/ name) -1))
(colon-i (position #\: name :start (1+ slash-i)))
(decnet-colon-p (and colon-i (eql (elt name (1+ colon-i)) #\:)))
(host (subseq name (1+ slash-i) colon-i))
(dot-i (and colon-i (position #\. name :start colon-i)))
(display (and colon-i
(parse-integer name
:start (if decnet-colon-p
(+ colon-i 2)
(1+ colon-i))
:end dot-i)))
(screen (and dot-i
(parse-integer name :start (1+ dot-i))))
(protocol
(cond ((or (string= host "") (string-equal host "unix")) :local)
(decnet-colon-p :decnet)
((> slash-i -1) (intern
(string-upcase (subseq name 0 slash-i))
:keyword))
(t :internet))))
(list :host host
:display-id (or display 0)
:screen-id (or screen 0)
:protocol protocol))))
(defun server-options-from-environment-with-localhost-fallback ()
(restart-case (server-options-from-environment)
(use-localhost ()
:report "Use local display"
#+windows '(:host "localhost" :protocol :internet :display-id 0 :screen-id 0)
#-windows '(:host "" :protocol :unix :display-id 0 :screen-id 0))))
(defun parse-clx-server-path (path)
(destructuring-bind (port-type &key (host "localhost" hostp)
(protocol :internet protocolp)
(display-id 0 display-id-p)
(screen-id 0 screen-id-p)
(mirroring nil mirroringp))
path
`(,port-type ,@(if (or hostp protocolp display-id-p screen-id-p)
`(:host ,host :protocol ,protocol
:display-id ,display-id :screen-id ,screen-id)
(server-options-from-environment-with-localhost-fallback))
,@(when mirroringp `(:mirroring ,mirroring)))))
(defmethod find-port-type ((type (eql :x11)))
(find-port-type :clx))
(defmethod find-port-type ((type (eql :clx)))
(values 'clx-port 'parse-clx-server-path))
(defmethod initialize-instance :after ((port clx-port) &key)
(let ((options (cdr (port-server-path port))))
(push (apply #'make-instance 'clx-frame-manager :port port options)
(slot-value port 'frame-managers))
(setf (slot-value port 'pointer)
(make-instance 'clx-basic-pointer :port port)))
(initialize-clx port))
(defmethod print-object ((object clx-port) stream)
(print-unreadable-object (object stream :identity t :type t)
(when (slot-boundp object 'display)
(when-let ((display (slot-value object 'display)))
(format stream "~S ~S ~S ~S"
:host (xlib:display-host display)
:display-id (xlib:display-display display))))))
(defvar *window-event-mask*
`(:exposure
:key-press :key-release
:button-press :button-release
:owner-grab-button
:enter-window :leave-window
:structure-notify
:pointer-motion :button-motion))
(defvar *sheet-event-mask*
`(:exposure
:key-press :key-release
:button-press :button-release
:owner-grab-button
:enter-window :leave-window
:pointer-motion :button-motion))
(defun realize-mirror-aux (port sheet
&key (width nil) (height nil) (x nil) (y nil)
(override-redirect :off)
(backing-store :not-useful)
(save-under :off)
(event-mask *window-event-mask*))
(assert (null (sheet-direct-mirror sheet)))
(with-standard-rectangle* (mx my :width mw :height mh)
(sheet-mirror-geometry sheet)
(setf x (round-coordinate (or x mx))
y (round-coordinate (or y my))
width (round-coordinate (or width mw))
height (round-coordinate (or height mh))))
(xlib:create-window
:parent (window (sheet-mirror (sheet-parent sheet)))
:width (round-coordinate width)
:height (round-coordinate height)
:x (round-coordinate x)
:y (round-coordinate y)
:override-redirect override-redirect
:backing-store backing-store
:save-under save-under
:gravity :north-west
:bit-gravity :forget ; don't be evil! -- jd
:event-mask (apply #'xlib:make-event-mask event-mask)))
(defmethod realize-mirror ((port clx-port) (sheet mirrored-sheet-mixin))
;; MIRRORED-SHEET-MIXIN is always in the top of the Class Precedence List.
(let ((window (%realize-mirror port sheet)))
(setf (getf (xlib:window-plist window) 'sheet) sheet)
(make-instance 'clx-window :mirror window :sheet sheet)))
(defmethod %realize-mirror :around ((port clx-basic-port) sheet)
(let ((window (call-next-method)))
(when (sheet-enabled-p sheet)
(xlib:map-window window)
(xlib:display-force-output (clx-port-display port)))
window))
(defmethod %realize-mirror ((port clx-port) (sheet basic-sheet))
(with-bounding-rectangle* (:width w :height h) sheet
(let ((width (if (> w 0) w nil))
(height (if (> h 0) h nil)))
(realize-mirror-aux port sheet :event-mask *sheet-event-mask*
:width width
:height height))))
(defmethod %realize-mirror ((port clx-port) (sheet top-level-sheet-mixin))
(let* ((window (realize-mirror-aux
port sheet
:width (bounding-rectangle-width sheet)
:height (bounding-rectangle-height sheet)
:event-mask *window-event-mask*))
(name (clime:sheet-name sheet))
(instance-name (string-downcase name))
(class-name (string-capitalize name))
(pretty-name (clime:sheet-pretty-name sheet))
(icon (clime:sheet-icon sheet)))
(xlib:set-wm-class window instance-name class-name)
(%set-window-name window pretty-name)
(%set-window-icon-name window pretty-name)
(when icon
(%mirror-install-icons window icon))
(setf (xlib:wm-hints window) (xlib:make-wm-hints :input :on))
(setf (xlib:wm-protocols window) `(:wm_take_focus :wm_delete_window))
(xlib:change-property window
:WM_CLIENT_LEADER (list (xlib:window-id window))
:WINDOW 32)
window))
(defmethod %realize-mirror ((port clx-port) (sheet unmanaged-sheet-mixin))
(realize-mirror-aux port sheet :override-redirect :on
:save-under :on))
(defmethod make-medium ((port clx-port) sheet)
(make-instance 'clx-medium :port port :sheet sheet))
(defmethod make-medium ((port clx-render-port) sheet)
(make-instance 'clx-render-medium :port port :sheet sheet))
(defmethod port-force-output ((port clx-port))
(xlib:display-force-output (clx-port-display port)))
|
