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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Fri Feb 8 18:32:27 2002 UTC (12 years, 2 months ago) by moore
Branch: MAIN
Changes since 1.19: +1 -1 lines
Committed initial code for Goatee emacs-alike editor.  This is all completely
broken at the moment.  Added conditions for errors encountered during accept
(spuriously referred to as errors in present in the spec).  Added some new
accept presentation methods.  Changed parse-display-variable to default to
not transform an empty host to "localhost" so we get a Unix domain connection
instead of a TCP socket.
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     ((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 cvs 1.10 (pixmap->mirror :initform (make-hash-table :test #'eq))
63     (mirror->pixmap :initform (make-hash-table :test #'eq))
64 mikemac 1.1 (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 rouanet 1.15 (defmethod port-lookup-mirror ((port port) (sheet mirrored-sheet-mixin))
83 mikemac 1.1 (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 rouanet 1.15 (defmethod port-register-mirror ((port port) (sheet mirrored-sheet-mixin) mirror)
89 mikemac 1.1 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
90     (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
91     nil)
92    
93 rouanet 1.15 (defmethod port-unregister-mirror ((port port) (sheet mirrored-sheet-mixin) mirror)
94 mikemac 1.1 (remhash sheet (slot-value port 'sheet->mirror))
95     (remhash mirror (slot-value port 'mirror->sheet))
96     nil)
97    
98 rouanet 1.15 (defmethod realize-mirror ((port port) (sheet mirrored-sheet-mixin))
99 mikemac 1.1 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
100    
101 rouanet 1.15 (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 mikemac 1.1
104 rouanet 1.16 (defmethod mirror-transformation ((port port) mirror)
105     (declare (ignore mirror))
106     (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
107    
108 mikemac 1.1 (defmethod port-properties ((port port) indicator)
109     (with-slots (properties) port
110     (getf properties indicator)))
111    
112     (defmethod (setf port-properties) (value (port port) indicator)
113     (with-slots (properties) port
114     (setf (getf properties indicator) value)))
115    
116     (defmethod get-next-event ((port port) &key wait-function timeout)
117     (declare (ignore wait-function timeout))
118     (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
119    
120     (defmethod process-next-event ((port port) &key wait-function timeout)
121     (let ((event (get-next-event port :wait-function wait-function :timeout timeout)))
122     (cond
123     ((null event) nil)
124     ((eq event :timeout) (values nil :timeout))
125     (t
126     (distribute-event port event)
127     t))))
128    
129     (defmethod distribute-event ((port port) event)
130     (cond
131     ((typep event 'keyboard-event)
132     (dispatch-event (or (port-keyboard-input-focus port)
133     (event-sheet event)) event))
134     ((typep event 'window-event)
135 cvs 1.4 ; (dispatch-event (window-event-mirrored-sheet event) event))
136     (dispatch-event (event-sheet event) event))
137 mikemac 1.1 ((typep event 'pointer-event)
138     (dispatch-event (event-sheet event) event))
139     ((typep event 'timer-event)
140     (error "Where do we send timer-events?"))
141     (t
142     (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
143    
144     (defun map-over-ports (function)
145     (mapc function *all-ports*))
146    
147     (defmethod restart-port ((port port))
148     (reset-watcher port :restart)
149     nil)
150    
151     (defmethod destroy-port ((port port))
152     (reset-watcher port :destroy)
153     (setf *all-ports* (remove port *all-ports*)))
154    
155     (defmethod add-watcher ((port port) watcher)
156     (declare (ignore watcher))
157     nil)
158    
159     (defmethod delete-watcher ((port port) watcher)
160     (declare (ignore watcher))
161     nil)
162    
163     (defmethod reset-watcher ((port port) how)
164     (declare (ignore how))
165     nil)
166    
167     (defmethod make-graft ((port port) &key (orientation :default) (units :device))
168     (let ((graft (make-instance 'graft
169     :port port :mirror nil
170     :orientation orientation :units units)))
171     (push graft (port-grafts port))
172     graft))
173    
174     (defmethod make-medium ((port port) sheet)
175 rouanet 1.16 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
176 mikemac 1.1
177 cvs 1.10 ;;; Pixmap
178    
179     (defmethod port-lookup-mirror ((port port) (pixmap pixmap))
180     (gethash pixmap (slot-value port 'pixmap->mirror)))
181    
182     (defmethod port-lookup-pixmap ((port port) mirror)
183     (gethash mirror (slot-value port 'mirror->pixmap)))
184    
185     (defmethod port-register-mirror ((port port) (pixmap pixmap) mirror)
186     (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
187     (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
188     nil)
189    
190     (defmethod port-unregister-mirror ((port port) (pixmap pixmap) mirror)
191     (remhash pixmap (slot-value port 'pixmap->mirror))
192     (remhash mirror (slot-value port 'mirror->pixmap))
193     nil)
194    
195     (defmethod realize-mirror ((port port) (pixmap mirrored-pixmap))
196     (declare (ignorable port pixmap))
197     (error "Don't know how to realize the mirror on a generic port"))
198    
199 rouanet 1.15 (defmethod destroy-mirror ((port port) (pixmap mirrored-pixmap))
200 cvs 1.10 (declare (ignorable port pixmap))
201 rouanet 1.15 (error "Don't know how to destroy the mirror on a generic port"))
202 cvs 1.10
203 mikemac 1.1 (defmethod port-allocate-pixmap ((port port) sheet width height)
204     (declare (ignore sheet width height))
205 cvs 1.10 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
206 mikemac 1.1
207     (defmethod port-deallocate-pixmap ((port port) pixmap)
208     (declare (ignore pixmap))
209 cvs 1.10 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))

  ViewVC Help
Powered by ViewVC 1.1.5