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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5