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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (hide annotations)
Wed Feb 27 23:13:34 2002 UTC (12 years, 1 month ago) by mikemac
Branch: MAIN
Changes since 1.23: +1 -1 lines
make window-manager-delete-event work
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     (in-package :CLIM-INTERNALS)
25    
26 mikemac 1.22 (defvar *default-server-path* NIL)
27    
28     (defvar *server-path-search-order* '(:clx :x11 :genera))
29    
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     (defclass port ()
39 gilbert 1.21 ()
40     (:documentation
41     "The protocol class that corresponds to a port."))
42    
43     (defclass basic-port (port)
44 mikemac 1.1 ((server-path :initform nil
45     :initarg :server-path
46     :reader port-server-path)
47     (properties :initform nil
48     :initarg :properties)
49     (grafts :initform nil
50     :accessor port-grafts)
51     (frame-managers :initform nil
52     :reader frame-managers)
53     (sheet->mirror :initform (make-hash-table :test #'eq))
54     (mirror->sheet :initform (make-hash-table :test #'eq))
55 cvs 1.10 (pixmap->mirror :initform (make-hash-table :test #'eq))
56     (mirror->pixmap :initform (make-hash-table :test #'eq))
57 mikemac 1.1 (keyboard-input-focus :initform nil
58     :initarg :keyboard-input-focus
59     :accessor port-keyboard-input-focus)
60 gilbert 1.21 (event-process
61     :initform nil
62     :initarg :event-process
63     :accessor port-event-process
64     :documentation "In a multiprocessing environment, the particular process
65     reponsible for calling PROCESS-NEXT-EVENT in a loop.")
66    
67     (lock
68     :initform (make-recursive-lock "port lock")
69     :accessor port-lock) ))
70 mikemac 1.1
71     (defun find-port (&key (server-path *default-server-path*))
72 mikemac 1.22 (if (null server-path)
73     (setq server-path (find-default-server-path)))
74     (if (atom server-path)
75     (setq server-path (list server-path)))
76     (setq server-path (funcall (get (first server-path) :server-path-parser) server-path))
77 mikemac 1.1 (loop for port in *all-ports*
78     if (equal server-path (port-server-path port))
79     do (return port)
80     finally (let ((port-type (get (first server-path) :port-type))
81     port)
82     (if (null port-type)
83     (error "Don't know how to make a port of type ~S" server-path))
84     (setq port (funcall 'make-instance port-type :server-path server-path))
85     (push port *all-ports*)
86     (return port))))
87    
88 gilbert 1.21 (defmethod initialize-instance :after ((port basic-port) &rest args)
89     (declare (ignorable args))
90     )
91    
92     (defmethod destroy-port :before ((port basic-port))
93     (when *multiprocessing-p*
94     (destroy-process (port-event-process port))
95     (setf (port-event-process port) nil)))
96    
97     (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
98 mikemac 1.1 (gethash sheet (slot-value port 'sheet->mirror)))
99    
100 gilbert 1.21 (defmethod port-lookup-sheet ((port basic-port) mirror)
101 mikemac 1.1 (gethash mirror (slot-value port 'mirror->sheet)))
102    
103 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
104 mikemac 1.1 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
105     (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
106     nil)
107    
108 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
109 mikemac 1.1 (remhash sheet (slot-value port 'sheet->mirror))
110     (remhash mirror (slot-value port 'mirror->sheet))
111     nil)
112    
113 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
114 mikemac 1.1 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
115    
116 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
117 rouanet 1.15 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
118 mikemac 1.1
119 gilbert 1.21 (defmethod mirror-transformation ((port basic-port) mirror)
120 rouanet 1.16 (declare (ignore mirror))
121     (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
122    
123 gilbert 1.21 (defmethod port-properties ((port basic-port) indicator)
124 mikemac 1.1 (with-slots (properties) port
125     (getf properties indicator)))
126    
127 gilbert 1.21 (defmethod (setf port-properties) (value (port basic-port) indicator)
128 mikemac 1.1 (with-slots (properties) port
129     (setf (getf properties indicator) value)))
130    
131 gilbert 1.21 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
132 mikemac 1.1 (declare (ignore wait-function timeout))
133     (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
134    
135 gilbert 1.21 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
136 mikemac 1.1 (let ((event (get-next-event port :wait-function wait-function :timeout timeout)))
137     (cond
138     ((null event) nil)
139     ((eq event :timeout) (values nil :timeout))
140     (t
141     (distribute-event port event)
142     t))))
143    
144 gilbert 1.21 (defmethod distribute-event ((port basic-port) event)
145 mikemac 1.1 (cond
146     ((typep event 'keyboard-event)
147     (dispatch-event (or (port-keyboard-input-focus port)
148     (event-sheet event)) event))
149     ((typep event 'window-event)
150 cvs 1.4 ; (dispatch-event (window-event-mirrored-sheet event) event))
151     (dispatch-event (event-sheet event) event))
152 mikemac 1.1 ((typep event 'pointer-event)
153     (dispatch-event (event-sheet event) event))
154 mikemac 1.23 ((typep event 'window-manager-delete-event)
155     ;; not sure where this type of event should get sent - mikemac
156 mikemac 1.24 (queue-event (frame-standard-input (pane-frame (event-sheet event))) event))
157 mikemac 1.1 ((typep event 'timer-event)
158     (error "Where do we send timer-events?"))
159     (t
160     (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
161    
162 gilbert 1.21 (defmacro with-port-locked ((port) &body body)
163     (let ((fn (gensym "CONT.")))
164     `(labels ((,fn ()
165     ,@body))
166     (declare (dynamic-extent #',fn))
167     `(invoke-with-port-locked ,port #',fn))))
168    
169     (defmethod invoke-with-port-locked ((port basic-port) continuation)
170     (with-recursive-lock-held ((port-lock port))
171     (funcall continuation)))
172    
173 mikemac 1.1 (defun map-over-ports (function)
174     (mapc function *all-ports*))
175    
176 gilbert 1.21 (defmethod restart-port ((port basic-port))
177 mikemac 1.1 (reset-watcher port :restart)
178     nil)
179    
180 gilbert 1.21 (defmethod destroy-port ((port basic-port))
181 mikemac 1.1 (reset-watcher port :destroy)
182     (setf *all-ports* (remove port *all-ports*)))
183    
184 gilbert 1.21 (defmethod add-watcher ((port basic-port) watcher)
185 mikemac 1.1 (declare (ignore watcher))
186     nil)
187    
188 gilbert 1.21 (defmethod delete-watcher ((port basic-port) watcher)
189 mikemac 1.1 (declare (ignore watcher))
190     nil)
191    
192 gilbert 1.21 (defmethod reset-watcher ((port basic-port) how)
193 mikemac 1.1 (declare (ignore how))
194     nil)
195    
196 gilbert 1.21 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
197 mikemac 1.1 (let ((graft (make-instance 'graft
198     :port port :mirror nil
199     :orientation orientation :units units)))
200     (push graft (port-grafts port))
201     graft))
202    
203 gilbert 1.21 #||
204     (defmethod make-medium ((port basic-port) sheet)
205 rouanet 1.16 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
206 gilbert 1.21 ||#
207 mikemac 1.1
208 cvs 1.10 ;;; Pixmap
209    
210 gilbert 1.21 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
211 cvs 1.10 (gethash pixmap (slot-value port 'pixmap->mirror)))
212    
213 gilbert 1.21 (defmethod port-lookup-pixmap ((port basic-port) mirror)
214 cvs 1.10 (gethash mirror (slot-value port 'mirror->pixmap)))
215    
216 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
217 cvs 1.10 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
218     (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
219     nil)
220    
221 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
222 cvs 1.10 (remhash pixmap (slot-value port 'pixmap->mirror))
223     (remhash mirror (slot-value port 'mirror->pixmap))
224     nil)
225    
226 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
227 cvs 1.10 (declare (ignorable port pixmap))
228     (error "Don't know how to realize the mirror on a generic port"))
229    
230 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
231 cvs 1.10 (declare (ignorable port pixmap))
232 rouanet 1.15 (error "Don't know how to destroy the mirror on a generic port"))
233 cvs 1.10
234 gilbert 1.21 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
235 mikemac 1.1 (declare (ignore sheet width height))
236 cvs 1.10 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
237 mikemac 1.1
238 gilbert 1.21 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
239 mikemac 1.1 (declare (ignore pixmap))
240 cvs 1.10 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))

  ViewVC Help
Powered by ViewVC 1.1.5