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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (show annotations)
Thu Aug 23 23:18:11 2001 UTC (12 years, 7 months ago) by rouanet
Branch: MAIN
Changes since 1.14: +8 -8 lines
The former mirrored-sheet class is now mirrored-sheet-mixin.
Changed the name in the existing code and made the necessary
adaptations.

Renamed the unrealize-mirror function, which was previously only
used internally by CLIM, but is now publicly advertised in the spec
as destroy-mirror.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (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
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 (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 (host-name (if (zerop colon) "localhost" (subseq s 0 colon)))
34 (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 #+cmu (cdr (assoc string ext:*environment-list* :test #'string=))
41 #+clisp (sys::getenv (string string))
42 #+sbcl (sb-ext::posix-getenv string)
43 #-(or excl cmu clisp sbcl) (error "GET-ENVIRONMENT-VARIABLE not implemented")))
44
45 (defvar *default-server-path*
46 #+unix (parse-display-variable (get-environment-variable "DISPLAY")))
47
48 (defvar *all-ports* nil)
49
50 (defclass port ()
51 ((server-path :initform nil
52 :initarg :server-path
53 :reader port-server-path)
54 (properties :initform nil
55 :initarg :properties)
56 (grafts :initform nil
57 :accessor port-grafts)
58 (frame-managers :initform nil
59 :reader frame-managers)
60 (sheet->mirror :initform (make-hash-table :test #'eq))
61 (mirror->sheet :initform (make-hash-table :test #'eq))
62 (pixmap->mirror :initform (make-hash-table :test #'eq))
63 (mirror->pixmap :initform (make-hash-table :test #'eq))
64 (keyboard-input-focus :initform nil
65 :initarg :keyboard-input-focus
66 :accessor port-keyboard-input-focus)
67 )
68 )
69
70 (defun find-port (&key (server-path *default-server-path*))
71 (loop for port in *all-ports*
72 if (equal server-path (port-server-path port))
73 do (return port)
74 finally (let ((port-type (get (first server-path) :port-type))
75 port)
76 (if (null port-type)
77 (error "Don't know how to make a port of type ~S" server-path))
78 (setq port (funcall 'make-instance port-type :server-path server-path))
79 (push port *all-ports*)
80 (return port))))
81
82 (defmethod port-lookup-mirror ((port port) (sheet mirrored-sheet-mixin))
83 (gethash sheet (slot-value port 'sheet->mirror)))
84
85 (defmethod port-lookup-sheet ((port port) mirror)
86 (gethash mirror (slot-value port 'mirror->sheet)))
87
88 (defmethod port-register-mirror ((port port) (sheet mirrored-sheet-mixin) mirror)
89 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
90 (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
91 nil)
92
93 (defmethod port-unregister-mirror ((port port) (sheet mirrored-sheet-mixin) mirror)
94 (remhash sheet (slot-value port 'sheet->mirror))
95 (remhash mirror (slot-value port 'mirror->sheet))
96 nil)
97
98 (defmethod realize-mirror ((port port) (sheet mirrored-sheet-mixin))
99 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
100
101 (defmethod destroy-mirror ((port port) (sheet mirrored-sheet-mixin))
102 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
103
104 (defmethod port-properties ((port port) indicator)
105 (with-slots (properties) port
106 (getf properties indicator)))
107
108 (defmethod (setf port-properties) (value (port port) indicator)
109 (with-slots (properties) port
110 (setf (getf properties indicator) value)))
111
112 (defmethod get-next-event ((port port) &key wait-function timeout)
113 (declare (ignore wait-function timeout))
114 (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
115
116 (defmethod process-next-event ((port port) &key wait-function timeout)
117 (let ((event (get-next-event port :wait-function wait-function :timeout timeout)))
118 (cond
119 ((null event) nil)
120 ((eq event :timeout) (values nil :timeout))
121 (t
122 (distribute-event port event)
123 t))))
124
125 (defmethod distribute-event ((port port) event)
126 (cond
127 ((typep event 'keyboard-event)
128 (dispatch-event (or (port-keyboard-input-focus port)
129 (event-sheet event)) event))
130 ((typep event 'window-event)
131 ; (dispatch-event (window-event-mirrored-sheet event) event))
132 (dispatch-event (event-sheet event) event))
133 ((typep event 'pointer-event)
134 (dispatch-event (event-sheet event) event))
135 ((typep event 'timer-event)
136 (error "Where do we send timer-events?"))
137 (t
138 (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
139
140 (defun map-over-ports (function)
141 (mapc function *all-ports*))
142
143 (defmethod restart-port ((port port))
144 (reset-watcher port :restart)
145 nil)
146
147 (defmethod destroy-port ((port port))
148 (reset-watcher port :destroy)
149 (setf *all-ports* (remove port *all-ports*)))
150
151 (defmethod add-watcher ((port port) watcher)
152 (declare (ignore watcher))
153 nil)
154
155 (defmethod delete-watcher ((port port) watcher)
156 (declare (ignore watcher))
157 nil)
158
159 (defmethod reset-watcher ((port port) how)
160 (declare (ignore how))
161 nil)
162
163 (defmethod make-graft ((port port) &key (orientation :default) (units :device))
164 (let ((graft (make-instance 'graft
165 :port port :mirror nil
166 :orientation orientation :units units)))
167 (push graft (port-grafts port))
168 graft))
169
170 (defmethod make-medium ((port port) sheet)
171 (make-instance 'medium :port port :graft (graft sheet) :sheet sheet))
172
173 (defmethod port-line-height ((port port) text-style)
174 (declare (ignore text-style))
175 (error "LINE-HEIGHT fell thru to a generic PORT"))
176
177 (defmethod port-character-width ((port port) text-style char)
178 (declare (ignore text-style char))
179 (error "PORT-CHARACTER-WIDTH fell thru to a generic PORT"))
180
181 (defmethod port-copy-area ((port port) sheet from-x from-y width height to-x to-y)
182 (declare (ignore sheet from-x from-y width height to-x to-y))
183 (error "COPY-AREA is not implemented for PORTs"))
184
185 ;;; Pixmap
186
187 (defmethod port-lookup-mirror ((port port) (pixmap pixmap))
188 (gethash pixmap (slot-value port 'pixmap->mirror)))
189
190 (defmethod port-lookup-pixmap ((port port) mirror)
191 (gethash mirror (slot-value port 'mirror->pixmap)))
192
193 (defmethod port-register-mirror ((port port) (pixmap pixmap) mirror)
194 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
195 (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
196 nil)
197
198 (defmethod port-unregister-mirror ((port port) (pixmap pixmap) mirror)
199 (remhash pixmap (slot-value port 'pixmap->mirror))
200 (remhash mirror (slot-value port 'mirror->pixmap))
201 nil)
202
203 (defmethod realize-mirror ((port port) (pixmap mirrored-pixmap))
204 (declare (ignorable port pixmap))
205 (error "Don't know how to realize the mirror on a generic port"))
206
207 (defmethod destroy-mirror ((port port) (pixmap mirrored-pixmap))
208 (declare (ignorable port pixmap))
209 (error "Don't know how to destroy the mirror on a generic port"))
210
211 (defmethod port-allocate-pixmap ((port port) sheet width height)
212 (declare (ignore sheet width height))
213 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
214
215 (defmethod port-deallocate-pixmap ((port port) pixmap)
216 (declare (ignore pixmap))
217 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))
218
219 (defmethod port-copy-to-pixmap ((port port) sheet from-x from-y width height
220 pixmap to-x to-y)
221 (declare (ignore sheet from-x from-y width height pixmap to-x to-y))
222 (error "COPY-TO-PIXMAP is not implemented for generic PORTs"))
223

  ViewVC Help
Powered by ViewVC 1.1.5