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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.50 - (hide annotations)
Fri Mar 10 21:58:13 2006 UTC (8 years, 1 month ago) by tmoore
Branch: MAIN
CVS Tags: McCLIM-0-9-2
Changes since 1.49: +0 -2 lines
Move most protocol class definitions into protocol-classes.lisp, which
is compiled and loaded early. Some class definitions, which had slot
definitions that I didn't have the stomach to tease apart, stayed
behind.

Replace the presentation documentation state mechanism with
updating-output so that other functions / programs can write to the
pointer documentation area and not screw things up. We still use the
state to actually print the documentation.
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 duncan 1.47 (defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl :beagle))
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.21 (defclass basic-port (port)
39 mikemac 1.1 ((server-path :initform nil
40     :initarg :server-path
41     :reader port-server-path)
42     (properties :initform nil
43     :initarg :properties)
44     (grafts :initform nil
45     :accessor port-grafts)
46     (frame-managers :initform nil
47     :reader frame-managers)
48     (sheet->mirror :initform (make-hash-table :test #'eq))
49     (mirror->sheet :initform (make-hash-table :test #'eq))
50 cvs 1.10 (pixmap->mirror :initform (make-hash-table :test #'eq))
51     (mirror->pixmap :initform (make-hash-table :test #'eq))
52 hefner1 1.40 #+ignore (keyboard-input-focus :initform nil ;; nuked this, see below
53 mikemac 1.1 :initarg :keyboard-input-focus
54     :accessor port-keyboard-input-focus)
55 gilbert 1.21 (event-process
56     :initform nil
57     :initarg :event-process
58     :accessor port-event-process
59     :documentation "In a multiprocessing environment, the particular process
60     reponsible for calling PROCESS-NEXT-EVENT in a loop.")
61 adejneka 1.34
62 gilbert 1.21 (lock
63     :initform (make-recursive-lock "port lock")
64 mikemac 1.25 :accessor port-lock)
65     (event-count :initform 0)
66 adejneka 1.34 (text-style-mappings :initform (make-hash-table :test #'eq)
67     :reader port-text-style-mappings)
68 moore 1.36 (pointer-sheet :initform nil :accessor port-pointer-sheet
69     :documentation "The sheet the pointer is over, if any")
70 mikemac 1.25 ))
71 mikemac 1.1
72 hefner1 1.40 ;; Keyboard focus is now managed per-frame rather than per-port,
73 ahefner 1.48 ;; which makes a lot of sense (less sense in the presense of
74     ;; multiple top-level windows, but no one does that yet). The CLIM
75     ;; spec suggests this in a "Minor Issue". So, redirect
76     ;; PORT-KEYBOARD-INPUT-FOCUS to the current application frame
77     ;; for compatibility.
78    
79     ;; Note: This would prevent you from using the function the
80     ;; function to query who currently has the focus. I don't
81     ;; know if this is an intended use or not.
82    
83     ;; The big picture:
84     ;; PORT-KEYBOARD-INPUT-FOCUS is defined by CLIM 2.0
85     ;; Our default method on this delegates to KEYBOARD-INPUT-FOCUS
86     ;; on the current application frame.
87     ;; %SET-PORT-KEYBOARD-FOCUS is the function which
88     ;; should be implemented in a McCLIM backend and
89     ;; does the work of changing the focus.
90     ;; A method on (SETF KEYBOARD-INPUT-FOCUS) brings them together,
91     ;; calling %SET-PORT-KEYBOARD-FOCUS.
92    
93 rstrandh 1.49 (defgeneric port-keyboard-input-focus (port))
94     (defgeneric (setf port-keyboard-input-focus) (focus port))
95    
96 hefner1 1.40 (defmethod port-keyboard-input-focus (port)
97     (declare (ignore port))
98     (when *application-frame*
99     (keyboard-input-focus *application-frame*)))
100    
101     (defmethod (setf port-keyboard-input-focus) (focus port)
102 hefner1 1.41 (when focus
103     (if (pane-frame focus)
104     (setf (keyboard-input-focus (pane-frame focus)) focus)
105 ahefner 1.48 (%set-port-keyboard-focus port focus))))
106 hefner1 1.41
107     ;; This is not in the CLIM spec, but since (setf port-keyboard-input-focus)
108     ;; now calls (setf keyboard-input-focus), we need something concrete the
109     ;; backend can implement to set the focus.
110 ahefner 1.48 (defmethod %set-port-keyboard-focus (port focus &key timestamp)
111 rstrandh 1.49 (declare (ignore focus timestamp))
112 ahefner 1.48 (warn "%SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port))
113 hefner1 1.41
114 hefner1 1.40
115 mikemac 1.1 (defun find-port (&key (server-path *default-server-path*))
116 mikemac 1.22 (if (null server-path)
117     (setq server-path (find-default-server-path)))
118     (if (atom server-path)
119     (setq server-path (list server-path)))
120     (setq server-path (funcall (get (first server-path) :server-path-parser) server-path))
121 mikemac 1.1 (loop for port in *all-ports*
122     if (equal server-path (port-server-path port))
123     do (return port)
124     finally (let ((port-type (get (first server-path) :port-type))
125     port)
126     (if (null port-type)
127     (error "Don't know how to make a port of type ~S" server-path))
128     (setq port (funcall 'make-instance port-type :server-path server-path))
129     (push port *all-ports*)
130     (return port))))
131    
132 gilbert 1.21 (defmethod initialize-instance :after ((port basic-port) &rest args)
133     (declare (ignorable args))
134     )
135    
136     (defmethod destroy-port :before ((port basic-port))
137 adejneka 1.33 (when (and *multiprocessing-p* (port-event-process port))
138 gilbert 1.21 (destroy-process (port-event-process port))
139     (setf (port-event-process port) nil)))
140    
141     (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
142 mikemac 1.1 (gethash sheet (slot-value port 'sheet->mirror)))
143    
144 gilbert 1.21 (defmethod port-lookup-sheet ((port basic-port) mirror)
145 mikemac 1.1 (gethash mirror (slot-value port 'mirror->sheet)))
146    
147 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
148 mikemac 1.1 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
149     (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
150     nil)
151    
152 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
153 mikemac 1.1 (remhash sheet (slot-value port 'sheet->mirror))
154     (remhash mirror (slot-value port 'mirror->sheet))
155     nil)
156    
157 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
158 mikemac 1.1 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
159    
160 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
161 rouanet 1.15 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
162 mikemac 1.1
163 gilbert 1.21 (defmethod mirror-transformation ((port basic-port) mirror)
164 rouanet 1.16 (declare (ignore mirror))
165     (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
166    
167 gilbert 1.21 (defmethod port-properties ((port basic-port) indicator)
168 mikemac 1.1 (with-slots (properties) port
169     (getf properties indicator)))
170    
171 gilbert 1.21 (defmethod (setf port-properties) (value (port basic-port) indicator)
172 mikemac 1.1 (with-slots (properties) port
173     (setf (getf properties indicator) value)))
174    
175 gilbert 1.21 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
176 mikemac 1.1 (declare (ignore wait-function timeout))
177     (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
178    
179 mikemac 1.25 (defmethod get-next-event :after ((port basic-port) &key wait-function timeout)
180     (declare (ignore wait-function timeout))
181     (with-slots (event-count) port
182     (incf event-count)))
183    
184 gilbert 1.21 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
185 moore 1.26 (let ((event (get-next-event port
186     :wait-function wait-function
187     :timeout timeout)))
188 mikemac 1.1 (cond
189     ((null event) nil)
190     ((eq event :timeout) (values nil :timeout))
191     (t
192 moore 1.27 (distribute-event port event)
193 mikemac 1.1 t))))
194    
195 gilbert 1.21 (defmethod distribute-event ((port basic-port) event)
196 mikemac 1.1 (cond
197     ((typep event 'keyboard-event)
198 hefner1 1.40 (dispatch-event (or #+ignore(port-keyboard-input-focus port) (event-sheet event))
199 moore 1.35 event))
200 mikemac 1.1 ((typep event 'window-event)
201 brian 1.28 ; (dispatch-event (window-event-mirrored-sheet event) event)
202 cvs 1.4 (dispatch-event (event-sheet event) event))
203 mikemac 1.1 ((typep event 'pointer-event)
204     (dispatch-event (event-sheet event) event))
205 mikemac 1.23 ((typep event 'window-manager-delete-event)
206     ;; not sure where this type of event should get sent - mikemac
207 moore 1.27 ;; This seems fine; will be handled by the top-level-sheet-pane - moore
208     (dispatch-event (event-sheet event) event))
209 mikemac 1.1 ((typep event 'timer-event)
210     (error "Where do we send timer-events?"))
211     (t
212     (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
213    
214 gilbert 1.21 (defmacro with-port-locked ((port) &body body)
215     (let ((fn (gensym "CONT.")))
216     `(labels ((,fn ()
217     ,@body))
218     (declare (dynamic-extent #',fn))
219 moore 1.29 (invoke-with-port-locked ,port #',fn))))
220 gilbert 1.21
221     (defmethod invoke-with-port-locked ((port basic-port) continuation)
222     (with-recursive-lock-held ((port-lock port))
223     (funcall continuation)))
224    
225 mikemac 1.1 (defun map-over-ports (function)
226     (mapc function *all-ports*))
227    
228 gilbert 1.21 (defmethod restart-port ((port basic-port))
229 mikemac 1.1 (reset-watcher port :restart)
230     nil)
231    
232 gilbert 1.21 (defmethod destroy-port ((port basic-port))
233 mikemac 1.1 (reset-watcher port :destroy)
234     (setf *all-ports* (remove port *all-ports*)))
235    
236 gilbert 1.21 (defmethod add-watcher ((port basic-port) watcher)
237 mikemac 1.1 (declare (ignore watcher))
238     nil)
239    
240 gilbert 1.21 (defmethod delete-watcher ((port basic-port) watcher)
241 mikemac 1.1 (declare (ignore watcher))
242     nil)
243    
244 gilbert 1.21 (defmethod reset-watcher ((port basic-port) how)
245 mikemac 1.1 (declare (ignore how))
246     nil)
247    
248 gilbert 1.21 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
249 mikemac 1.1 (let ((graft (make-instance 'graft
250     :port port :mirror nil
251     :orientation orientation :units units)))
252     (push graft (port-grafts port))
253     graft))
254    
255 gilbert 1.21 #||
256     (defmethod make-medium ((port basic-port) sheet)
257 rouanet 1.16 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
258 gilbert 1.21 ||#
259 mikemac 1.1
260 cvs 1.10 ;;; Pixmap
261    
262 gilbert 1.21 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
263 cvs 1.10 (gethash pixmap (slot-value port 'pixmap->mirror)))
264    
265 gilbert 1.21 (defmethod port-lookup-pixmap ((port basic-port) mirror)
266 cvs 1.10 (gethash mirror (slot-value port 'mirror->pixmap)))
267    
268 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
269 cvs 1.10 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
270     (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
271     nil)
272    
273 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
274 cvs 1.10 (remhash pixmap (slot-value port 'pixmap->mirror))
275     (remhash mirror (slot-value port 'mirror->pixmap))
276     nil)
277    
278 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
279 cvs 1.10 (declare (ignorable port pixmap))
280     (error "Don't know how to realize the mirror on a generic port"))
281    
282 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
283 cvs 1.10 (declare (ignorable port pixmap))
284 rouanet 1.15 (error "Don't know how to destroy the mirror on a generic port"))
285 cvs 1.10
286 gilbert 1.21 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
287 mikemac 1.1 (declare (ignore sheet width height))
288 cvs 1.10 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
289 mikemac 1.1
290 gilbert 1.21 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
291 mikemac 1.1 (declare (ignore pixmap))
292 cvs 1.10 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))
293 hefner1 1.42
294    
295 hefner1 1.43 (defgeneric port-force-output (port)
296     (:documentation "Flush the output buffer of PORT, if there is one."))
297 hefner1 1.42
298     (defmethod port-force-output ((port basic-port))
299     (values))
300 hefner1 1.43
301     (defgeneric port-grab-pointer (port pointer sheet)
302     (:documentation "Grab the specified pointer, for implementing TRACKING-POINTER."))
303    
304     (defgeneric port-ungrab-pointer (port pointer sheet)
305     (:documentation "Ungrab the specified pointer, for implementing TRACKING-POINTER."))
306    
307 hefner1 1.44 (defmethod port-grab-pointer ((port basic-port) pointer sheet)
308 hefner1 1.43 (declare (ignorable port pointer sheet))
309     (warn "Port ~A has not implemented pointer grabbing." port))
310    
311 hefner1 1.44 (defmethod port-ungrab-pointer ((port basic-port) pointer sheet)
312 hefner1 1.43 (declare (ignorable port pointer sheet))
313     (warn "Port ~A has not implemented pointer grabbing." port))
314    
315 hefner1 1.44 (defgeneric set-sheet-pointer-cursor (port sheet cursor)
316     (:documentation "Sets the cursor associated with SHEET. CURSOR is a symbol, as described in the Franz user's guide."))
317    
318     (defmethod set-sheet-pointer-cursor ((port basic-port) sheet cursor)
319 moore 1.46 (declare (ignore sheet cursor))
320 hefner1 1.44 (warn "Port ~A has not implemented sheet pointer cursors." port))

  ViewVC Help
Powered by ViewVC 1.1.5