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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.43 - (hide annotations)
Fri Nov 28 23:28:45 2003 UTC (10 years, 4 months ago) by hefner1
Branch: MAIN
Changes since 1.42: +17 -1 lines
Implement :multiple-window option to tracking-pointer. Added a new backend
protocol to support this, through functions PORT-GRAB-POINTER and
PORT-UNGRAB-POINTER.

Using this, ensure that MENU-CHOOSE grabs the pointer and clicking anywhere
outside the menu will dismiss it (which previously only worked somewhat,
due to the lack of pointer grabbing).

Note the slight limitation that the CLX backend does not always accurately
report the window which the pointer is over during a grab.

Imported some symbols into CLIM-CLX package.

Changed the Help command to present available commands using the item
formatter.
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 hefner1 1.41 (when focus
85     (if (pane-frame focus)
86     (setf (keyboard-input-focus (pane-frame focus)) focus)
87     (set-port-keyboard-focus focus port))))
88    
89     ;; This is not in the CLIM spec, but since (setf port-keyboard-input-focus)
90     ;; now calls (setf keyboard-input-focus), we need something concrete the
91     ;; backend can implement to set the focus.
92     (defmethod set-port-keyboard-focus (focus port)
93     (declare (ignore focus))
94     (warn "SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port))
95    
96 hefner1 1.40
97 mikemac 1.1 (defun find-port (&key (server-path *default-server-path*))
98 mikemac 1.22 (if (null server-path)
99     (setq server-path (find-default-server-path)))
100     (if (atom server-path)
101     (setq server-path (list server-path)))
102     (setq server-path (funcall (get (first server-path) :server-path-parser) server-path))
103 mikemac 1.1 (loop for port in *all-ports*
104     if (equal server-path (port-server-path port))
105     do (return port)
106     finally (let ((port-type (get (first server-path) :port-type))
107     port)
108     (if (null port-type)
109     (error "Don't know how to make a port of type ~S" server-path))
110     (setq port (funcall 'make-instance port-type :server-path server-path))
111     (push port *all-ports*)
112     (return port))))
113    
114 gilbert 1.21 (defmethod initialize-instance :after ((port basic-port) &rest args)
115     (declare (ignorable args))
116     )
117    
118     (defmethod destroy-port :before ((port basic-port))
119 adejneka 1.33 (when (and *multiprocessing-p* (port-event-process port))
120 gilbert 1.21 (destroy-process (port-event-process port))
121     (setf (port-event-process port) nil)))
122    
123     (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
124 mikemac 1.1 (gethash sheet (slot-value port 'sheet->mirror)))
125    
126 gilbert 1.21 (defmethod port-lookup-sheet ((port basic-port) mirror)
127 mikemac 1.1 (gethash mirror (slot-value port 'mirror->sheet)))
128    
129 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
130 mikemac 1.1 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
131     (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
132     nil)
133    
134 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
135 mikemac 1.1 (remhash sheet (slot-value port 'sheet->mirror))
136     (remhash mirror (slot-value port 'mirror->sheet))
137     nil)
138    
139 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
140 mikemac 1.1 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
141    
142 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
143 rouanet 1.15 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
144 mikemac 1.1
145 gilbert 1.21 (defmethod mirror-transformation ((port basic-port) mirror)
146 rouanet 1.16 (declare (ignore mirror))
147     (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
148    
149 gilbert 1.21 (defmethod port-properties ((port basic-port) indicator)
150 mikemac 1.1 (with-slots (properties) port
151     (getf properties indicator)))
152    
153 gilbert 1.21 (defmethod (setf port-properties) (value (port basic-port) indicator)
154 mikemac 1.1 (with-slots (properties) port
155     (setf (getf properties indicator) value)))
156    
157 gilbert 1.21 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
158 mikemac 1.1 (declare (ignore wait-function timeout))
159     (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
160    
161 mikemac 1.25 (defmethod get-next-event :after ((port basic-port) &key wait-function timeout)
162     (declare (ignore wait-function timeout))
163     (with-slots (event-count) port
164     (incf event-count)))
165    
166 gilbert 1.21 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
167 moore 1.26 (let ((event (get-next-event port
168     :wait-function wait-function
169     :timeout timeout)))
170 mikemac 1.1 (cond
171     ((null event) nil)
172     ((eq event :timeout) (values nil :timeout))
173     (t
174 moore 1.27 (distribute-event port event)
175 mikemac 1.1 t))))
176    
177 moore 1.27 ;;; Called in the application frame process.
178 moore 1.26 (defmethod port-wait-on-event-processing ((port basic-port) &key wait-function timeout
179     ((:event-count old-count) nil))
180 mikemac 1.25 (declare (ignorable wait-function))
181 moore 1.29 (with-slots (event-count) port
182     (if *multiprocessing-p*
183 moore 1.26 (let ((old-event-count (or old-count event-count))
184 mikemac 1.25 (flag nil))
185 moore 1.27 (flet ((wait-fn ()
186     (when (not (eql old-event-count event-count))
187     (setq flag t))))
188     (if timeout
189     (process-wait-with-timeout "Wait for event" timeout #'wait-fn)
190     (process-wait "Wait for event" #'wait-fn))
191     (if flag
192     event-count
193 moore 1.29 (values nil :timeout))))
194     (multiple-value-bind (result reason)
195     (process-next-event port
196     :wait-function wait-function
197     :timeout timeout)
198     (values (and result event-count) reason)))))
199 mikemac 1.25
200 gilbert 1.21 (defmethod distribute-event ((port basic-port) event)
201 mikemac 1.1 (cond
202     ((typep event 'keyboard-event)
203 hefner1 1.40 (dispatch-event (or #+ignore(port-keyboard-input-focus port) (event-sheet event))
204 moore 1.35 event))
205 mikemac 1.1 ((typep event 'window-event)
206 brian 1.28 ; (dispatch-event (window-event-mirrored-sheet event) event)
207 cvs 1.4 (dispatch-event (event-sheet event) event))
208 mikemac 1.1 ((typep event 'pointer-event)
209     (dispatch-event (event-sheet event) event))
210 mikemac 1.23 ((typep event 'window-manager-delete-event)
211     ;; not sure where this type of event should get sent - mikemac
212 moore 1.27 ;; This seems fine; will be handled by the top-level-sheet-pane - moore
213     (dispatch-event (event-sheet event) event))
214 mikemac 1.1 ((typep event 'timer-event)
215     (error "Where do we send timer-events?"))
216     (t
217     (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
218    
219 gilbert 1.21 (defmacro with-port-locked ((port) &body body)
220     (let ((fn (gensym "CONT.")))
221     `(labels ((,fn ()
222     ,@body))
223     (declare (dynamic-extent #',fn))
224 moore 1.29 (invoke-with-port-locked ,port #',fn))))
225 gilbert 1.21
226     (defmethod invoke-with-port-locked ((port basic-port) continuation)
227     (with-recursive-lock-held ((port-lock port))
228     (funcall continuation)))
229    
230 mikemac 1.1 (defun map-over-ports (function)
231     (mapc function *all-ports*))
232    
233 gilbert 1.21 (defmethod restart-port ((port basic-port))
234 mikemac 1.1 (reset-watcher port :restart)
235     nil)
236    
237 gilbert 1.21 (defmethod destroy-port ((port basic-port))
238 mikemac 1.1 (reset-watcher port :destroy)
239     (setf *all-ports* (remove port *all-ports*)))
240    
241 gilbert 1.21 (defmethod add-watcher ((port basic-port) watcher)
242 mikemac 1.1 (declare (ignore watcher))
243     nil)
244    
245 gilbert 1.21 (defmethod delete-watcher ((port basic-port) watcher)
246 mikemac 1.1 (declare (ignore watcher))
247     nil)
248    
249 gilbert 1.21 (defmethod reset-watcher ((port basic-port) how)
250 mikemac 1.1 (declare (ignore how))
251     nil)
252    
253 gilbert 1.21 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
254 mikemac 1.1 (let ((graft (make-instance 'graft
255     :port port :mirror nil
256     :orientation orientation :units units)))
257     (push graft (port-grafts port))
258     graft))
259    
260 gilbert 1.21 #||
261     (defmethod make-medium ((port basic-port) sheet)
262 rouanet 1.16 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
263 gilbert 1.21 ||#
264 mikemac 1.1
265 cvs 1.10 ;;; Pixmap
266    
267 gilbert 1.21 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
268 cvs 1.10 (gethash pixmap (slot-value port 'pixmap->mirror)))
269    
270 gilbert 1.21 (defmethod port-lookup-pixmap ((port basic-port) mirror)
271 cvs 1.10 (gethash mirror (slot-value port 'mirror->pixmap)))
272    
273 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
274 cvs 1.10 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
275     (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
276     nil)
277    
278 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
279 cvs 1.10 (remhash pixmap (slot-value port 'pixmap->mirror))
280     (remhash mirror (slot-value port 'mirror->pixmap))
281     nil)
282    
283 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
284 cvs 1.10 (declare (ignorable port pixmap))
285     (error "Don't know how to realize the mirror on a generic port"))
286    
287 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
288 cvs 1.10 (declare (ignorable port pixmap))
289 rouanet 1.15 (error "Don't know how to destroy the mirror on a generic port"))
290 cvs 1.10
291 gilbert 1.21 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
292 mikemac 1.1 (declare (ignore sheet width height))
293 cvs 1.10 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
294 mikemac 1.1
295 gilbert 1.21 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
296 mikemac 1.1 (declare (ignore pixmap))
297 cvs 1.10 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))
298 hefner1 1.42
299    
300 hefner1 1.43 (defgeneric port-force-output (port)
301     (:documentation "Flush the output buffer of PORT, if there is one."))
302 hefner1 1.42
303     (defmethod port-force-output ((port basic-port))
304     (values))
305 hefner1 1.43
306     (defgeneric port-grab-pointer (port pointer sheet)
307     (:documentation "Grab the specified pointer, for implementing TRACKING-POINTER."))
308    
309     (defgeneric port-ungrab-pointer (port pointer sheet)
310     (:documentation "Ungrab the specified pointer, for implementing TRACKING-POINTER."))
311    
312     (defmethod port-grab-pointer (port pointer sheet)
313     (declare (ignorable port pointer sheet))
314     (warn "Port ~A has not implemented pointer grabbing." port))
315    
316     (defmethod port-ungrab-pointer (port pointer sheet)
317     (declare (ignorable port pointer sheet))
318     (warn "Port ~A has not implemented pointer grabbing." port))
319    

  ViewVC Help
Powered by ViewVC 1.1.5