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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.125 - (hide annotations)
Wed Feb 7 12:44:16 2007 UTC (7 years, 2 months ago) by crhodes
Branch: MAIN
Changes since 1.124: +0 -6 lines
New click-to-focus policy for text-editor gadgets and panes, implemented
for the CLX, Null and gtkairo backends (but gtk_window_get_focus()
hand-inserted into gtkairo/ffi.lisp).

PORT-KEYBOARD-INPUT-FOCUS is now a trampoline to
PORT-FRAME-KEYBOARD-INPUT-FOCUS, a per-port function to set the keyboard
focus for a particular frame.  Not implemented for Beagle or OpenGL
backends.

Now Drei / Goatee gadgets don't have to do their own keyboard
focus handling on arm/disarm any more.  Various kludges sprinkled all
over the place to make this so.
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.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 gilbert 1.95 ;;; (c) copyright 2004 by
9     ;;; Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
10 mikemac 1.1
11     ;;; This library is free software; you can redistribute it and/or
12     ;;; modify it under the terms of the GNU Library General Public
13     ;;; License as published by the Free Software Foundation; either
14     ;;; version 2 of the License, or (at your option) any later version.
15     ;;;
16     ;;; This library is distributed in the hope that it will be useful,
17     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19     ;;; Library General Public License for more details.
20     ;;;
21     ;;; You should have received a copy of the GNU Library General Public
22     ;;; License along with this library; if not, write to the
23     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24     ;;; Boston, MA 02111-1307 USA.
25    
26 mikemac 1.60 (in-package :clim-internals)
27 mikemac 1.1
28 gilbert 1.33 ;; *application-frame* is in decls.lisp
29 mikemac 1.1 (defvar *default-frame-manager* nil)
30    
31 cvs 1.5 ;;; Frame-Manager class
32    
33 ahefner 1.122 ;; FIXME: The spec says the port must "conform to options".
34     ;; I've added a check that the ports match, but we've no
35     ;; protocol for testing the other options. -Hefner
36 cvs 1.5 (defun find-frame-manager (&rest options &key port &allow-other-keys)
37     (declare (special *frame-manager*))
38 ahefner 1.122 (if (and (boundp '*frame-manager*)
39     (or (null port)
40     (eql port (frame-manager-port *frame-manager*))))
41 cvs 1.5 *frame-manager*
42     (if (and *default-frame-manager*
43 ahefner 1.122 (frame-manager-p *default-frame-manager*)
44     (or (null port)
45     (eql port (frame-manager-port *default-frame-manager*))))
46 cvs 1.5 *default-frame-manager*
47 ahefner 1.122 (first (frame-managers (or port (apply #'find-port options)))))))
48 cvs 1.5
49     (defmacro with-frame-manager ((frame-manager) &body body)
50 adejneka 1.43 `(let ((*frame-manager* ,frame-manager))
51 cvs 1.5 (declare (special *frame-manager*))
52 adejneka 1.43 (locally ,@body)))
53    
54 moore 1.94 ;;; XXX These should force the redisplay of the menu bar. They don't
55     ;;; yet.
56    
57     (defmethod note-command-enabled (frame-manager frame command-name)
58     (declare (ignore frame-manager frame command-name))
59     nil)
60    
61     (defmethod note-command-disabled (frame-manager frame command-name)
62     (declare (ignore frame-manager frame command-name))
63     nil)
64    
65 mikemac 1.1 ;;; Application-Frame class
66 moore 1.38 ;;; XXX All these slots should move to a mixin or to standard-application-frame.
67     ;;; -- moore
68 mikemac 1.1
69 brian 1.54 ; extension
70     (defgeneric frame-schedule-timer-event (frame sheet delay token))
71 adejneka 1.13
72 hefner1 1.68 (defgeneric note-input-focus-changed (pane state)
73     (:documentation "Called when a pane receives or loses the keyboard
74     input focus. This is a McCLIM extension."))
75    
76 tmoore 1.114 (defmethod frame-geometry* ((frame application-frame))
77     "-> width height &optional top left"
78     (let ((pane (frame-top-level-sheet frame)))
79     (destructuring-bind (&key left top right bottom width height) (frame-geometry frame)
80     ;; Find width and height from looking at the respective options
81     ;; first, then at left/right and top/bottom and finally at what
82     ;; compose-space says.
83     (setf width (or width
84     (and left right (- right left))
85     (space-requirement-width (compose-space pane))))
86     (setf height (or height
87     (and top bottom (- bottom top))
88     (space-requirement-height (compose-space pane))))
89     ;; See if a position is wanted and return left, top.
90     (setf left (or left
91     (and right (- right width))))
92     (setf top (or top
93     (and bottom (- bottom height))))
94     (values width height left top))))
95    
96     (defclass standard-application-frame (application-frame
97     presentation-history-mixin)
98 moore 1.90 ((port :initform nil
99     :initarg :port
100     :accessor port)
101     (graft :initform nil
102     :initarg :graft
103     :accessor graft)
104     (name :initarg :name
105     :reader frame-name)
106     (pretty-name :initarg :pretty-name
107     :accessor frame-pretty-name)
108     (command-table :initarg :command-table
109     :initform nil
110     :accessor frame-command-table)
111     (named-panes :accessor frame-named-panes :initform nil)
112     (panes :initform nil :reader frame-panes
113     :documentation "The tree of panes in the current layout.")
114     (layouts :initform nil
115     :initarg :layouts
116     :reader frame-layouts)
117     (current-layout :initform nil
118     :initarg :current-layout
119     :accessor frame-current-layout)
120     (panes-for-layout :initform nil :accessor frame-panes-for-layout
121     :documentation "alist of names and panes (as returned by make-pane)")
122     (top-level-sheet :initform nil
123     :reader frame-top-level-sheet)
124     (menu-bar :initarg :menu-bar
125     :initform nil)
126     (state :initarg :state
127     :initform :disowned
128     :reader frame-state)
129     (manager :initform nil
130     :reader frame-manager
131     :accessor %frame-manager)
132     (properties :accessor %frame-properties
133     :initarg :properties
134     :initform nil)
135     (top-level :initform '(default-frame-top-level)
136     :initarg :top-level
137     :reader frame-top-level)
138     (top-level-lambda :initarg :top-level-lambda
139     :reader frame-top-level-lambda)
140     (hilited-presentation :initform nil
141     :initarg :hilited-presentation
142     :accessor frame-hilited-presentation)
143     (user-supplied-geometry :initform nil
144 gilbert 1.95 :initarg :user-supplied-geometry
145 tmoore 1.114 :reader frame-geometry
146 gilbert 1.95 :documentation "plist of defaulted :left, :top, :bottom, :right, :width and :height options.")
147 tmoore 1.111 (process :accessor frame-process :initform nil)
148 tmoore 1.114 (client-settings :accessor client-settings :initform nil)
149     (event-queue :initarg :frame-event-queue
150 hefner1 1.66 :initarg :input-buffer
151     :initform nil
152 moore 1.38 :accessor frame-event-queue
153     :documentation "The event queue that, by default, will be
154 moore 1.47 shared by all panes in the stream")
155     (documentation-state :accessor frame-documentation-state
156     :initform nil
157     :documentation "Used to keep of track of what
158 moore 1.89 needs to be rendered in the pointer documentation frame.")
159     (calling-frame :reader frame-calling-frame
160     :initarg :calling-frame
161     :initform nil
162     :documentation "The frame that is the parent of this
163 moore 1.94 frame, if any")
164     (disabled-commands :accessor disabled-commands
165 tmoore 1.114 :accessor frame-disabled-commands
166     :initarg :disabled-commands
167 moore 1.94 :initform nil
168     :documentation "A list of command names that have been
169 tmoore 1.114 disabled in this frame")
170     (documentation-record :accessor documentation-record
171     :initform nil
172     :documentation "updating output record for pointer
173     documentation produced by presentations.")))
174 moore 1.38
175     ;;; Support the :input-buffer initarg for compatibility with "real CLIM"
176    
177     (defmethod initialize-instance :after ((obj standard-application-frame)
178 moore 1.89 &key &allow-other-keys)
179     (when (and (frame-calling-frame obj)
180     (null (frame-event-queue obj)))
181     (setf (frame-event-queue obj)
182     (frame-event-queue (frame-calling-frame obj))))
183 hefner1 1.66 (unless (frame-event-queue obj)
184 hefner1 1.72 (setf (frame-event-queue obj)
185 hefner1 1.79 (make-instance 'port-event-queue))))
186 mikemac 1.1
187     (defmethod (setf frame-manager) (fm (frame application-frame))
188     (let ((old-manager (frame-manager frame)))
189 adejneka 1.46 (setf (%frame-manager frame) nil)
190 mikemac 1.1 (when old-manager
191     (disown-frame old-manager frame)
192     (setf (slot-value frame 'panes) nil)
193     (setf (slot-value frame 'layouts) nil))
194 adejneka 1.46 (setf (%frame-manager frame) fm)))
195 mikemac 1.1
196 moore 1.90 (define-condition frame-layout-changed (condition)
197     ((frame :initarg :frame :reader frame-layout-changed-frame)))
198    
199     (defmethod (setf frame-current-layout) :after (name (frame application-frame))
200 mikemac 1.1 (declare (ignore name))
201 ahefner 1.107 (when (frame-manager frame)
202     (generate-panes (frame-manager frame) frame)
203     (multiple-value-bind (w h) (frame-geometry* frame)
204     (layout-frame frame w h))
205     (signal 'frame-layout-changed :frame frame)))
206 mikemac 1.1
207     (defmethod generate-panes :before (fm (frame application-frame))
208     (declare (ignore fm))
209 moore 1.101 (when (and (frame-panes frame)
210     (eq (sheet-parent (frame-panes frame))
211     (frame-top-level-sheet frame)))
212 moore 1.90 (sheet-disown-child (frame-top-level-sheet frame) (frame-panes frame)))
213     (loop
214     for (nil . pane) in (frame-panes-for-layout frame)
215     for parent = (sheet-parent pane)
216     if parent
217     do (sheet-disown-child parent pane)))
218 mikemac 1.1
219     (defmethod generate-panes :after (fm (frame application-frame))
220     (declare (ignore fm))
221 moore 1.90 (sheet-adopt-child (frame-top-level-sheet frame) (frame-panes frame))
222     (unless (sheet-parent (frame-top-level-sheet frame))
223     (sheet-adopt-child (graft frame) (frame-top-level-sheet frame)))
224 gilbert 1.95 ;; Find the size of the new frame
225     (multiple-value-bind (w h x y) (frame-geometry* frame)
226 crhodes 1.119 (declare (ignore x y))
227 cvs 1.5 ;; automatically generates a window-configuation-event
228     ;; which then calls allocate-space
229 gilbert 1.39 ;;
230 crhodes 1.119 ;; Not any longer, we turn off CONFIGURE-NOTIFY events until the
231 gilbert 1.39 ;; window is mapped and do the space allocation now, so that all
232     ;; sheets will have their correct geometry at once. --GB
233 mikemac 1.1 (setf (sheet-region (frame-top-level-sheet frame))
234 gilbert 1.95 (make-bounding-rectangle 0 0 w h))
235     (allocate-space (frame-top-level-sheet frame) w h) ))
236 mikemac 1.1
237     (defmethod layout-frame ((frame application-frame) &optional width height)
238 moore 1.90 (let ((pane (frame-panes frame)))
239 ahefner 1.124 (when (and (or width height)
240     (not (and width height)))
241     (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
242 mikemac 1.1 (if (and (null width) (null height))
243 gilbert 1.95 (let ((space (compose-space pane))) ;I guess, this might be wrong. --GB 2004-06-01
244 mikemac 1.1 (setq width (space-requirement-width space))
245     (setq height (space-requirement-height space))))
246 gilbert 1.63 (let ((tpl-sheet (frame-top-level-sheet frame)))
247     (unless (and (= width (bounding-rectangle-width tpl-sheet))
248     (= height (bounding-rectangle-height tpl-sheet)))
249     (resize-sheet (frame-top-level-sheet frame) width height)))
250 mikemac 1.1 (allocate-space pane width height)))
251    
252 adejneka 1.13 (defun find-pane-if (predicate panes)
253     "Returns a pane satisfying PREDICATE in the forest growing from PANES"
254 moore 1.90 (map-over-sheets #'(lambda (p)
255     (when (funcall predicate p)
256     (return-from find-pane-if p)))
257     panes)
258     nil)
259 moore 1.27
260 adejneka 1.13 (defun find-pane-of-type (panes type)
261     (find-pane-if #'(lambda (pane) (typep pane type)) panes))
262 adejneka 1.40
263 moore 1.90 ;;; There are several ways to do this; this isn't particularly efficient, but
264     ;;; it shouldn't matter much. If it does, it might be better to map over the
265     ;;; panes in frame-named-panes looking for panes with parents.
266 adejneka 1.13 (defmethod frame-current-panes ((frame application-frame))
267 moore 1.90 (let ((panes nil)
268     (named-panes (frame-named-panes frame)))
269     (map-over-sheets #'(lambda (p)
270     (when (member p named-panes)
271     (push p panes)))
272     (frame-panes frame))
273     panes))
274 adejneka 1.13
275     (defmethod get-frame-pane ((frame application-frame) pane-name)
276 moore 1.90 (let ((pane (find-pane-named frame pane-name)))
277     (if (typep pane 'clim-stream-pane)
278     pane
279     nil)))
280 adejneka 1.13
281     (defmethod find-pane-named ((frame application-frame) pane-name)
282 moore 1.90 (find pane-name (frame-named-panes frame) :key #'pane-name))
283 adejneka 1.13
284 mikemac 1.1 (defmethod frame-standard-output ((frame application-frame))
285 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'application-pane)
286     (find-pane-of-type (frame-panes frame) 'interactor-pane)))
287 mikemac 1.1
288     (defmethod frame-standard-input ((frame application-frame))
289 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
290 mikemac 1.1 (frame-standard-output frame)))
291    
292     (defmethod frame-query-io ((frame application-frame))
293     (or (frame-standard-input frame)
294     (frame-standard-output frame)))
295    
296     (defmethod frame-error-output ((frame application-frame))
297     (frame-standard-output frame))
298    
299     (defvar *pointer-documentation-output* nil)
300    
301     (defmethod frame-pointer-documentation-output ((frame application-frame))
302 adejneka 1.13 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
303 mikemac 1.1
304 moore 1.93 #+nil
305 hefner1 1.70 (defmethod redisplay-frame-panes ((frame application-frame) &key force-p)
306     (map-over-sheets
307     (lambda (sheet)
308     (when (typep sheet 'pane)
309     (when (and (typep sheet 'clim-stream-pane)
310     (not (eq :no-clear (pane-redisplay-needed sheet))))
311     (window-clear sheet))
312     (redisplay-frame-pane frame sheet :force-p force-p)))
313     (frame-top-level-sheet frame)))
314    
315 moore 1.93 (defmethod redisplay-frame-panes ((frame application-frame) &key force-p)
316     (map-over-sheets (lambda (sheet)
317     (redisplay-frame-pane frame sheet :force-p force-p))
318     (frame-top-level-sheet frame)))
319    
320    
321 moore 1.82 (defmethod frame-replay (frame stream &optional region)
322     (declare (ignore frame))
323     (stream-replay stream region))
324    
325     (defmethod frame-properties ((frame application-frame) property)
326     (getf (%frame-properties frame) property))
327    
328     (defmethod (setf frame-properties) (value (frame application-frame) property)
329     (setf (getf (%frame-properties frame) property) value))
330    
331 mikemac 1.1 ;;; Command loop interface
332    
333 mikemac 1.22 (define-condition frame-exit (condition)
334 moore 1.26 ((frame :initarg :frame :reader %frame-exit-frame)))
335 mikemac 1.22
336 hefner1 1.66 ;; I make the assumption here that the contents of *application-frame* is
337     ;; the frame the top-level loop is running. With the introduction of
338     ;; window-stream frames that may be sharing the event queue with the main
339     ;; application frame, we need to discriminate between them here to avoid
340     ;; shutting down the application at the wrong time.
341     ;; ...
342     ;; A better way to do this would be to make the handler bound in
343     ;; run-frame-top-level check whether the frame signalled is the one
344     ;; it was invoked on.. -- Hefner
345    
346 mikemac 1.22 (defmethod frame-exit ((frame standard-application-frame))
347 hefner1 1.66 (if (eq *application-frame* frame)
348     (signal 'frame-exit :frame frame)
349     (disown-frame (frame-manager frame) frame)))
350 moore 1.26
351     (defmethod frame-exit-frame ((c frame-exit))
352     (%frame-exit-frame c))
353 mikemac 1.22
354 moore 1.59 (defmethod redisplay-frame-pane ((frame application-frame) pane &key force-p)
355     (declare (ignore pane force-p))
356     nil)
357    
358 rstrandh 1.109 (defgeneric medium-invoke-with-possible-double-buffering (frame pane medium continuation))
359    
360     (defmethod medium-invoke-with-possible-double-buffering (frame pane medium continuation)
361     (funcall continuation))
362    
363     (defgeneric invoke-with-possible-double-buffering (frame pane continuation))
364    
365     (defmethod invoke-with-possible-double-buffering (frame pane continuation)
366     (declare (ignore frame pane))
367     (funcall continuation))
368    
369     (defmethod invoke-with-possible-double-buffering (frame (pane sheet-with-medium-mixin) continuation)
370     (medium-invoke-with-possible-double-buffering frame pane (sheet-medium pane) continuation))
371    
372     (defmacro with-possible-double-buffering ((frame pane) &body body)
373     `(invoke-with-possible-double-buffering ,frame ,pane (lambda () ,@body)))
374    
375 moore 1.93 (defmethod redisplay-frame-pane :around ((frame application-frame) pane
376     &key force-p)
377 thenriksen 1.121 (let ((pane-object (if (typep pane 'pane)
378     pane
379     (find-pane-named frame pane))))
380     (multiple-value-bind (redisplayp clearp)
381     (pane-needs-redisplay pane-object)
382     (when force-p
383     (setq redisplayp (or redisplayp t)
384     clearp t))
385     (when redisplayp
386     (let ((hilited (frame-hilited-presentation frame)))
387     (when hilited
388     (highlight-presentation-1 (car hilited) (cdr hilited) :unhighlight)
389     (setf (frame-hilited-presentation frame) nil)))
390     (with-possible-double-buffering (frame pane-object)
391     (when clearp
392     (window-clear pane-object))
393     (call-next-method))
394     (unless (or (eq redisplayp :command-loop) (eq redisplayp :no-clear))
395     (setf (pane-needs-redisplay pane-object) nil))))))
396 moore 1.93
397 moore 1.90 (defmethod run-frame-top-level ((frame application-frame)
398     &key &allow-other-keys)
399 tmoore 1.111 (letf (((frame-process frame) (current-process)))
400     (handler-case
401     (funcall (frame-top-level-lambda frame) frame)
402     (frame-exit ()
403     nil))))
404    
405 mikemac 1.1
406 adejneka 1.44 (defmethod run-frame-top-level :around ((frame application-frame) &key)
407 mikemac 1.1 (let ((*application-frame* frame)
408     (*input-context* nil)
409     (*input-wait-test* nil)
410     (*input-wait-handler* nil)
411 moore 1.52 (*pointer-button-press-handler* nil)
412     (original-state (frame-state frame)))
413 mikemac 1.1 (declare (special *input-context* *input-wait-test* *input-wait-handler*
414     *pointer-button-press-handler*))
415 hefner1 1.74 (when (eq (frame-state frame) :disowned) ; Adopt frame into frame manager
416 moore 1.52 (adopt-frame (or (frame-manager frame) (find-frame-manager))
417     frame))
418     (unless (or (eq (frame-state frame) :enabled)
419     (eq (frame-state frame) :shrunk))
420     (enable-frame frame))
421 moore 1.90 (unwind-protect
422     (loop
423     for query-io = (frame-query-io frame)
424     for *default-frame-manager* = (frame-manager frame)
425     do (handler-case
426     (return (if query-io
427     (with-input-focus (query-io)
428     (call-next-method))
429     (call-next-method)))
430     (frame-layout-changed () nil)))
431     (let ((fm (frame-manager frame)))
432     (case original-state
433     (:disabled
434     (disable-frame frame))
435     (:disowned
436     (disown-frame fm frame)))))))
437 mikemac 1.1
438 moore 1.85 (defparameter +default-prompt-style+ (make-text-style :fix :italic :normal))
439    
440 mikemac 1.1 (defmethod default-frame-top-level
441     ((frame application-frame)
442     &key (command-parser 'command-line-command-parser)
443     (command-unparser 'command-line-command-unparser)
444     (partial-command-parser
445     'command-line-read-remaining-arguments-for-partial-command)
446 moore 1.35 (prompt "Command: "))
447 moore 1.93 ;; Give each pane a fresh start first time through.
448     (let ((first-time t))
449     (loop
450     ;; The variables are rebound each time through the loop because the
451     ;; values of frame-standard-input et al. might be changed by a command.
452     (let* ((*standard-input* (or (frame-standard-input frame)
453     *standard-input*))
454     (*standard-output* (or (frame-standard-output frame)
455     *standard-output*))
456     (query-io (frame-query-io frame))
457     (*query-io* (or query-io *query-io*))
458     (*pointer-documentation-output*
459     (frame-pointer-documentation-output frame))
460     ;; during development, don't alter *error-output*
461     ;; (*error-output* (frame-error-output frame))
462     (*command-parser* command-parser)
463     (*command-unparser* command-unparser)
464     (*partial-command-parser* partial-command-parser)
465     (interactorp (typep *query-io* 'interactor-pane)))
466     (restart-case
467     (progn
468     (redisplay-frame-panes frame :force-p first-time)
469     (setq first-time nil)
470     (if query-io
471 ahefner 1.120 ;; For frames with an interactor:
472 hefner1 1.100 (progn
473 ahefner 1.120 ;; Hide cursor, so we don't need to toggle it during
474     ;; command output.
475 moore 1.93 (setf (cursor-visibility (stream-text-cursor *query-io*))
476     nil)
477     (when (and prompt interactorp)
478     (with-text-style (*query-io* +default-prompt-style+)
479     (if (stringp prompt)
480     (write-string prompt *query-io*)
481     (funcall prompt *query-io* frame))
482     (finish-output *query-io*)))
483     (let ((command (read-frame-command frame
484     :stream *query-io*)))
485     (when interactorp
486     (fresh-line *query-io*))
487     (when command
488     (execute-frame-command frame command))
489     (when interactorp
490     (fresh-line *query-io*))))
491 ahefner 1.120 ;; Frames without an interactor:
492     (let ((command (read-frame-command frame :stream nil)))
493     (when command (execute-frame-command frame command)))))
494 moore 1.93 (abort ()
495     :report "Return to application command loop"
496     (if interactorp
497     (format *query-io* "~&Command aborted.~&")
498     (beep))))))))
499 moore 1.85
500 moore 1.87 (defmethod read-frame-command :around ((frame application-frame)
501 ahefner 1.120 &key (stream *standard-input*))
502 moore 1.64 (with-input-context ('menu-item)
503 moore 1.92 (object)
504     (call-next-method)
505 moore 1.64 (menu-item
506     (let ((command (command-menu-item-value object)))
507 moore 1.92 (unless (listp command)
508 hefner1 1.100 (setq command (list command)))
509 moore 1.92 (if (and (typep stream 'interactor-pane)
510     (member *unsupplied-argument-marker* command :test #'eq))
511     (command-line-read-remaining-arguments-for-partial-command
512     (frame-command-table frame) stream command 0)
513     command)))))
514 moore 1.64
515 moore 1.87 (defmethod read-frame-command ((frame application-frame)
516     &key (stream *standard-input*))
517 ahefner 1.107 ;; The following is the correct interpretation according to the spec.
518     ;; I think it is terribly counterintuitive and want to look into
519     ;; what existing CLIMs do before giving in to it.
520     ;; If we do things as the spec says, command accelerators will
521     ;; appear to not work, confusing new users.
522     #+NIL (read-command (frame-command-table frame) :use-keystrokes nil :stream stream)
523 ahefner 1.120 (if stream
524     (read-command (frame-command-table frame) :use-keystrokes t :stream stream)
525     (simple-event-loop frame)))
526 mikemac 1.1
527 tmoore 1.118 (define-event-class execute-command-event (window-manager-event)
528 gbaumann 1.110 ((sheet :initarg :sheet :reader event-sheet)
529     (command :initarg :command :reader execute-command-event-command)))
530    
531 mikemac 1.1 (defmethod execute-frame-command ((frame application-frame) command)
532 gbaumann 1.110 ;; ### FIXME: I'd like a different method than checking for
533     ;; *application-frame* to decide, which process processes which
534     ;; frames command loop. Perhaps looking ath the process slot?
535     ;; --GB 2005-11-28
536     (cond ((eq *application-frame* frame)
537     (apply (command-name command) (command-arguments command)))
538     (t
539     (let ((eq (sheet-event-queue (frame-top-level-sheet frame))))
540     (event-queue-append eq (make-instance 'execute-command-event
541     :sheet frame
542     :command command))))))
543    
544     (defmethod handle-event ((frame application-frame) (event execute-command-event))
545     (execute-frame-command frame (execute-command-event-command event)))
546 moore 1.94
547     (defmethod command-enabled (command-name (frame standard-application-frame))
548     (and (command-accessible-in-command-table-p command-name
549     (frame-command-table frame))
550     (not (member command-name (disabled-commands frame)))))
551    
552     (defmethod (setf command-enabled)
553     (enabled command-name (frame standard-application-frame))
554     (unless (command-accessible-in-command-table-p command-name
555     (frame-command-table frame))
556     (return-from command-enabled nil))
557     (with-accessors ((disabled-commands disabled-commands))
558     frame
559     (if enabled
560     (progn
561     (setf disabled-commands (delete command-name disabled-commands))
562     (note-command-enabled (frame-manager frame)
563     frame
564     command-name)
565     enabled)
566     (progn
567     (pushnew command-name disabled-commands)
568     (note-command-disabled (frame-manager frame)
569     frame
570     command-name)
571     nil))))
572    
573 moore 1.38 (defmethod make-pane-1 :around (fm (frame standard-application-frame) type
574     &rest args
575 moore 1.51 &key (input-buffer nil input-buffer-p)
576 moore 1.90 (name nil namep)
577 moore 1.51 &allow-other-keys)
578 moore 1.90 (declare (ignore name input-buffer))
579 moore 1.38 "Default input-buffer to the frame event queue."
580 moore 1.90 (let ((pane (if input-buffer-p
581     (call-next-method)
582     (apply #'call-next-method fm frame type
583     :input-buffer (frame-event-queue frame)
584     args))))
585     (when namep
586     (push pane (frame-named-panes frame)))
587 mikemac 1.91 pane))
588 mikemac 1.1
589     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
590     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
591     (setf (frame-manager frame) fm)
592 moore 1.52 (setf (port frame) (frame-manager-port fm))
593     (setf (graft frame) (find-graft :port (port frame)))
594 mikemac 1.1 (let* ((*application-frame* frame)
595 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
596 moore 1.52 :name 'top-level-sheet
597     ;; enabling should be left to enable-frame
598 hefner1 1.79 :enabled-p nil))
599 hefner1 1.80 #+clim-mp (event-queue (sheet-event-queue t-l-s)))
600 mikemac 1.1 (setf (slot-value frame 'top-level-sheet) t-l-s)
601 moore 1.52 (generate-panes fm frame)
602 ahefner 1.124 (setf (slot-value frame 'state) :disabled)
603 hefner1 1.80 #+clim-mp
604 hefner1 1.79 (when (typep event-queue 'port-event-queue)
605     (setf (event-queue-port event-queue)
606     (frame-manager-port fm)))
607 moore 1.52 frame))
608 brian 1.28
609 mikemac 1.1 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
610 hefner1 1.84 #+CLIM-MP
611 hefner1 1.79 (let* ((t-l-s (frame-top-level-sheet frame))
612     (queue (sheet-event-queue t-l-s)))
613     (when (typep queue 'port-event-queue)
614     (setf (event-queue-port queue) nil)))
615 mikemac 1.1 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
616     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
617 moore 1.52 (setf (%frame-manager frame) nil)
618     (setf (slot-value frame 'state) :disowned)
619 hefner1 1.79 (port-force-output (frame-manager-port fm))
620 moore 1.52 frame)
621    
622     (defmethod enable-frame ((frame application-frame))
623     (setf (sheet-enabled-p (frame-top-level-sheet frame)) t)
624     (setf (slot-value frame 'state) :enabled)
625     (note-frame-enabled (frame-manager frame) frame))
626    
627     (defmethod disable-frame ((frame application-frame))
628     (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil)
629     (setf (slot-value frame 'state) :disabled)
630     (note-frame-disabled (frame-manager frame) frame))
631    
632 tmoore 1.111 (defmethod destroy-frame ((frame application-frame))
633     (when (eq (frame-state frame) :enabled)
634     (disable-frame frame))
635     (disown-frame (frame-manager frame) frame))
636    
637 tmoore 1.113 (defmethod raise-frame ((frame application-frame))
638     (raise-sheet (frame-top-level-sheet frame)))
639    
640     (defmethod bury-frame ((frame application-frame))
641     (bury-sheet (frame-top-level-sheet frame)))
642    
643 moore 1.52 (defmethod note-frame-enabled ((fm frame-manager) frame)
644     (declare (ignore frame))
645     t)
646    
647     (defmethod note-frame-disabled ((fm frame-manager) frame)
648 moore 1.75 (declare (ignore frame))
649 moore 1.52 t)
650 mikemac 1.1
651 tmoore 1.111 (defun map-over-frames (function &key port frame-manager)
652     (cond (frame-manager
653     (mapc function (frame-manager-frames frame-manager)))
654     (port
655     (loop for manager in (frame-managers port)
656     do (map-over-frames function :frame-manager manager)))
657     (t (loop for p in *all-ports*
658     do (map-over-frames function :port p)))))
659    
660 cvs 1.8 (defvar *pane-realizer* nil)
661    
662 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
663 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
664     (*application-frame* ,frame))
665 adejneka 1.45 (locally
666     ,@body)))
667 mikemac 1.1
668 brian 1.28 ; The menu-bar code in the following two functions is incorrect.
669     ; it needs to be moved to somewhere after the backend, since
670     ; it depends on the backend chosen.
671     ;
672     ; This hack slaps a menu-bar into the start of the application-frame,
673     ; in such a way that it is hard to find.
674     ;
675     ; FIXME
676     (defun make-single-pane-generate-panes-form (class-name menu-bar pane)
677 moore 1.90 `(progn
678     (defmethod generate-panes ((fm frame-manager) (frame ,class-name))
679     ;; v-- hey, how can this be?
680     (with-look-and-feel-realization (fm frame)
681     (let ((pane ,(cond
682     ((eq menu-bar t)
683     `(vertically () (clim-internals::make-menu-bar
684 brian 1.28 ',class-name)
685 moore 1.90 ,pane))
686     ((consp menu-bar)
687     `(vertically () (clim-internals::make-menu-bar
688 brian 1.28 (make-command-table nil
689 moore 1.90 :menu ',menu-bar))
690     ,pane))
691     (menu-bar
692     `(vertically () (clim-internals::make-menu-bar
693     ',menu-bar)
694     ,pane))
695     ;; The form below is unreachable with (listp
696     ;; menu-bar) instead of (consp menu-bar) above
697     ;; --GB
698     (t pane))))
699     (setf (slot-value frame 'panes) pane))))
700     (defmethod frame-all-layouts ((frame ,class-name))
701     nil)))
702    
703     (defun find-pane-for-layout (name frame)
704     (cdr (assoc name (frame-panes-for-layout frame) :test #'eq)))
705    
706     (defun save-pane-for-layout (name pane frame)
707     (push (cons name pane) (frame-panes-for-layout frame))
708     pane)
709    
710 hefner1 1.96 (defun coerce-pane-name (pane name)
711 crhodes 1.123 (when pane
712 hefner1 1.96 (setf (slot-value pane 'name) name)
713     (push pane (frame-named-panes (pane-frame pane))))
714     pane)
715    
716     (defun do-pane-creation-form (name form)
717 moore 1.90 (cond
718     ((and (= (length form) 1)
719     (listp (first form)))
720 hefner1 1.96 `(coerce-pane-name ,(first form) ',name))
721 moore 1.90 ((keywordp (first form))
722     (let ((maker (intern (concatenate 'string
723     (symbol-name '#:make-clim-)
724     (symbol-name (first form))
725     (symbol-name '#:-pane))
726     :clim)))
727     (if (fboundp maker)
728     `(,maker :name ',name ,@(cdr form))
729     `(make-pane ',(first form)
730     :name ',name ,@(cdr form)))))
731     (t `(make-pane ',(first form) :name ',name ,@(cdr form)))))
732 mikemac 1.1
733 moore 1.47 (defun make-panes-generate-panes-form (class-name menu-bar panes layouts
734     pointer-documentation)
735     (when pointer-documentation
736     (setf panes (append panes
737     '((%pointer-documentation%
738     pointer-documentation-pane)))))
739 moore 1.90 `(progn
740     (defmethod generate-panes ((fm frame-manager) (frame ,class-name))
741     (let ((*application-frame* frame))
742     (with-look-and-feel-realization (fm frame)
743     (let ,(loop
744     for (name . form) in panes
745     collect `(,name (or (find-pane-for-layout ',name frame)
746     (save-pane-for-layout
747     ',name
748     ,(do-pane-creation-form name form)
749     frame))))
750     ;; [BTS] added this, but is not sure that this is correct for
751     ;; adding a menu-bar transparently, should also only be done
752     ;; where the exterior window system does not support menus
753     ,(if (or menu-bar pointer-documentation)
754     `(setf (slot-value frame 'panes)
755     (ecase (frame-current-layout frame)
756     ,@(mapcar (lambda (layout)
757     `(,(first layout)
758     (vertically ()
759     ,@(cond
760     ((eq menu-bar t)
761     `((clim-internals::make-menu-bar
762     ',class-name)))
763     ((consp menu-bar)
764     `((clim-internals::make-menu-bar
765     (make-command-table
766     nil
767     :menu ',menu-bar))))
768     (menu-bar
769     `((clim-internals::make-menu-bar
770     ',menu-bar)))
771     (t nil))
772     ,@(rest layout)
773     ,@(when pointer-documentation
774     '(%pointer-documentation%)))))
775     layouts)))
776     `(setf (slot-value frame 'panes)
777     (ecase (frame-current-layout frame)
778     ,@layouts)))))))
779     (defmethod frame-all-layouts ((frame ,class-name))
780     ',(mapcar #'car layouts))))
781 mikemac 1.1
782     (defmacro define-application-frame (name superclasses slots &rest options)
783     (if (null superclasses)
784     (setq superclasses '(standard-application-frame)))
785     (let ((pane nil)
786     (panes nil)
787     (layouts nil)
788     (current-layout nil)
789 mikemac 1.23 (command-table (list name))
790 mikemac 1.1 (menu-bar t)
791     (disabled-commands nil)
792     (command-definer t)
793     (top-level '(default-frame-top-level))
794 hefner1 1.86 (others nil)
795 mikemac 1.69 (pointer-documentation nil)
796 moore 1.87 (geometry nil)
797 ahefner 1.124 (user-default-initargs nil)
798 moore 1.87 (frame-arg (gensym "FRAME-ARG")))
799 mikemac 1.1 (loop for (prop . values) in options
800     do (case prop
801     (:pane (setq pane (first values)))
802     (:panes (setq panes values))
803     (:layouts (setq layouts values))
804     (:command-table (setq command-table (first values)))
805 brian 1.28 (:menu-bar (setq menu-bar (if (listp values)
806     (first values)
807     values)))
808 mikemac 1.1 (:disabled-commands (setq disabled-commands values))
809     (:command-definer (setq command-definer (first values)))
810     (:top-level (setq top-level (first values)))
811 moore 1.47 (:pointer-documentation (setq pointer-documentation (car values)))
812 mikemac 1.69 (:geometry (setq geometry values))
813 ahefner 1.124 (:default-initargs (setq user-default-initargs values))
814 mikemac 1.1 (t (push (cons prop values) others))))
815 hefner1 1.86 (when (eq command-definer t)
816     (setf command-definer
817     (intern (concatenate 'string
818     (symbol-name '#:define-)
819     (symbol-name name)
820     (symbol-name '#:-command)))))
821 mikemac 1.1 (if (or (and pane panes)
822     (and pane layouts))
823     (error ":pane cannot be specified along with either :panes or :layouts"))
824     (if pane
825     (setq panes (list 'single-pane pane)
826 moore 1.17 layouts `((:default ,(car pane)))))
827 mikemac 1.1 (setq current-layout (first (first layouts)))
828     `(progn
829 gilbert 1.95 (defclass ,name ,superclasses
830     ,slots
831     (:default-initargs
832     :name ',name
833     :pretty-name ,(string-capitalize name)
834     :command-table (find-command-table ',(first command-table))
835     :disabled-commands ',disabled-commands
836     :menu-bar ',menu-bar
837     :current-layout ',current-layout
838     :layouts ',layouts
839     :top-level (list ',(car top-level) ,@(cdr top-level))
840     :top-level-lambda (lambda (,frame-arg)
841     (,(car top-level) ,frame-arg
842 ahefner 1.124 ,@(cdr top-level)))
843     ,@user-default-initargs)
844 gilbert 1.95 ,@others)
845     ;; We alway set the frame class default geometry, so that the
846     ;; user can undo the effect of a specified :geometry option.
847     ;; --GB 2004-06-01
848     (setf (get ',name 'application-frame-geometry) ',geometry)
849     ,(if pane
850     (make-single-pane-generate-panes-form name menu-bar pane)
851     (make-panes-generate-panes-form name menu-bar panes layouts
852     pointer-documentation))
853     ,@(if command-table
854     `((define-command-table ,@command-table)))
855     ,@(if command-definer
856 ahefner 1.107 `((defmacro ,command-definer (name-and-options arguments &rest body)
857 gilbert 1.95 (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
858     (options (if (listp name-and-options) (cdr name-and-options) nil))
859     (command-table ',(first command-table)))
860 ahefner 1.107 `(define-command (,name :command-table ,command-table ,@options) ,arguments ,@body))))))))
861 gilbert 1.95
862     (defun get-application-frame-class-geometry (name indicator)
863     (getf (get name 'application-frame-geometry) indicator nil))
864 mikemac 1.69
865 mikemac 1.1 (defun make-application-frame (frame-name
866     &rest options
867 moore 1.52 &key (pretty-name
868     (string-capitalize frame-name))
869     (frame-manager nil frame-manager-p)
870     enable
871     (state nil state-supplied-p)
872 gilbert 1.95 (left (get-application-frame-class-geometry frame-name :left))
873     (top (get-application-frame-class-geometry frame-name :top))
874     (right (get-application-frame-class-geometry frame-name :right))
875     (bottom (get-application-frame-class-geometry frame-name :bottom))
876     (width (get-application-frame-class-geometry frame-name :width))
877     (height (get-application-frame-class-geometry frame-name :height))
878 moore 1.52 save-under (frame-class frame-name)
879 mikemac 1.1 &allow-other-keys)
880 mikemac 1.69 (declare (ignore save-under))
881 moore 1.52 (with-keywords-removed (options (:pretty-name :frame-manager :enable :state
882     :left :top :right :bottom :width :height
883 moore 1.53 :save-under :frame-class))
884 moore 1.52 (let ((frame (apply #'make-instance frame-class
885 mikemac 1.69 :name frame-name
886     :pretty-name pretty-name
887 gilbert 1.95 :user-supplied-geometry
888     (list :left left :top top
889     :right right :bottom bottom
890     :width width :height height)
891 mikemac 1.69 options)))
892 moore 1.52 (when frame-manager-p
893     (adopt-frame frame-manager frame))
894     (cond ((or enable (eq state :enabled))
895     (enable-frame frame))
896     ((and (eq state :disowned)
897     (not (eq (frame-state frame) :disowned)))
898     (disown-frame (frame-manager frame) frame))
899     (state-supplied-p
900     (warn ":state ~S not supported yet." state)))
901     frame)))
902 cvs 1.4
903 tmoore 1.111 ;;; From Franz Users Guide
904    
905     (defun find-application-frame (frame-name &rest initargs
906     &key (create t) (activate t)
907     (own-process *multiprocessing-p*) port
908     frame-manager frame-class
909     &allow-other-keys)
910 tmoore 1.112 (declare (ignorable frame-class))
911 tmoore 1.111 (let ((frame (unless (eq create :force)
912     (block
913     found-frame
914     (map-over-frames
915     #'(lambda (frame)
916     (when (eq (frame-name frame) frame-name)
917     (return-from found-frame frame)))
918     :port port
919     :frame-manager frame-manager)))))
920     (unless (or frame create)
921     (return-from find-application-frame nil))
922     (unless frame
923     (with-keywords-removed (initargs (:create :activate :own-process))
924     (setq frame (apply #'make-application-frame frame-name initargs))))
925     (when (and frame activate)
926     (cond ((frame-process frame)
927 tmoore 1.113 (raise-frame frame))
928 tmoore 1.111 (own-process
929     (clim-sys:make-process #'(lambda ()
930     (run-frame-top-level frame))
931     :name (format nil "~A" frame-name)))
932     (t (run-frame-top-level frame))))
933     frame))
934    
935    
936    
937 cvs 1.7 ;;; Menu frame class
938    
939     (defclass menu-frame ()
940     ((left :initform 0 :initarg :left)
941     (top :initform 0 :initarg :top)
942 hefner1 1.103 (min-width :initform nil :initarg :min-width)
943 cvs 1.7 (top-level-sheet :initform nil :reader frame-top-level-sheet)
944 moore 1.90 (panes :reader frame-panes :initarg :panes)
945 cvs 1.7 (graft :initform nil :accessor graft)
946     (manager :initform nil :accessor frame-manager)))
947 adejneka 1.46
948 ahefner 1.124 (defclass menu-unmanaged-top-level-sheet-pane (unmanaged-top-level-sheet-pane)
949     ())
950    
951 cvs 1.7 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
952     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
953 adejneka 1.46 (setf (frame-manager frame) fm)
954 brian 1.54 (let* ((t-l-s (make-pane-1 fm *application-frame*
955 ahefner 1.124 'menu-unmanaged-top-level-sheet-pane
956 cvs 1.7 :name 'top-level-sheet)))
957     (setf (slot-value frame 'top-level-sheet) t-l-s)
958 moore 1.90 (sheet-adopt-child t-l-s (frame-panes frame))
959 cvs 1.7 (let ((graft (find-graft :port (frame-manager-port fm))))
960     (sheet-adopt-child graft t-l-s)
961     (setf (graft frame) graft))
962 hefner1 1.103 (let ((pre-space (compose-space t-l-s))
963     (frame-min-width (slot-value frame 'min-width)))
964     (multiple-value-bind (width min-width max-width height min-height max-height)
965     (space-requirement-components pre-space)
966     (flet ((foomax (x y) (max (or x 1) (or y 1))))
967     (let ((space (make-space-requirement :min-width (foomax frame-min-width min-width)
968     :width (foomax frame-min-width width)
969     :max-width (foomax frame-min-width max-width)
970     :min-height min-height
971     :height height
972     :max-height max-height)))
973     (allocate-space (frame-panes frame)
974     (space-requirement-width space)
975     (space-requirement-height space))
976     (setf (sheet-region t-l-s)
977     (make-bounding-rectangle 0 0
978     (space-requirement-width space)
979     (space-requirement-height space))))
980     (setf (sheet-transformation t-l-s)
981     (make-translation-transformation (slot-value frame 'left)
982     (slot-value frame 'top))))))))
983 cvs 1.7
984     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
985     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
986     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
987     (setf (frame-manager frame) nil))
988    
989 hefner1 1.103 (defun make-menu-frame (pane &key (left 0) (top 0) (min-width 1))
990     (make-instance 'menu-frame :panes pane :left left :top top :min-width min-width))
991 moore 1.18
992     ;;; Frames and presentations
993 moore 1.88 (defmethod frame-maintain-presentation-histories
994     ((frame standard-application-frame))
995     (if (find-pane-of-type (frame-panes frame) 'interactor-pane)
996     t
997     nil))
998 moore 1.18
999     (defmethod frame-find-innermost-applicable-presentation
1000     ((frame standard-application-frame) input-context stream x y
1001     &key event)
1002     (find-innermost-applicable-presentation input-context stream
1003     x y
1004     :frame frame :event event))
1005    
1006 adejneka 1.41 (defmethod frame-input-context-button-press-handler
1007 moore 1.18 ((frame standard-application-frame)
1008     (stream output-recording-stream)
1009     button-press-event)
1010     (let ((presentation (find-innermost-applicable-presentation
1011     *input-context*
1012     stream
1013     (pointer-event-x button-press-event)
1014     (pointer-event-y button-press-event)
1015 moore 1.37 :frame frame
1016     :event button-press-event)))
1017 moore 1.18 (when presentation
1018     (throw-highlighted-presentation presentation
1019     *input-context*
1020     button-press-event))))
1021    
1022     (defmethod frame-input-context-button-press-handler
1023     ((frame standard-application-frame) stream button-press-event)
1024 mikemac 1.36 (declare (ignore stream button-press-event))
1025 moore 1.27 nil)
1026 moore 1.18
1027 moore 1.47 (defgeneric frame-update-pointer-documentation
1028     (frame input-context stream event))
1029    
1030     (defconstant +button-documentation+ '((#.+pointer-left-button+ "L")
1031     (#.+pointer-middle-button+ "M")
1032 hefner1 1.96 (#.+pointer-right-button+ "R")
1033     (#.+pointer-wheel-up+ "WheelUp")
1034     (#.+pointer-wheel-down+ "WheelDown")))
1035 moore 1.47
1036 moore 1.48 (defconstant +modifier-documentation+
1037     '((#.+shift-key+ "sh" "Shift")
1038     (#.+control-key+ "c" "Control")
1039     (#.+meta-key+ "m" "Meta")
1040     (#.+super-key+ "s" "Super")
1041     (#.+hyper-key+ "h" "Hyper")))
1042    
1043     ;;; Give a coherent order to sets of modifier combinations. Multi-key combos
1044     ;;; come after single keys.
1045    
1046     (defun cmp-modifiers (a b)
1047     (let ((cnt-a (logcount a))
1048     (cnt-b (logcount b)))
1049     (cond ((eql cnt-a cnt-b)
1050     (< a b))
1051     (t (< cnt-a cnt-b)))))
1052    
1053     (defun print-modifiers (stream modifiers style)
1054 moore 1.49 (if (zerop modifiers)
1055     (when (eq style :long)
1056     (write-string "<nothing>" stream))
1057     (loop with trailing = nil
1058     for (bit short long) in +modifier-documentation+
1059     when (logtest bit modifiers)
1060     do (progn
1061     (format stream "~:[~;-~]~A" trailing (if (eq style :short)
1062     short
1063     long))
1064     (setq trailing t)))))
1065 moore 1.48
1066 tmoore 1.114 ;;; XXX Warning: Changing rapidly!
1067     ;;;
1068 moore 1.48 ;;; We don't actually want to print out the translator documentation and redraw
1069     ;;; the pointer documentation window on every motion event. So, we compute a
1070     ;;; state object (basically modifier state and a list of the applicable
1071     ;;; presentation, translator and input context on each mouse button),
1072     ;;; compare it to the previous state object, and only write out documentation
1073     ;;; if they are different. I suppose it's possible that this state object
1074     ;;; doesn't capture all possible documentation changes -- the doc generator is
1075     ;;; a function, after all -- but that's just tough.
1076     ;;;
1077     ;;; It would be nice to evolve this into a protocol so that elements other than
1078     ;;; presentations -- menu choices, for example -- could influence pointer
1079     ;;; documentation window.
1080    
1081 moore 1.50 (defgeneric frame-compute-pointer-documentation-state
1082     (frame input-context stream event)
1083     (:documentation
1084     "Compute a state object that will be used to generate pointer documentation."))
1085    
1086     (defmethod frame-compute-pointer-documentation-state
1087     ((frame standard-application-frame) input-context stream event)
1088     (let* ((current-modifier (event-modifier-state event))
1089     (x (device-event-x event))
1090     (y (device-event-y event))
1091     (new-translators
1092     (loop for (button) in +button-documentation+
1093     for context-list = (multiple-value-list
1094     (find-innermost-presentation-context
1095     input-context
1096     stream
1097     x y
1098     :modifier-state current-modifier
1099     :button button))
1100     when (car context-list)
1101     collect (cons button context-list))))
1102     (list current-modifier new-translators)))
1103    
1104     (defgeneric frame-compare-pointer-documentation-state
1105     (frame input-context stream old-state new-state))
1106    
1107     (defmethod frame-compare-pointer-documentation-state
1108     ((frame standard-application-frame) input-context stream
1109     old-state new-state)
1110 moore 1.78 (declare (ignore input-context stream))
1111 moore 1.50 (equal old-state new-state))
1112    
1113     (defgeneric frame-print-pointer-documentation
1114     (frame input-context stream state event))
1115    
1116     (defmethod frame-print-pointer-documentation
1117     ((frame standard-application-frame) input-context stream state event)
1118     (unless state
1119     (return-from frame-print-pointer-documentation nil))
1120     (destructuring-bind (current-modifier new-translators)
1121     state
1122     (let ((x (device-event-x event))
1123     (y (device-event-y event))
1124     (pstream *pointer-documentation-output*))
1125     (loop for (button presentation translator context)
1126     in new-translators
1127     for name = (cadr (assoc button +button-documentation+))
1128     for first-one = t then nil
1129     do (progn
1130     (unless first-one
1131     (write-string "; " pstream))
1132     (unless (zerop current-modifier)
1133     (print-modifiers pstream current-modifier :short)
1134     (write-string "-" pstream))
1135     (format pstream "~A: " name)
1136     (document-presentation-translator translator
1137     presentation
1138     (input-context-type context)
1139     *application-frame*
1140     event
1141     stream
1142     x y
1143     :stream pstream
1144     :documentation-type
1145     :pointer))
1146     finally (when new-translators
1147     (write-char #\. pstream)))
1148     ;; Wasteful to do this after doing
1149     ;; find-innermost-presentation-context above... look at doing this
1150     ;; first and then doing the innermost test.
1151     (let ((all-translators (find-applicable-translators
1152     (stream-output-history stream)
1153     input-context
1154     *application-frame*
1155     stream
1156     x y
1157     :for-menu t))
1158     (other-modifiers nil))
1159     (loop for (translator) in all-translators
1160     for gesture = (gesture translator)
1161     unless (eq gesture t)
1162     do (loop for (name type modifier) in gesture
1163     unless (eql modifier current-modifier)
1164     do (pushnew modifier other-modifiers)))
1165     (when other-modifiers
1166     (setf other-modifiers (sort other-modifiers #'cmp-modifiers))
1167     (terpri pstream)
1168     (write-string "To see other commands, press " pstream)
1169     (loop for modifier-tail on other-modifiers
1170     for (modifier) = modifier-tail
1171     for count from 0
1172     do (progn
1173     (if (null (cdr modifier-tail))
1174     (progn
1175     (when (> count 1)
1176     (write-char #\, pstream))
1177     (when (> count 0)
1178     (write-string " or " pstream)))
1179     (when (> count 0)
1180     (write-string ", " pstream)))
1181     (print-modifiers pstream modifier :long)))
1182     (write-char #\. pstream))))))
1183    
1184 moore 1.47 (defmethod frame-update-pointer-documentation
1185     ((frame standard-application-frame) input-context stream event)
1186     (when *pointer-documentation-output*
1187 tmoore 1.114 (with-accessors ((frame-documentation-state frame-documentation-state)
1188     (documentation-record documentation-record))
1189     frame
1190     (setf frame-documentation-state
1191     (frame-compute-pointer-documentation-state frame
1192     input-context
1193     stream
1194     event))
1195     ;; These ugly special bindings work around the fact that the outer
1196     ;; updating-output form closes over its body and allow the inner
1197     ;; form to see the correct, current values of those variables.
1198     (let ((%input-context% input-context)
1199     (%stream% stream)
1200     (%doc-state% frame-documentation-state)
1201     (%event% event))
1202     (declare (special %input-context% %stream% %doc-state% %event&))
1203     (if (and documentation-record
1204     (output-record-parent documentation-record))
1205     (redisplay documentation-record *pointer-documentation-output*)
1206     (progn
1207     (window-clear *pointer-documentation-output*)
1208     (setf documentation-record
1209     (updating-output (*pointer-documentation-output*)
1210     (updating-output (*pointer-documentation-output*
1211     :cache-value %doc-state%
1212     :cache-test
1213     #'equal)
1214     (frame-print-pointer-documentation frame
1215     %input-context%
1216     %stream%
1217     %doc-state%
1218     %event%))))))))))
1219    
1220     #-(and)
1221     (defmethod frame-update-pointer-documentation
1222     ((frame standard-application-frame) input-context stream event)
1223     (when *pointer-documentation-output*
1224 moore 1.47 (with-accessors ((frame-documentation-state frame-documentation-state))
1225     frame
1226 moore 1.50 (let ((new-state (frame-compute-pointer-documentation-state frame
1227     input-context
1228     stream
1229     event)))
1230     (unless (frame-compare-pointer-documentation-state
1231     frame
1232     input-context
1233     stream
1234     frame-documentation-state
1235     new-state)
1236     (window-clear *pointer-documentation-output*)
1237     (frame-print-pointer-documentation frame
1238     input-context
1239     stream
1240     new-state
1241     event)
1242     (setq frame-documentation-state new-state))))))
1243 moore 1.47
1244 moore 1.78 ;;; A hook for applications to draw random strings in the
1245     ;;; *pointer-documentation-output* without screwing up the real pointer
1246     ;;; documentation too badly.
1247    
1248     (defgeneric frame-display-pointer-documentation-string
1249     (frame documentation-stream string))
1250    
1251     (defmethod frame-display-pointer-documentation-string
1252     ((frame standard-application-frame) documentation-stream string)
1253     (when *pointer-documentation-output*
1254     (with-accessors ((frame-documentation-state frame-documentation-state))
1255     frame
1256     (unless (frame-compare-pointer-documentation-state
1257     frame nil documentation-stream frame-documentation-state string)
1258     (window-clear documentation-stream)
1259     (write-string string documentation-stream)
1260     (setq frame-documentation-state string)))))
1261    
1262 moore 1.18 (defmethod frame-input-context-track-pointer
1263     ((frame standard-application-frame)
1264     input-context
1265     (stream output-recording-stream) event)
1266     (declare (ignore input-context event))
1267     nil)
1268    
1269     (defmethod frame-input-context-track-pointer
1270     ((frame standard-application-frame) input-context stream event)
1271 mikemac 1.36 (declare (ignore input-context stream event))
1272 moore 1.27 nil)
1273 moore 1.18
1274 moore 1.98 (defun frame-highlight-at-position (frame stream x y modifier input-context
1275     &key (highlight t))
1276     "Given stream x,y; key modifiers; input-context, find the applicable
1277     presentation and maybe highlight it."
1278 moore 1.47 (flet ((maybe-unhighlight (presentation)
1279     (when (and (frame-hilited-presentation frame)
1280 moore 1.98 (or (not highlight)
1281     (not (eq presentation
1282     (car (frame-hilited-presentation frame))))))
1283 moore 1.47 (highlight-presentation-1 (car (frame-hilited-presentation frame))
1284     (cdr (frame-hilited-presentation frame))
1285 moore 1.98 :unhighlight)
1286     (setf (frame-hilited-presentation frame) nil))))
1287 moore 1.18 (if (output-recording-stream-p stream)
1288     (let ((presentation (find-innermost-applicable-presentation
1289     input-context
1290 hefner1 1.76 stream
1291     x y
1292 moore 1.37 :frame frame
1293 hefner1 1.76 :modifier-state modifier)))
1294 moore 1.47 (maybe-unhighlight presentation)
1295 moore 1.98 (when (and presentation
1296     highlight
1297     (not (eq presentation
1298     (car (frame-hilited-presentation frame)))))
1299     (setf (frame-hilited-presentation frame)
1300     (cons presentation stream))
1301     (highlight-presentation-1 presentation stream :highlight))
1302     presentation)
1303 moore 1.47 (progn
1304     (maybe-unhighlight nil)
1305 moore 1.98 nil))))
1306 moore 1.78
1307 hefner1 1.76 (defmethod frame-input-context-track-pointer :before
1308     ((frame standard-application-frame) input-context
1309     (stream output-recording-stream) event)
1310     (frame-highlight-at-position frame stream
1311     (device-event-x event)
1312     (device-event-y event)
1313     (event-modifier-state event)
1314     input-context)
1315 moore 1.47 (frame-update-pointer-documentation frame input-context stream event))
1316 moore 1.27
1317 ahefner 1.120 (defun simple-event-loop (&optional (frame *application-frame*))
1318 moore 1.27 "An simple event loop for applications that want all events to be handled by
1319     handle-event methods"
1320 ahefner 1.120 (let ((queue (frame-event-queue frame)))
1321 adejneka 1.41 (loop for event = (event-queue-read queue)
1322     ;; EVENT-QUEUE-READ in single-process mode calls PROCESS-NEXT-EVENT itself.
1323     do (handle-event (event-sheet event) event))))
1324 moore 1.57
1325     ;;; Am I missing something? Does this need to do more? - moore
1326     (defmacro with-application-frame ((frame) &body body)
1327     `(let ((,frame *application-frame*))
1328     ,@body))
1329 hefner1 1.67
1330 hefner1 1.68 (defmethod note-input-focus-changed (pane state)
1331     (declare (ignore pane state)))
1332    
1333 moore 1.82 (defmethod (setf client-setting) (value frame setting)
1334     (setf (getf (client-settings frame) setting) value))
1335 moore 1.81
1336 moore 1.82 (defmethod reset-frame (frame &rest client-settings)
1337     (loop for (setting value) on client-settings by #'cddr
1338     do (setf (client-setting frame setting) value)))
1339 moore 1.98
1340     ;;; tracking-pointer stuff related to presentations
1341    
1342     (defclass frame-tracking-pointer-state (tracking-pointer-state)
1343     ((presentation-handler :reader presentation-handler :initarg :presentation)
1344     (presentation-button-release-handler
1345     :reader presentation-button-release-handler
1346     :initarg :presentation-button-release)
1347     (presentation-button-press-handler :reader presentation-button-press-handler
1348     :initarg :presentation-button-press)
1349     (applicable-presentation :accessor applicable-presentation :initform nil)
1350     (input-context :reader input-context)
1351     (highlight :reader highlight))
1352     (:default-initargs :presentation nil
1353     :presentation-button-press nil
1354     :presentation-button-release nil
1355     :context-type t))
1356    
1357     (defmethod initialize-instance :after
1358     ((obj frame-tracking-pointer-state)
1359     &key presentation presentation-button-press presentation-button-release
1360 moore 1.99 (highlight nil highlightp) context-type
1361     multiple-window)
1362     (declare (ignore multiple-window))
1363 tmoore 1.114 (let ((presentation-clauses-p (or presentation
1364     presentation-button-press
1365     presentation-button-release)))
1366     (setf (slot-value obj 'highlight) (if highlightp
1367     highlight
1368     presentation-clauses-p))
1369 moore 1.98 (setf (slot-value obj 'input-context)
1370 tmoore 1.114 (if (or presentation-clauses-p highlight)
1371     (make-fake-input-context context-type)
1372     nil))))
1373 moore 1.98
1374     (defmethod make-tracking-pointer-state
1375     ((frame standard-application-frame) sheet args)
1376     (declare (ignore sheet))
1377     (apply #'make-instance 'frame-tracking-pointer-state
1378     args))
1379    
1380     (defmethod tracking-pointer-loop :before
1381     ((state frame-tracking-pointer-state) frame sheet &rest args)
1382     (declare (ignore args))
1383     (if (highlight state)
1384     (highlight-current-presentation frame (input-context state))
1385     (let ((hilited (frame-hilited-presentation frame)))
1386     (when hilited
1387     (highlight-presentation-1 (car hilited)
1388     (cdr hilited)
1389     :unhighlight)))))
1390    
1391 tmoore 1.104 ;;; Poor man's find-applicable-translators. tracking-pointer doesn't want to
1392     ;;; see any results from presentation translators.
1393 tmoore 1.114 ;;;
1394     ;;; XXX I don't see why not (even though I wrote the above comment :) and
1395     ;;; Classic CLIM seems to agree. -- moore
1396     (defun highlight-for-tracking-pointer (frame stream event input-context
1397     highlight)
1398 tmoore 1.117 (let ((presentation nil)
1399 tmoore 1.104 (current-hilited (frame-hilited-presentation frame)))
1400 tmoore 1.114 (when (output-recording-stream-p stream)
1401 tmoore 1.117 ;; XXX Massive hack to prevent the presentation action for completions
1402     ;; from being applicable. After the .9.2.2 release that action will have
1403     ;; a more restrictive context type.
1404     (let ((*completion-possibilities-continuation* nil))
1405     (setq presentation (find-innermost-applicable-presentation
1406     input-context
1407     stream
1408     (device-event-x event)
1409     (device-event-y event)
1410     :frame frame))))
1411 tmoore 1.114 (when (and current-hilited (not (eq (car current-hilited) presentation)))
1412     (highlight-presentation-1 (car current-hilited)
1413     (cdr current-hilited)
1414     :unhighlight))
1415     (when (and presentation highlight)
1416     (setf (frame-hilited-presentation frame) (cons presentation stream))
1417     (highlight-presentation-1 presentation stream :highlight))
1418     presentation))
1419 tmoore 1.104
1420 moore 1.98 (defmethod tracking-pointer-loop-step :before
1421     ((state frame-tracking-pointer-state) (event pointer-event) x y)
1422     (declare (ignore x y))
1423 tmoore 1.114 (when (input-context state)
1424 moore 1.98 (let ((stream (event-sheet event)))
1425     (setf (applicable-presentation state)
1426 tmoore 1.104 (highlight-for-tracking-pointer *application-frame* stream
1427 tmoore 1.114 event
1428     (input-context state)
1429     (highlight state))))))
1430 tmoore 1.104
1431 moore 1.98
1432     (macrolet ((frob (event handler)
1433     `(defmethod tracking-pointer-loop-step
1434     ((state frame-tracking-pointer-state) (event ,event) x y)
1435     (let ((handler (,handler state))
1436     (presentation (applicable-presentation state)))
1437     (if (and handler presentation)
1438     (funcall handler :presentation presentation
1439 hefner1 1.102 :event event
1440 moore 1.98 :window (event-sheet event)
1441     :x x :y y)
1442     (call-next-method))))))
1443     (frob pointer-motion-event presentation-handler)
1444     (frob pointer-button-press-event presentation-button-press-handler)
1445     (frob pointer-button-release-event presentation-button-release-handler))
1446    
1447 tmoore 1.105 (defun make-drag-bounding (old-highlighting new-highlighting
1448     old-presentation new-presentation)
1449     (let (x1 y1 x2 y2)
1450     (flet ((union-with-bounds (rect)
1451     (cond ((null rect)
1452     nil)
1453     ((null x1)
1454     (setf (values x1 y1 x2 y2) (bounding-rectangle* rect)))
1455     (t (with-bounding-rectangle* (r-x1 r-y1 r-x2 r-y2)
1456     rect
1457     (setf (values x1 y1 x2 y2)
1458     (bound-rectangles x1 y1 x2 y2
1459     r-x1 r-y1 r-x2 r-y2)))))))
1460     (union-with-bounds old-highlighting)
1461     (union-with-bounds new-highlighting)
1462     (union-with-bounds old-presentation)
1463     (union-with-bounds new-presentation)
1464     (values x1 y1 x2 y2))))
1465    
1466     (defun make-drag-and-drop-feedback-function (from-presentation)
1467     (multiple-value-bind (record-x record-y)
1468     (output-record-position from-presentation)
1469     (let ((current-to-presentation nil)
1470     (current-from-higlighting nil))
1471     (lambda (frame from-presentation to-presentation initial-x initial-y
1472     x y event)
1473     (let ((dx (- record-x initial-x))
1474     (dy (- record-y initial-y)))
1475     (typecase event
1476     (null
1477     ())))))))
1478 moore 1.98
1479 tmoore 1.114 (defmethod frame-drag-and-drop-feedback
1480     ((frame standard-application-frame) from-presentation stream
1481     initial-x initial-y x y state)
1482     (with-bounding-rectangle* (fp-x1 fp-y1 fp-x2 fp-y2)
1483     from-presentation
1484     ;; Offset from origin of presentation is preserved throughout
1485     (let* ((x-off (- fp-x1 initial-x))
1486     (y-off (- fp-y1 initial-y))
1487     (hilite-x1 (+ x-off x))
1488     (hilite-y1 (+ y-off y))
1489     (hilite-x2 (+ hilite-x1 (- fp-x2 fp-x1)))
1490     (hilite-y2 (+ hilite-y1 (- fp-y2 fp-y1))))
1491     (with-identity-transformation (stream)
1492     (ecase state
1493     (:highlight
1494     (with-output-recording-options (stream :record nil)
1495     (draw-rectangle* stream hilite-x1 hilite-y1 hilite-x2 hilite-y2
1496     :filled nil :line-dashes #(4 4))))
1497     (:unhighlight
1498     (with-double-buffering
1499 tmoore 1.116 ((stream hilite-x1 hilite-y1 (1+ hilite-x2) (1+ hilite-y2))
1500 tmoore 1.114 (buffer-rectangle))
1501     (stream-replay stream buffer-rectangle))))))))
1502    
1503     (defmethod frame-drag-and-drop-highlighting
1504 tmoore 1.115 ((frame standard-application-frame) to-presentation stream state)
1505     (highlight-presentation-1 to-presentation stream state))
1506 tmoore 1.114
1507 tmoore 1.115 (defun frame-drag-and-drop (translator-name command-table
1508     from-presentation context-type frame event window
1509     x y)
1510     (declare (ignore command-table))
1511     (let* ((*dragged-presentation* from-presentation)
1512     (*dragged-object* (presentation-object from-presentation))
1513     (translators (mapcan (lambda (trans)
1514 tmoore 1.114 (and (typep trans 'drag-n-drop-translator)
1515 tmoore 1.115 (funcall (tester trans)
1516     (presentation-object
1517     from-presentation)
1518     :presentation from-presentation
1519     :context-type context-type
1520     :frame frame
1521     :window window
1522     :x x
1523     :y y
1524 tmoore 1.116 :event event)
1525     (list trans)))
1526 tmoore 1.114 (find-presentation-translators
1527 tmoore 1.115 (presentation-type from-presentation)
1528 tmoore 1.114 context-type
1529     (frame-command-table frame))))
1530 tmoore 1.115 ;; Try to run the feedback and highlight functions of the translator
1531     ;; that got us here.
1532 tmoore 1.114 (translator (or (find translator-name translators :key #'name)
1533     (car translators)))
1534 tmoore 1.115 (initial-feedback-fn (feedback translator))
1535     (initial-hilite-fn (highlighting translator))
1536     (destination-presentation nil)
1537     (initial-x x)
1538     (initial-y y)
1539     (last-presentation nil)
1540     (feedback-activated nil)
1541     (feedback-fn initial-feedback-fn)
1542     (hilite-fn initial-hilite-fn)
1543     (last-event nil))
1544     ;; We shouldn't need to use find-innermost-presentation-match
1545     ;; This repeats what tracking-pointer has already done, but what are you
1546     ;; gonna do?
1547     (flet ((find-dest-translator (presentation window x y)
1548     (loop for translator in translators
1549     when (and (presentation-subtypep
1550     (presentation-type presentation)
1551     (destination-ptype translator))
1552     (test-presentation-translator translator
1553     presentation
1554     context-type frame
1555     window x y))
1556     do (return-from find-dest-translator translator))
1557     nil)
1558 tmoore 1.116 (do-feedback (window x y state)
1559     (funcall feedback-fn frame from-presentation window
1560     initial-x initial-y x y state))
1561 tmoore 1.115 (do-hilite (presentation window state)
1562 tmoore 1.116 (funcall hilite-fn frame presentation window state))
1563 tmoore 1.115 (last-window ()
1564     (event-sheet last-event))
1565     (last-x ()
1566     (pointer-event-x last-event))
1567     (last-y ()
1568     (pointer-event-y last-event)))
1569     ;; :highlight nil will cause the presentation that is the source of the
1570     ;; dragged object to be unhighlighted initially.
1571     (block do-tracking
1572     (tracking-pointer (window :context-type `(or ,(mapcar #'from-type
1573     translators))
1574     :highlight nil
1575 tmoore 1.117 :multiple-window nil) ;XXX
1576 tmoore 1.115 (:presentation (&key presentation window event x y)
1577     (let ((dest-translator (find-dest-translator presentation window
1578     x y)))
1579 tmoore 1.116 (when feedback-activated
1580     (do-feedback (last-window) (last-x) (last-y) :unhighlight))
1581 tmoore 1.115 (setq feedback-activated t
1582     last-event event)
1583 tmoore 1.116 (when last-presentation
1584     (do-hilite last-presentation (last-window) :unhighlight))
1585 tmoore 1.115 (setq last-presentation presentation
1586     feedback-fn (feedback dest-translator)
1587     hilite-fn (highlighting dest-translator))
1588     (do-hilite presentation window :highlight)
1589 tmoore 1.116 (do-feedback window x y :highlight)
1590 tmoore 1.115 (document-drag-n-drop dest-translator presentation
1591     context-type frame event window
1592     x y)))
1593     (:pointer-motion (&key event window x y)
1594 tmoore 1.116 (when feedback-activated
1595     (do-feedback (last-window) (last-x) (last-y) :unhighlight))
1596 tmoore 1.115 (setq feedback-activated t
1597     last-event event)
1598 tmoore 1.116 (when last-presentation
1599     (do-hilite last-presentation (last-window) :unhighlight))
1600 tmoore 1.115 (setq last-presentation nil)
1601 tmoore 1.116 (do-feedback window x y :highlight)
1602 tmoore 1.115 (document-drag-n-drop translator nil
1603     context-type frame event window
1604     x y))
1605     ;; XXX only support finish-on-release for now.
1606     #-(and)(:presentation-button-press ())
1607     (:presentation-button-release (&key presentation event)
1608     (setq destination-presentation presentation
1609     last-event event)
1610     (return-from do-tracking nil))
1611     #-(and)(:button-press ())
1612     (:button-release (&key event)
1613     (setq last-event event)
1614     (return-from do-tracking nil))))
1615     ;;
1616     ;; XXX Assumes x y from :button-release are the same as for the preceding
1617     ;; button-motion; is that correct?
1618 tmoore 1.116 (when feedback-activated
1619     (do-feedback (last-window) (last-x) (last-y) :unhighlight))
1620     (when last-presentation
1621     (do-hilite last-presentation (last-window) :unhighlight))
1622 tmoore 1.115 (if destination-presentation
1623     (let ((final-translator (find-dest-translator destination-presentation
1624     (last-window)
1625     (last-x)
1626     (last-y))))
1627     (if final-translator
1628     (funcall (destination-translator final-translator)
1629     *dragged-object*
1630     :presentation *dragged-presentation*
1631     :destination-object (presentation-object
1632     destination-presentation)
1633     :destination-presentation destination-presentation
1634     :context-type context-type
1635     :frame frame
1636     :event event
1637     :window window
1638     :x x
1639     :y y)
1640     (values nil nil)))
1641     (values nil nil)))))
1642    
1643     (defun document-drag-n-drop
1644     (translator presentation context-type frame event window x y)
1645     (when *pointer-documentation-output*
1646     (let ((s *pointer-documentation-output*))
1647     (window-clear s)
1648     (with-end-of-page-action (s :allow)
1649     (with-end-of-line-action (s :allow)
1650 tmoore 1.116 (funcall (pointer-documentation translator)
1651     *dragged-object*
1652     :presentation *dragged-presentation*
1653     :destination-object (and presentation
1654     (presentation-object presentation))
1655     :destination-presentation presentation
1656     :context-type context-type
1657     :frame frame
1658     :event event
1659     :window window
1660     :x x
1661     :y y
1662     :stream s))))))
1663    
1664 tmoore 1.115
1665    

  ViewVC Help
Powered by ViewVC 1.1.5