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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5