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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5