/[mcclim]/mcclim/clx-port.lisp
ViewVC logotype

Contents of /mcclim/clx-port.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (show annotations)
Mon Oct 29 19:57:12 2001 UTC (12 years, 5 months ago) by mikemac
Branch: MAIN
CVS Tags: HEAD
Changes since 1.34: +0 -0 lines
FILE REMOVED
restructure directory layout
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2000,2001 by
5 ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr)
6 ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr)
7 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
8
9 ;;; This library is free software; you can redistribute it and/or
10 ;;; modify it under the terms of the GNU Library General Public
11 ;;; License as published by the Free Software Foundation; either
12 ;;; version 2 of the License, or (at your option) any later version.
13 ;;;
14 ;;; This library is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;;; Library General Public License for more details.
18 ;;;
19 ;;; You should have received a copy of the GNU Library General Public
20 ;;; License along with this library; if not, write to the
21 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;;; Boston, MA 02111-1307 USA.
23
24 (in-package :CLIM-INTERNALS)
25
26 ;;; CLX-PORT class
27
28 (defclass clx-port (port)
29 ((display :initform nil
30 :accessor clx-port-display)
31 (screen :initform nil
32 :accessor clx-port-screen)
33 (window :initform nil
34 :accessor clx-port-window)
35 (color-table :initform (make-hash-table :test #'eq))
36 (font-table :initform (make-hash-table :test #'eq)))
37 )
38
39 (setf (get :x11 :port-type) 'clx-port)
40
41 (defmethod initialize-instance :after ((port clx-port) &rest args)
42 (declare (ignore args))
43 (push (make-instance 'clx-frame-manager :port port) (slot-value port 'frame-managers))
44 (initialize-clx port))
45
46 (defun clx-error-handler (display error-name &key &allow-other-keys)
47 (format *error-output* "clx-error: ~a~%" error-name))
48
49 (defmethod initialize-clx ((port clx-port))
50 (let ((options (cdr (port-server-path port))))
51 (setf (clx-port-display port)
52 (xlib:open-display (getf options :host "") :display (getf options :display-id 0)))
53 (setf (xlib:display-error-handler (clx-port-display port))
54 #'clx-error-handler)
55 (setf (clx-port-screen port) (nth (getf options :screen-id 0)
56 (xlib:display-roots (clx-port-display port))))
57 (setf (clx-port-window port) (xlib:screen-root (clx-port-screen port)))
58 (make-graft port)
59 ))
60
61 (defun realize-mirror-aux (port sheet
62 &key (width 100) (height 100) (x 0) (y 0)
63 (border-width 0) (border 0)
64 (override-redirect :off)
65 (map t)
66 (backing-store :not-useful)
67 (event-mask `(:exposure
68 :key-press :key-release
69 :button-press :button-release
70 :enter-window :leave-window
71 :structure-notify
72 :pointer-motion)))
73 (when (null (port-lookup-mirror port sheet))
74 (with-sheet-medium (medium sheet)
75 (let* ((desired-color (medium-background (sheet-medium sheet)))
76 (color (multiple-value-bind (r g b)
77 (color-rgb desired-color)
78 (xlib:make-color :red r :green g :blue b)))
79 (pixel (xlib:alloc-color (xlib:screen-default-colormap (clx-port-screen port))
80 color))
81 (window (xlib:create-window
82 :parent (sheet-mirror (sheet-parent sheet))
83 :width width
84 :height height
85 :x x :y y
86 :border-width border-width
87 :border border
88 :override-redirect override-redirect
89 :backing-store backing-store
90 :gravity :north-west
91 :background pixel
92 :event-mask (apply #'xlib:make-event-mask
93 event-mask))))
94 (port-register-mirror (port sheet) sheet window)
95 (when map
96 (xlib:map-window window)))))
97 (port-lookup-mirror port sheet))
98
99 (defmethod realize-mirror ((port clx-port) (sheet mirrored-sheet-mixin))
100 (realize-mirror-aux port sheet :border-width 0))
101
102 (defmethod realize-mirror ((port clx-port) (sheet border-pane))
103 (rotatef (medium-background (sheet-medium sheet)) (medium-foreground (sheet-medium sheet)))
104 (realize-mirror-aux port sheet
105 :border-width 0 ; (border-pane-width sheet)
106 :event-mask '(:exposure
107 :structure-notify)))
108
109 (defmethod realize-mirror ((port clx-port) (sheet top-level-sheet-pane))
110 (let ((frame (pane-frame sheet))
111 (window (realize-mirror-aux port sheet
112 :map nil
113 :event-mask '(:structure-notify))))
114 (setf (xlib:wm-name window) (frame-pretty-name frame))
115 (setf (xlib:wm-icon-name window) (frame-pretty-name frame))))
116
117 (defmethod realize-mirror ((port clx-port) (sheet unmanaged-top-level-sheet-pane))
118 (realize-mirror-aux port sheet
119 :override-redirect :on
120 :map nil
121 :event-mask '(:structure-notify)))
122
123 (defmethod realize-mirror ((port clx-port) (sheet menu-button-pane))
124 (realize-mirror-aux port sheet
125 :event-mask '(:exposure
126 :key-press :key-release
127 :button-press :button-release
128 :enter-window :leave-window
129 :structure-notify
130 :pointer-motion
131 :owner-grab-button)))
132
133 (defmethod destroy-mirror ((port clx-port) (sheet mirrored-sheet-mixin))
134 (when (port-lookup-mirror port sheet)
135 (xlib:destroy-window (port-lookup-mirror port sheet))
136 (port-unregister-mirror port sheet (sheet-mirror sheet))))
137
138 (defmethod mirror-transformation ((port clx-port) mirror)
139 (make-translation-transformation (xlib:drawable-x mirror)
140 (xlib:drawable-y mirror)))
141
142 (defmethod port-set-sheet-region ((port clx-port) (graft graft) region)
143 (declare (ignore region))
144 nil)
145
146 (defmethod port-set-sheet-region ((port clx-port) (sheet mirrored-sheet-mixin) region)
147 (let ((mirror (sheet-direct-mirror sheet)))
148 (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* region)
149 (setf (xlib:drawable-width mirror) (round (- x2 x1))
150 (xlib:drawable-height mirror) (round (- y2 y1))))))
151
152 (defmethod port-set-sheet-transformation ((port clx-port) (graft graft) transformation)
153 (declare (ignore transformation))
154 nil)
155
156 (defmethod port-set-sheet-transformation ((port clx-port) (pane application-pane) transformation)
157 (declare (ignore transformation))
158 nil)
159
160 (defmethod port-set-sheet-transformation ((port clx-port) (pane interactor-pane) transformation)
161 (declare (ignore transformation))
162 nil)
163
164 (defmethod port-set-sheet-transformation ((port clx-port) (sheet mirrored-sheet-mixin) transformation)
165 (let ((mirror (sheet-direct-mirror sheet)))
166 (multiple-value-bind (x y) (transform-position transformation 0 0)
167 (setf (xlib:drawable-x mirror) (round x)
168 (xlib:drawable-y mirror) (round y)))))
169
170 (defmethod destroy-port :before ((port clx-port))
171 (xlib:close-display (clx-port-display port)))
172
173 (defun event-handler (&rest event-slots
174 &key display window event-key code state mode time width height x y
175 &allow-other-keys)
176 (let ((sheet (and window
177 (port-lookup-sheet *clx-port* window))))
178 (declare (special *clx-port*))
179 (when sheet
180 (case event-key
181 (:key-press
182 (make-instance 'key-press-event :key-name (xlib:keycode->character display code state)
183 :sheet sheet :modifier-state state :timestamp time))
184 (:key-release
185 (make-instance 'key-release-event :key-name (xlib:keycode->character display code state)
186 :sheet sheet :modifier-state state :timestamp time))
187 (:button-release
188 (make-instance 'pointer-button-release-event :pointer 0 :button code :x x :y y
189 :sheet sheet :modifier-state state :timestamp time))
190 (:button-press
191 (make-instance 'pointer-button-press-event :pointer 0 :button code :x x :y y
192 :sheet sheet :modifier-state state :timestamp time))
193 (:enter-notify
194 (make-instance 'pointer-enter-event :pointer 0 :button code :x x :y y
195 :sheet sheet :modifier-state state :timestamp time))
196 (:leave-notify
197 (make-instance (if (eq mode :ungrab) 'pointer-ungrab-event 'pointer-exit-event)
198 :pointer 0 :button code :x x :y y
199 :sheet sheet :modifier-state state :timestamp time))
200 (:configure-notify
201 (make-instance 'window-configuration-event :sheet sheet
202 :x x :y y :width width :height height))
203 (:destroy-notify
204 (make-instance 'window-destroy-event :sheet sheet))
205 (:motion-notify
206 (make-instance 'pointer-motion-event :pointer 0 :button code :x x :y y
207 :sheet sheet :modifier-state state :timestamp time))
208 ((:exposure :display)
209 (make-instance 'window-repaint-event
210 :sheet sheet
211 :region (make-rectangle* x y (+ x width) (+ y height))))
212 (t
213 nil)))))
214
215 (defmethod get-next-event ((port clx-port) &key wait-function (timeout nil))
216 (declare (ignore wait-function))
217 (let ((*clx-port* port))
218 (declare (special *clx-port*))
219 (xlib:display-finish-output (clx-port-display port))
220 ; (xlib:process-event (clx-port-display port) :timeout timeout :handler #'event-handler :discard-p t)))
221 ; temporary solution
222 (or (xlib:process-event (clx-port-display port) :timeout timeout :handler #'event-handler :discard-p t)
223 :timeout)))
224 ;; [Mike] Timeout and wait-functions are both implementation
225 ;; specific and hence best done in the backends.
226
227
228 (defmethod make-graft ((port clx-port) &key (orientation :default) (units :device))
229 (let ((graft (make-instance 'clx-graft
230 :port port :mirror (clx-port-window port)
231 :orientation orientation :units units)))
232 (setf (sheet-region graft) (make-bounding-rectangle 0 0 (xlib:screen-width (clx-port-screen port)) (xlib:screen-height (clx-port-screen port))))
233 (push graft (port-grafts port))
234 graft))
235
236 (defmethod make-medium ((port clx-port) sheet)
237 (make-instance 'clx-medium
238 :port port
239 :graft (find-graft :port port)
240 :sheet sheet))
241
242 (defconstant *clx-text-families* '(:fix "adobe-courier"
243 :serif "adobe-times"
244 :sans-serif "adobe-helvetica"))
245
246 (defconstant *clx-text-faces* '(:roman "medium-r"
247 :bold "bold-r"
248 :italic "medium-i"
249 :bold-italic "bold-i"
250 :italic-bold "bold-i"))
251
252 (defconstant *clx-text-sizes* '(:normal 14
253 :tiny 8
254 :very-small 10
255 :small 12
256 :large 18
257 :very-large 20
258 :huge 24))
259
260 (defun open-font (display font-name)
261 (let ((fonts (xlib:list-font-names display font-name :max-fonts 1)))
262 (if fonts
263 (xlib:open-font display (first fonts))
264 (xlib:open-font display "fixed"))))
265
266 (defmethod text-style-to-X-font ((port clx-port) text-style)
267 (let ((table (slot-value port 'font-table)))
268 (or (gethash text-style table)
269 (with-slots (family face size) text-style
270 (let* ((family-name (if (stringp family)
271 family
272 (or (getf *clx-text-families* family)
273 (getf *clx-text-families* :fix))))
274 (face-name (if (stringp face)
275 face
276 (or (getf *clx-text-faces*
277 (if (listp face)
278 (intern (format nil "~A-~A"
279 (first face)
280 (second face))
281 :keyword)
282 face))
283 (getf *clx-text-faces* :roman))))
284 (size-number (if (numberp size)
285 (round size)
286 (or (getf *clx-text-sizes* size)
287 (getf *clx-text-sizes* :normal))))
288 (font-name (format nil "-~A-~A-*-*-~D-*-*-*-*-*-*-*"
289 family-name face-name size-number)))
290 (setf (gethash text-style table)
291 (open-font (clx-port-display port) font-name)))))))
292
293 (defmethod port-character-width ((port clx-port) text-style char)
294 (let* ((font (text-style-to-X-font port text-style))
295 (width (xlib:char-width font (char-code char))))
296 width))
297
298 (defmethod port-string-width ((port clx-port) text-style string &key (start 0) end)
299 (xlib:text-width (text-style-to-X-font port text-style)
300 string :start start :end end))
301
302 (defmethod X-pixel ((port clx-port) color)
303 (let ((table (slot-value port 'color-table)))
304 (or (gethash color table)
305 (setf (gethash color table)
306 (multiple-value-bind (r g b) (color-rgb color)
307 (xlib:alloc-color (xlib:screen-default-colormap
308 (first (xlib:display-roots (clx-port-display port))))
309 (xlib:make-color :red r :green g :blue b)))))))
310
311 (defmethod port-mirror-width ((port clx-port) sheet)
312 (let ((mirror (port-lookup-mirror port sheet)))
313 (xlib:drawable-width mirror)))
314
315 (defmethod port-mirror-height ((port clx-port) sheet)
316 (let ((mirror (port-lookup-mirror port sheet)))
317 (xlib:drawable-height mirror)))
318
319 (defmethod graft ((port clx-port))
320 (first (port-grafts port)))
321
322 ;;; Pixmap
323
324 (defmethod realize-mirror ((port clx-port) (pixmap pixmap))
325 (when (null (port-lookup-mirror port pixmap))
326 (let* ((window (sheet-direct-mirror (pixmap-sheet pixmap)))
327 (pix (xlib:create-pixmap
328 :width (round (pixmap-width pixmap))
329 :height (round (pixmap-height pixmap))
330 :depth (xlib:drawable-depth window)
331 :drawable window)))
332 (port-register-mirror port pixmap pix))
333 (values)))
334
335 (defmethod destroy-mirror ((port clx-port) (pixmap pixmap))
336 (when (port-lookup-mirror port pixmap)
337 (xlib:free-pixmap (port-lookup-mirror port pixmap))
338 (port-unregister-mirror port pixmap (port-lookup-mirror port pixmap))))
339
340 (defmethod port-allocate-pixmap ((port clx-port) sheet width height)
341 (let ((pixmap (make-instance 'mirrored-pixmap
342 :sheet sheet
343 :width width
344 :height height
345 :port port)))
346 (when (sheet-grafted-p sheet)
347 (realize-mirror port pixmap))
348 pixmap))
349
350 (defmethod port-deallocate-pixmap ((port clx-port) pixmap)
351 (when (port-lookup-mirror port pixmap)
352 (destroy-mirror port pixmap)))
353
354 ;; Device-Font-Text-Style
355
356 (defmethod port-make-font-text-style ((port clx-port) device-font-name)
357 (let ((text-style (make-instance 'device-font-text-style
358 :text-family device-font-name
359 :text-face nil
360 :text-size nil)))
361 (setf (gethash text-style (slot-value port 'font-table))
362 (open-font (clx-port-display port) device-font-name))
363 text-style))
364
365 ;; Top-level-sheet
366
367 (defmethod compute-extremum :after ((pane top-level-sheet-pane))
368 (with-slots (space-requirement) pane
369 (setf (xlib:wm-normal-hints (sheet-direct-mirror pane))
370 (xlib:make-wm-size-hints
371 :width (round (space-requirement-width space-requirement))
372 :height (round (space-requirement-height space-requirement))
373 :max-width (round (space-requirement-max-width space-requirement))
374 :max-height (round (space-requirement-max-height space-requirement))
375 :min-width (round (space-requirement-min-width space-requirement))
376 :min-height (round (space-requirement-min-height space-requirement))))))
377
378

  ViewVC Help
Powered by ViewVC 1.1.5