/[mcclim]/mcclim/ports.lisp
ViewVC logotype

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (hide annotations)
Mon Jul 14 19:41:44 2003 UTC (10 years, 9 months ago) by hefner1
Branch: MAIN
Changes since 1.39: +16 -2 lines
Reworking of input focus handling - track keyboard focus per-frame rather
than per-port, and set appropriate WM hint/protocol to implement what the
ICCCM defines as "Locally Active" focus.

port-keyboard-input-focus is still around, but now changes the frame input
focus through clim:*application-frame*. This makes multiple application
frames play nice with each other.

You can also now move the pointer out of the window and still type to it, if
your WM allows that sort of thing.
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3 mikemac 1.19 ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
4 cvs 1.5 ;;; (c) copyright 2000 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 mikemac 1.1
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 mikemac 1.38 (in-package :clim-internals)
25 mikemac 1.1
26 mikemac 1.39 (defvar *default-server-path* nil)
27 mikemac 1.22
28 mikemac 1.32 (defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl))
29 mikemac 1.22
30     (defun find-default-server-path ()
31     (loop for port in *server-path-search-order*
32     if (get port :port-type)
33     do (return-from find-default-server-path (list port))
34     finally (error "No CLIM backends have been loaded!")))
35 mikemac 1.1
36     (defvar *all-ports* nil)
37    
38 gilbert 1.37 (define-protocol-class port ())
39 gilbert 1.21
40     (defclass basic-port (port)
41 mikemac 1.1 ((server-path :initform nil
42     :initarg :server-path
43     :reader port-server-path)
44     (properties :initform nil
45     :initarg :properties)
46     (grafts :initform nil
47     :accessor port-grafts)
48     (frame-managers :initform nil
49     :reader frame-managers)
50     (sheet->mirror :initform (make-hash-table :test #'eq))
51     (mirror->sheet :initform (make-hash-table :test #'eq))
52 cvs 1.10 (pixmap->mirror :initform (make-hash-table :test #'eq))
53     (mirror->pixmap :initform (make-hash-table :test #'eq))
54 hefner1 1.40 #+ignore (keyboard-input-focus :initform nil ;; nuked this, see below
55 mikemac 1.1 :initarg :keyboard-input-focus
56     :accessor port-keyboard-input-focus)
57 gilbert 1.21 (event-process
58     :initform nil
59     :initarg :event-process
60     :accessor port-event-process
61     :documentation "In a multiprocessing environment, the particular process
62     reponsible for calling PROCESS-NEXT-EVENT in a loop.")
63 adejneka 1.34
64 gilbert 1.21 (lock
65     :initform (make-recursive-lock "port lock")
66 mikemac 1.25 :accessor port-lock)
67     (event-count :initform 0)
68 adejneka 1.34 (text-style-mappings :initform (make-hash-table :test #'eq)
69     :reader port-text-style-mappings)
70 moore 1.36 (pointer-sheet :initform nil :accessor port-pointer-sheet
71     :documentation "The sheet the pointer is over, if any")
72 mikemac 1.25 ))
73 mikemac 1.1
74 hefner1 1.40 ;; Keyboard focus is now managed per-frame rather than per-port,
75     ;; which makes a lot of sense. The CLIM spec suggests this in a
76     ;; "Minor Issue". So, redirect PORT-KEYBOARD-INPUT-FOCUS to the
77     ;; current application frame for compatibility.
78     (defmethod port-keyboard-input-focus (port)
79     (declare (ignore port))
80     (when *application-frame*
81     (keyboard-input-focus *application-frame*)))
82    
83     (defmethod (setf port-keyboard-input-focus) (focus port)
84     (declare (ignore port))
85     (when *application-frame*
86     (setf (keyboard-input-focus *application-frame*) focus)))
87    
88 mikemac 1.1 (defun find-port (&key (server-path *default-server-path*))
89 mikemac 1.22 (if (null server-path)
90     (setq server-path (find-default-server-path)))
91     (if (atom server-path)
92     (setq server-path (list server-path)))
93     (setq server-path (funcall (get (first server-path) :server-path-parser) server-path))
94 mikemac 1.1 (loop for port in *all-ports*
95     if (equal server-path (port-server-path port))
96     do (return port)
97     finally (let ((port-type (get (first server-path) :port-type))
98     port)
99     (if (null port-type)
100     (error "Don't know how to make a port of type ~S" server-path))
101     (setq port (funcall 'make-instance port-type :server-path server-path))
102     (push port *all-ports*)
103     (return port))))
104    
105 gilbert 1.21 (defmethod initialize-instance :after ((port basic-port) &rest args)
106     (declare (ignorable args))
107     )
108    
109     (defmethod destroy-port :before ((port basic-port))
110 adejneka 1.33 (when (and *multiprocessing-p* (port-event-process port))
111 gilbert 1.21 (destroy-process (port-event-process port))
112     (setf (port-event-process port) nil)))
113    
114     (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
115 mikemac 1.1 (gethash sheet (slot-value port 'sheet->mirror)))
116    
117 gilbert 1.21 (defmethod port-lookup-sheet ((port basic-port) mirror)
118 mikemac 1.1 (gethash mirror (slot-value port 'mirror->sheet)))
119    
120 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
121 mikemac 1.1 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
122     (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
123     nil)
124    
125 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
126 mikemac 1.1 (remhash sheet (slot-value port 'sheet->mirror))
127     (remhash mirror (slot-value port 'mirror->sheet))
128     nil)
129    
130 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
131 mikemac 1.1 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
132    
133 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
134 rouanet 1.15 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
135 mikemac 1.1
136 gilbert 1.21 (defmethod mirror-transformation ((port basic-port) mirror)
137 rouanet 1.16 (declare (ignore mirror))
138     (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
139    
140 gilbert 1.21 (defmethod port-properties ((port basic-port) indicator)
141 mikemac 1.1 (with-slots (properties) port
142     (getf properties indicator)))
143    
144 gilbert 1.21 (defmethod (setf port-properties) (value (port basic-port) indicator)
145 mikemac 1.1 (with-slots (properties) port
146     (setf (getf properties indicator) value)))
147    
148 gilbert 1.21 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
149 mikemac 1.1 (declare (ignore wait-function timeout))
150     (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
151    
152 mikemac 1.25 (defmethod get-next-event :after ((port basic-port) &key wait-function timeout)
153     (declare (ignore wait-function timeout))
154     (with-slots (event-count) port
155     (incf event-count)))
156    
157 gilbert 1.21 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
158 moore 1.26 (let ((event (get-next-event port
159     :wait-function wait-function
160     :timeout timeout)))
161 mikemac 1.1 (cond
162     ((null event) nil)
163     ((eq event :timeout) (values nil :timeout))
164     (t
165 moore 1.27 (distribute-event port event)
166 mikemac 1.1 t))))
167    
168 moore 1.27 ;;; Called in the application frame process.
169 moore 1.26 (defmethod port-wait-on-event-processing ((port basic-port) &key wait-function timeout
170     ((:event-count old-count) nil))
171 mikemac 1.25 (declare (ignorable wait-function))
172 moore 1.29 (with-slots (event-count) port
173     (if *multiprocessing-p*
174 moore 1.26 (let ((old-event-count (or old-count event-count))
175 mikemac 1.25 (flag nil))
176 moore 1.27 (flet ((wait-fn ()
177     (when (not (eql old-event-count event-count))
178     (setq flag t))))
179     (if timeout
180     (process-wait-with-timeout "Wait for event" timeout #'wait-fn)
181     (process-wait "Wait for event" #'wait-fn))
182     (if flag
183     event-count
184 moore 1.29 (values nil :timeout))))
185     (multiple-value-bind (result reason)
186     (process-next-event port
187     :wait-function wait-function
188     :timeout timeout)
189     (values (and result event-count) reason)))))
190 mikemac 1.25
191 gilbert 1.21 (defmethod distribute-event ((port basic-port) event)
192 mikemac 1.1 (cond
193     ((typep event 'keyboard-event)
194 hefner1 1.40 (dispatch-event (or #+ignore(port-keyboard-input-focus port) (event-sheet event))
195 moore 1.35 event))
196 mikemac 1.1 ((typep event 'window-event)
197 brian 1.28 ; (dispatch-event (window-event-mirrored-sheet event) event)
198 cvs 1.4 (dispatch-event (event-sheet event) event))
199 mikemac 1.1 ((typep event 'pointer-event)
200     (dispatch-event (event-sheet event) event))
201 mikemac 1.23 ((typep event 'window-manager-delete-event)
202     ;; not sure where this type of event should get sent - mikemac
203 moore 1.27 ;; This seems fine; will be handled by the top-level-sheet-pane - moore
204     (dispatch-event (event-sheet event) event))
205 mikemac 1.1 ((typep event 'timer-event)
206     (error "Where do we send timer-events?"))
207     (t
208     (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
209    
210 gilbert 1.21 (defmacro with-port-locked ((port) &body body)
211     (let ((fn (gensym "CONT.")))
212     `(labels ((,fn ()
213     ,@body))
214     (declare (dynamic-extent #',fn))
215 moore 1.29 (invoke-with-port-locked ,port #',fn))))
216 gilbert 1.21
217     (defmethod invoke-with-port-locked ((port basic-port) continuation)
218     (with-recursive-lock-held ((port-lock port))
219     (funcall continuation)))
220    
221 mikemac 1.1 (defun map-over-ports (function)
222     (mapc function *all-ports*))
223    
224 gilbert 1.21 (defmethod restart-port ((port basic-port))
225 mikemac 1.1 (reset-watcher port :restart)
226     nil)
227    
228 gilbert 1.21 (defmethod destroy-port ((port basic-port))
229 mikemac 1.1 (reset-watcher port :destroy)
230     (setf *all-ports* (remove port *all-ports*)))
231    
232 gilbert 1.21 (defmethod add-watcher ((port basic-port) watcher)
233 mikemac 1.1 (declare (ignore watcher))
234     nil)
235    
236 gilbert 1.21 (defmethod delete-watcher ((port basic-port) watcher)
237 mikemac 1.1 (declare (ignore watcher))
238     nil)
239    
240 gilbert 1.21 (defmethod reset-watcher ((port basic-port) how)
241 mikemac 1.1 (declare (ignore how))
242     nil)
243    
244 gilbert 1.21 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
245 mikemac 1.1 (let ((graft (make-instance 'graft
246     :port port :mirror nil
247     :orientation orientation :units units)))
248     (push graft (port-grafts port))
249     graft))
250    
251 gilbert 1.21 #||
252     (defmethod make-medium ((port basic-port) sheet)
253 rouanet 1.16 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
254 gilbert 1.21 ||#
255 mikemac 1.1
256 cvs 1.10 ;;; Pixmap
257    
258 gilbert 1.21 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
259 cvs 1.10 (gethash pixmap (slot-value port 'pixmap->mirror)))
260    
261 gilbert 1.21 (defmethod port-lookup-pixmap ((port basic-port) mirror)
262 cvs 1.10 (gethash mirror (slot-value port 'mirror->pixmap)))
263    
264 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
265 cvs 1.10 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
266     (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
267     nil)
268    
269 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
270 cvs 1.10 (remhash pixmap (slot-value port 'pixmap->mirror))
271     (remhash mirror (slot-value port 'mirror->pixmap))
272     nil)
273    
274 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
275 cvs 1.10 (declare (ignorable port pixmap))
276     (error "Don't know how to realize the mirror on a generic port"))
277    
278 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
279 cvs 1.10 (declare (ignorable port pixmap))
280 rouanet 1.15 (error "Don't know how to destroy the mirror on a generic port"))
281 cvs 1.10
282 gilbert 1.21 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
283 mikemac 1.1 (declare (ignore sheet width height))
284 cvs 1.10 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
285 mikemac 1.1
286 gilbert 1.21 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
287 mikemac 1.1 (declare (ignore pixmap))
288 cvs 1.10 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))

  ViewVC Help
Powered by ViewVC 1.1.5