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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5