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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (hide annotations)
Mon Feb 11 21:46:36 2002 UTC (12 years, 2 months ago) by gilbert
Branch: MAIN
Changes since 1.20: +64 -29 lines
BASIC-PORT class
    Now features an event-process slot as well as a lock.

Basically all methods, which specialized on PORT, now specialize on
BASIC-PORT.

DESTROY-PORT :before ((port basic-port))
    New method, kills the event process.

WITH-PORT-LOCKED, INVOKE-WITH-PORT-LOCKED
    New macro.
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 cvs 1.2 (eval-when (:compile-toplevel :load-toplevel :execute)
27     (defun parse-display-variable (s)
28     "Given a string in standard X11 display format host-name:display-number:screen-number,
29     returns a list in CLIM X11 format (:x11 :host host-name :display-id display-number
30     :screen-id screen-number)."
31     (let* ((colon (position #\: s))
32     (dot (position #\. s :start colon))
33 moore 1.20 (host-name (subseq s 0 colon))
34 cvs 1.2 (display-number (parse-integer s :start (1+ colon) :end dot))
35     (screen-number (if dot (parse-integer s :start (1+ dot)) 0)))
36     (list :x11 :host host-name :display-id display-number :screen-id screen-number)))
37    
38     (defun get-environment-variable (string)
39     #+excl (sys:getenv string)
40 cvs 1.3 #+cmu (cdr (assoc string ext:*environment-list* :test #'string=))
41 cvs 1.6 #+clisp (sys::getenv (string string))
42 adejneka 1.12 #+sbcl (sb-ext::posix-getenv string)
43 cvs 1.11 #-(or excl cmu clisp sbcl) (error "GET-ENVIRONMENT-VARIABLE not implemented")))
44 cvs 1.2
45     (defvar *default-server-path*
46     #+unix (parse-display-variable (get-environment-variable "DISPLAY")))
47 mikemac 1.1
48     (defvar *all-ports* nil)
49    
50     (defclass port ()
51 gilbert 1.21 ()
52     (:documentation
53     "The protocol class that corresponds to a port."))
54    
55     (defclass basic-port (port)
56 mikemac 1.1 ((server-path :initform nil
57     :initarg :server-path
58     :reader port-server-path)
59     (properties :initform nil
60     :initarg :properties)
61     (grafts :initform nil
62     :accessor port-grafts)
63     (frame-managers :initform nil
64     :reader frame-managers)
65     (sheet->mirror :initform (make-hash-table :test #'eq))
66     (mirror->sheet :initform (make-hash-table :test #'eq))
67 cvs 1.10 (pixmap->mirror :initform (make-hash-table :test #'eq))
68     (mirror->pixmap :initform (make-hash-table :test #'eq))
69 mikemac 1.1 (keyboard-input-focus :initform nil
70     :initarg :keyboard-input-focus
71     :accessor port-keyboard-input-focus)
72 gilbert 1.21 (event-process
73     :initform nil
74     :initarg :event-process
75     :accessor port-event-process
76     :documentation "In a multiprocessing environment, the particular process
77     reponsible for calling PROCESS-NEXT-EVENT in a loop.")
78    
79     (lock
80     :initform (make-recursive-lock "port lock")
81     :accessor port-lock) ))
82 mikemac 1.1
83     (defun find-port (&key (server-path *default-server-path*))
84     (loop for port in *all-ports*
85     if (equal server-path (port-server-path port))
86     do (return port)
87     finally (let ((port-type (get (first server-path) :port-type))
88     port)
89     (if (null port-type)
90     (error "Don't know how to make a port of type ~S" server-path))
91     (setq port (funcall 'make-instance port-type :server-path server-path))
92     (push port *all-ports*)
93     (return port))))
94    
95 gilbert 1.21 (defmethod initialize-instance :after ((port basic-port) &rest args)
96     (declare (ignorable args))
97     )
98    
99     (defmethod destroy-port :before ((port basic-port))
100     (when *multiprocessing-p*
101     (destroy-process (port-event-process port))
102     (setf (port-event-process port) nil)))
103    
104     (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
105 mikemac 1.1 (gethash sheet (slot-value port 'sheet->mirror)))
106    
107 gilbert 1.21 (defmethod port-lookup-sheet ((port basic-port) mirror)
108 mikemac 1.1 (gethash mirror (slot-value port 'mirror->sheet)))
109    
110 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
111 mikemac 1.1 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
112     (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
113     nil)
114    
115 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
116 mikemac 1.1 (remhash sheet (slot-value port 'sheet->mirror))
117     (remhash mirror (slot-value port 'mirror->sheet))
118     nil)
119    
120 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
121 mikemac 1.1 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
122    
123 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
124 rouanet 1.15 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
125 mikemac 1.1
126 gilbert 1.21 (defmethod mirror-transformation ((port basic-port) mirror)
127 rouanet 1.16 (declare (ignore mirror))
128     (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
129    
130 gilbert 1.21 (defmethod port-properties ((port basic-port) indicator)
131 mikemac 1.1 (with-slots (properties) port
132     (getf properties indicator)))
133    
134 gilbert 1.21 (defmethod (setf port-properties) (value (port basic-port) indicator)
135 mikemac 1.1 (with-slots (properties) port
136     (setf (getf properties indicator) value)))
137    
138 gilbert 1.21 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
139 mikemac 1.1 (declare (ignore wait-function timeout))
140     (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
141    
142 gilbert 1.21 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
143 mikemac 1.1 (let ((event (get-next-event port :wait-function wait-function :timeout timeout)))
144     (cond
145     ((null event) nil)
146     ((eq event :timeout) (values nil :timeout))
147     (t
148     (distribute-event port event)
149     t))))
150    
151 gilbert 1.21 (defmethod distribute-event ((port basic-port) event)
152 mikemac 1.1 (cond
153     ((typep event 'keyboard-event)
154     (dispatch-event (or (port-keyboard-input-focus port)
155     (event-sheet event)) event))
156     ((typep event 'window-event)
157 cvs 1.4 ; (dispatch-event (window-event-mirrored-sheet event) event))
158     (dispatch-event (event-sheet event) event))
159 mikemac 1.1 ((typep event 'pointer-event)
160     (dispatch-event (event-sheet event) event))
161     ((typep event 'timer-event)
162     (error "Where do we send timer-events?"))
163     (t
164     (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
165    
166 gilbert 1.21 (defmacro with-port-locked ((port) &body body)
167     (let ((fn (gensym "CONT.")))
168     `(labels ((,fn ()
169     ,@body))
170     (declare (dynamic-extent #',fn))
171     `(invoke-with-port-locked ,port #',fn))))
172    
173     (defmethod invoke-with-port-locked ((port basic-port) continuation)
174     (with-recursive-lock-held ((port-lock port))
175     (funcall continuation)))
176    
177 mikemac 1.1 (defun map-over-ports (function)
178     (mapc function *all-ports*))
179    
180 gilbert 1.21 (defmethod restart-port ((port basic-port))
181 mikemac 1.1 (reset-watcher port :restart)
182     nil)
183    
184 gilbert 1.21 (defmethod destroy-port ((port basic-port))
185 mikemac 1.1 (reset-watcher port :destroy)
186     (setf *all-ports* (remove port *all-ports*)))
187    
188 gilbert 1.21 (defmethod add-watcher ((port basic-port) watcher)
189 mikemac 1.1 (declare (ignore watcher))
190     nil)
191    
192 gilbert 1.21 (defmethod delete-watcher ((port basic-port) watcher)
193 mikemac 1.1 (declare (ignore watcher))
194     nil)
195    
196 gilbert 1.21 (defmethod reset-watcher ((port basic-port) how)
197 mikemac 1.1 (declare (ignore how))
198     nil)
199    
200 gilbert 1.21 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
201 mikemac 1.1 (let ((graft (make-instance 'graft
202     :port port :mirror nil
203     :orientation orientation :units units)))
204     (push graft (port-grafts port))
205     graft))
206    
207 gilbert 1.21 #||
208     (defmethod make-medium ((port basic-port) sheet)
209 rouanet 1.16 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
210 gilbert 1.21 ||#
211 mikemac 1.1
212 cvs 1.10 ;;; Pixmap
213    
214 gilbert 1.21 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
215 cvs 1.10 (gethash pixmap (slot-value port 'pixmap->mirror)))
216    
217 gilbert 1.21 (defmethod port-lookup-pixmap ((port basic-port) mirror)
218 cvs 1.10 (gethash mirror (slot-value port 'mirror->pixmap)))
219    
220 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
221 cvs 1.10 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
222     (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
223     nil)
224    
225 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
226 cvs 1.10 (remhash pixmap (slot-value port 'pixmap->mirror))
227     (remhash mirror (slot-value port 'mirror->pixmap))
228     nil)
229    
230 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
231 cvs 1.10 (declare (ignorable port pixmap))
232     (error "Don't know how to realize the mirror on a generic port"))
233    
234 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
235 cvs 1.10 (declare (ignorable port pixmap))
236 rouanet 1.15 (error "Don't know how to destroy the mirror on a generic port"))
237 cvs 1.10
238 gilbert 1.21 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
239 mikemac 1.1 (declare (ignore sheet width height))
240 cvs 1.10 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
241 mikemac 1.1
242 gilbert 1.21 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
243 mikemac 1.1 (declare (ignore pixmap))
244 cvs 1.10 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))

  ViewVC Help
Powered by ViewVC 1.1.5