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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide annotations)
Thu Oct 4 19:26:59 2001 UTC (12 years, 6 months ago) by rouanet
Branch: MAIN
Changes since 1.16: +0 -10 lines
Rewrote the copy-{from,to}-pixmap and copy-area functions according to
the new spec.

The main difference is that the three functions now rely on
medium-copy-area, which is specialized on both a source an a destination
`drawable' and is in charge of the low-level stuff, such as
xlib:copy-area for clx-medium.  This leads to clearer and shorter code.

The copy to/from a stream is not implemended yet.
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 cvs 1.11 (host-name (if (zerop colon) "localhost" (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 strandh 1.14 (defmethod port-line-height ((port port) text-style)
178 mikemac 1.1 (declare (ignore text-style))
179     (error "LINE-HEIGHT fell thru to a generic PORT"))
180    
181 strandh 1.14 (defmethod port-character-width ((port port) text-style char)
182     (declare (ignore text-style char))
183     (error "PORT-CHARACTER-WIDTH fell thru to a generic PORT"))
184 mikemac 1.1
185 cvs 1.10 ;;; 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 rouanet 1.15 (defmethod destroy-mirror ((port port) (pixmap mirrored-pixmap))
208 cvs 1.10 (declare (ignorable port pixmap))
209 rouanet 1.15 (error "Don't know how to destroy the mirror on a generic port"))
210 cvs 1.10
211 mikemac 1.1 (defmethod port-allocate-pixmap ((port port) sheet width height)
212     (declare (ignore sheet width height))
213 cvs 1.10 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
214 mikemac 1.1
215     (defmethod port-deallocate-pixmap ((port port) pixmap)
216     (declare (ignore pixmap))
217 cvs 1.10 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))

  ViewVC Help
Powered by ViewVC 1.1.5