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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Thu Jun 8 22:01:12 2000 UTC (13 years, 10 months ago) by mikemac
Branch: MAIN
Branch point for: initial
Initial revision
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 (in-package :CLIM-INTERNALS)
21
22 (defvar *default-server-path* #+unix '(:x11 :host "" :display-id 0 :screen-id 0))
23
24 (defvar *all-ports* nil)
25
26 (defclass port ()
27 ((server-path :initform nil
28 :initarg :server-path
29 :reader port-server-path)
30 (properties :initform nil
31 :initarg :properties)
32 (grafts :initform nil
33 :accessor port-grafts)
34 (frame-managers :initform nil
35 :reader frame-managers)
36 (sheet->mirror :initform (make-hash-table :test #'eq))
37 (mirror->sheet :initform (make-hash-table :test #'eq))
38 (keyboard-input-focus :initform nil
39 :initarg :keyboard-input-focus
40 :accessor port-keyboard-input-focus)
41 )
42 )
43
44 (defun find-port (&key (server-path *default-server-path*))
45 (loop for port in *all-ports*
46 if (equal server-path (port-server-path port))
47 do (return port)
48 finally (let ((port-type (get (first server-path) :port-type))
49 port)
50 (if (null port-type)
51 (error "Don't know how to make a port of type ~S" server-path))
52 (setq port (funcall 'make-instance port-type :server-path server-path))
53 (push port *all-ports*)
54 (return port))))
55
56 (defmethod port-lookup-mirror ((port port) (sheet sheet))
57 (gethash sheet (slot-value port 'sheet->mirror)))
58
59 (defmethod port-lookup-sheet ((port port) mirror)
60 (gethash mirror (slot-value port 'mirror->sheet)))
61
62 (defmethod port-register-mirror ((port port) (sheet sheet) mirror)
63 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
64 (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
65 nil)
66
67 (defmethod port-unregister-mirror ((port port) (sheet sheet) mirror)
68 (remhash sheet (slot-value port 'sheet->mirror))
69 (remhash mirror (slot-value port 'mirror->sheet))
70 nil)
71
72 (defmethod realize-mirror ((port port) (sheet sheet))
73 (loop for child in (sheet-children sheet)
74 do (realize-mirror port child)))
75
76 (defmethod realize-mirror ((port port) (sheet mirrored-sheet))
77 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
78
79 (defmethod unrealize-mirror ((port port) (sheet sheet))
80 (loop for child in (sheet-children sheet)
81 do (unrealize-mirror port child)))
82
83 (defmethod unrealize-mirror ((port port) (sheet mirrored-sheet))
84 (error "Don't know how to unrealize the mirror of a generic mirrored-sheet"))
85
86 (defmethod port-properties ((port port) indicator)
87 (with-slots (properties) port
88 (getf properties indicator)))
89
90 (defmethod (setf port-properties) (value (port port) indicator)
91 (with-slots (properties) port
92 (setf (getf properties indicator) value)))
93
94 (defmethod get-next-event ((port port) &key wait-function timeout)
95 (declare (ignore wait-function timeout))
96 (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
97
98 (defmethod process-next-event ((port port) &key wait-function timeout)
99 (let ((event (get-next-event port :wait-function wait-function :timeout timeout)))
100 (cond
101 ((null event) nil)
102 ((eq event :timeout) (values nil :timeout))
103 (t
104 (distribute-event port event)
105 t))))
106
107 (defmethod distribute-event ((port port) event)
108 (cond
109 ((typep event 'keyboard-event)
110 (dispatch-event (or (port-keyboard-input-focus port)
111 (event-sheet event)) event))
112 ((typep event 'window-event)
113 (dispatch-event (window-event-mirrored-sheet event) event))
114 ((typep event 'pointer-event)
115 (dispatch-event (event-sheet event) event))
116 ((typep event 'timer-event)
117 (error "Where do we send timer-events?"))
118 (t
119 (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
120
121 (defun map-over-ports (function)
122 (mapc function *all-ports*))
123
124 (defmethod restart-port ((port port))
125 (reset-watcher port :restart)
126 nil)
127
128 (defmethod destroy-port ((port port))
129 (reset-watcher port :destroy)
130 (setf *all-ports* (remove port *all-ports*)))
131
132 (defmethod add-watcher ((port port) watcher)
133 (declare (ignore watcher))
134 nil)
135
136 (defmethod delete-watcher ((port port) watcher)
137 (declare (ignore watcher))
138 nil)
139
140 (defmethod reset-watcher ((port port) how)
141 (declare (ignore how))
142 nil)
143
144 (defmethod make-graft ((port port) &key (orientation :default) (units :device))
145 (let ((graft (make-instance 'graft
146 :port port :mirror nil
147 :orientation orientation :units units)))
148 (push graft (port-grafts port))
149 graft))
150
151 (defmethod make-medium ((port port) sheet)
152 (make-instance 'medium :port port :graft (graft sheet) :sheet sheet))
153
154 (defmethod line-height ((port port) text-style)
155 (declare (ignore text-style))
156 (error "LINE-HEIGHT fell thru to a generic PORT"))
157
158 (defmethod character-width ((port port) char text-style)
159 (declare (ignore char text-style))
160 (error "CHARACTER-WIDTH fell thru to a generic PORT"))
161
162 (defmethod beep ((port port))
163 )
164
165 (defmethod port-allocate-pixmap ((port port) sheet width height)
166 (declare (ignore sheet width height))
167 (error "ALLOCATE-PIXMAP is not implemented for PORTs"))
168
169 (defmethod port-deallocate-pixmap ((port port) pixmap)
170 (declare (ignore pixmap))
171 (error "DEALLOCATE-PIXMAP is not implemented for PORTs"))
172
173 (defmethod port-copy-to-pixmap ((port port) sheet from-x from-y width height
174 pixmap to-x to-y)
175 (declare (ignore sheet from-x from-y width height pixmap to-x to-y))
176 (error "COPY-TO-PIXMAP is not implemented for PORTs"))
177
178 (defmethod port-copy-area ((port port) sheet from-x from-y width height to-x to-y)
179 (declare (ignore sheet from-x from-y width height to-x to-y))
180 (error "COPY-AREA is not implemented for PORTs"))
181

  ViewVC Help
Powered by ViewVC 1.1.5