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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.109 - (show 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 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
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 ;;; (c) copyright 2004 by
9 ;;; Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
10
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 (in-package :clim-internals)
27
28 ;; *application-frame* is in decls.lisp
29 (defvar *default-frame-manager* nil)
30
31 ;;; Frame-Manager class
32
33 (define-protocol-class frame-manager ()
34 ((port :initarg :port
35 :reader frame-manager-port)
36 (frames :initform nil
37 :reader frame-manager-frames)))
38
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 `(let ((*frame-manager* ,frame-manager))
50 (declare (special *frame-manager*))
51 (locally ,@body)))
52
53 ;;; 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 ;;; Application-Frame class
65 ;;; XXX All these slots should move to a mixin or to standard-application-frame.
66 ;;; -- moore
67
68 ;;; Generic operations
69 (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 (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 (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 (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 (defgeneric frame-current-layout (frame))
115 (defgeneric (setf frame-current-layout) (layout frame))
116 (defgeneric frame-all-layouts (frame))
117 (defgeneric layout-frame (frame &optional width height))
118 (defgeneric frame-exit-frame (condition)
119 (:documentation
120 "Returns the frame that is being exited from associated with the
121 FRAME-EXIT condition."))
122 (defgeneric frame-exit (frame)
123 (: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 (defgeneric frame-properties (frame property))
133 (defgeneric (setf frame-properties) (value frame property))
134 (defgeneric (setf client-setting) (value frame setting))
135 (defgeneric reset-frame (frame &rest client-settings))
136 (defgeneric frame-maintain-presentation-histories (frame))
137
138 ; extension
139 (defgeneric frame-schedule-timer-event (frame sheet delay token))
140
141 (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 (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 :initarg :user-supplied-geometry
200 :documentation "plist of defaulted :left, :top, :bottom, :right, :width and :height options.")
201 (process :reader frame-process :initform (current-process))
202 (client-settings :accessor client-settings :initform nil)))
203
204 (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 (defclass standard-application-frame (application-frame
228 presentation-history-mixin)
229 ((event-queue :initarg :frame-event-queue
230 :initarg :input-buffer
231 :initform nil
232 :accessor frame-event-queue
233 :documentation "The event queue that, by default, will be
234 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 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 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
249 ;;; Support the :input-buffer initarg for compatibility with "real CLIM"
250
251 (defmethod initialize-instance :after ((obj standard-application-frame)
252 &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 (unless (frame-event-queue obj)
258 (setf (frame-event-queue obj)
259 (make-instance 'port-event-queue))))
260
261 (defmethod (setf frame-manager) (fm (frame application-frame))
262 (let ((old-manager (frame-manager frame)))
263 (setf (%frame-manager frame) nil)
264 (when old-manager
265 (disown-frame old-manager frame)
266 (setf (slot-value frame 'panes) nil)
267 (setf (slot-value frame 'layouts) nil))
268 (setf (%frame-manager frame) fm)))
269
270 (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 (declare (ignore name))
275 (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
281 (defmethod generate-panes :before (fm (frame application-frame))
282 (declare (ignore fm))
283 (when (and (frame-panes frame)
284 (eq (sheet-parent (frame-panes frame))
285 (frame-top-level-sheet frame)))
286 (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
293 (defmethod generate-panes :after (fm (frame application-frame))
294 (declare (ignore fm))
295 (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 ;; Find the size of the new frame
299 (multiple-value-bind (w h x y) (frame-geometry* frame)
300 ;; automatically generates a window-configuation-event
301 ;; which then calls allocate-space
302 ;;
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 (setf (sheet-region (frame-top-level-sheet frame))
307 (make-bounding-rectangle 0 0 w h))
308 (allocate-space (frame-top-level-sheet frame) w h) ))
309
310 (defmethod layout-frame ((frame application-frame) &optional width height)
311 (let ((pane (frame-panes frame)))
312 (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 (let ((space (compose-space pane))) ;I guess, this might be wrong. --GB 2004-06-01
316 (setq width (space-requirement-width space))
317 (setq height (space-requirement-height space))))
318 (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 (allocate-space pane width height)))
323
324 (defun find-pane-if (predicate panes)
325 "Returns a pane satisfying PREDICATE in the forest growing from PANES"
326 (map-over-sheets #'(lambda (p)
327 (when (funcall predicate p)
328 (return-from find-pane-if p)))
329 panes)
330 nil)
331
332 (defun find-pane-of-type (panes type)
333 (find-pane-if #'(lambda (pane) (typep pane type)) panes))
334
335 ;;; 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 (defmethod frame-current-panes ((frame application-frame))
339 (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
347 (defmethod get-frame-pane ((frame application-frame) pane-name)
348 (let ((pane (find-pane-named frame pane-name)))
349 (if (typep pane 'clim-stream-pane)
350 pane
351 nil)))
352
353 (defmethod find-pane-named ((frame application-frame) pane-name)
354 (find pane-name (frame-named-panes frame) :key #'pane-name))
355
356 (defmethod frame-standard-output ((frame application-frame))
357 (or (find-pane-of-type (frame-panes frame) 'application-pane)
358 (find-pane-of-type (frame-panes frame) 'interactor-pane)))
359
360 (defmethod frame-standard-input ((frame application-frame))
361 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
362 (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 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
375
376 #+nil
377 (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 (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 (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 ;;; Command loop interface
404
405 (define-condition frame-exit (condition)
406 ((frame :initarg :frame :reader %frame-exit-frame)))
407
408 ;; 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 (defmethod frame-exit ((frame standard-application-frame))
419 (if (eq *application-frame* frame)
420 (signal 'frame-exit :frame frame)
421 (disown-frame (frame-manager frame) frame)))
422
423 (defmethod frame-exit-frame ((c frame-exit))
424 (%frame-exit-frame c))
425
426 (defmethod redisplay-frame-pane ((frame application-frame) pane &key force-p)
427 (declare (ignore pane force-p))
428 nil)
429
430 (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 (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 (with-possible-double-buffering (frame pane)
460 (when clearp
461 (window-clear pane))
462 (call-next-method))
463 (unless (or (eq redisplayp :command-loop) (eq redisplayp :no-clear))
464 (setf (pane-needs-redisplay pane) nil)))))
465
466 (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
473 (defmethod run-frame-top-level :around ((frame application-frame) &key)
474 (let ((*application-frame* frame)
475 (*input-context* nil)
476 (*input-wait-test* nil)
477 (*input-wait-handler* nil)
478 (*pointer-button-press-handler* nil)
479 (original-state (frame-state frame)))
480 (declare (special *input-context* *input-wait-test* *input-wait-handler*
481 *pointer-button-press-handler*))
482 (when (eq (frame-state frame) :disowned) ; Adopt frame into frame manager
483 (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 (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
505 (defparameter +default-prompt-style+ (make-text-style :fix :italic :normal))
506
507 (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 (prompt "Command: "))
514 ;; 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 ;; 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 (progn
543 (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
566 (defmethod read-frame-command :around ((frame application-frame)
567 &key (stream *standard-input*))
568 (with-input-context ('menu-item)
569 (object)
570 (call-next-method)
571 (menu-item
572 (let ((command (command-menu-item-value object)))
573 (unless (listp command)
574 (setq command (list command)))
575 (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
581 (defmethod read-frame-command ((frame application-frame)
582 &key (stream *standard-input*))
583 ;; 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 (read-command (frame-command-table frame) :use-keystrokes t :stream stream))
590
591 (defmethod execute-frame-command ((frame application-frame) command)
592 (apply (command-name command) (command-arguments command)))
593
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
621 (defmethod make-pane-1 :around (fm (frame standard-application-frame) type
622 &rest args
623 &key (input-buffer nil input-buffer-p)
624 (name nil namep)
625 &allow-other-keys)
626 (declare (ignore name input-buffer))
627 "Default input-buffer to the frame event queue."
628 (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 pane))
636
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 (setf (port frame) (frame-manager-port fm))
641 (setf (graft frame) (find-graft :port (port frame)))
642 (let* ((*application-frame* frame)
643 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
644 :name 'top-level-sheet
645 ;; enabling should be left to enable-frame
646 :enabled-p nil))
647 #+clim-mp (event-queue (sheet-event-queue t-l-s)))
648 (setf (slot-value frame 'top-level-sheet) t-l-s)
649 (generate-panes fm frame)
650 (setf (slot-value frame 'state) :disabled)
651 #+clim-mp
652 (when (typep event-queue 'port-event-queue)
653 (setf (event-queue-port event-queue)
654 (frame-manager-port fm)))
655 frame))
656
657 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
658 #+CLIM-MP
659 (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 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
664 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
665 (setf (%frame-manager frame) nil)
666 (setf (slot-value frame 'state) :disowned)
667 (port-force-output (frame-manager-port fm))
668 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 (declare (ignore frame))
692 t)
693
694 (defvar *pane-realizer* nil)
695
696 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
697 `(let ((*pane-realizer* ,frame-manager)
698 (*application-frame* ,frame))
699 (locally
700 ,@body)))
701
702 ; 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 `(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 ',class-name)
719 ,pane))
720 ((consp menu-bar)
721 `(vertically () (clim-internals::make-menu-bar
722 (make-command-table nil
723 :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 (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 (cond
752 ((and (= (length form) 1)
753 (listp (first form)))
754 `(coerce-pane-name ,(first form) ',name))
755 ((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
767 (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 `(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
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 (command-table (list name))
824 (menu-bar t)
825 (disabled-commands nil)
826 (command-definer t)
827 (top-level '(default-frame-top-level))
828 (others nil)
829 (pointer-documentation nil)
830 (geometry nil)
831 (frame-arg (gensym "FRAME-ARG")))
832 (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 (:menu-bar (setq menu-bar (if (listp values)
839 (first values)
840 values)))
841 (:disabled-commands (setq disabled-commands values))
842 (:command-definer (setq command-definer (first values)))
843 (:top-level (setq top-level (first values)))
844 (:pointer-documentation (setq pointer-documentation (car values)))
845 (:geometry (setq geometry values))
846 (t (push (cons prop values) others))))
847 (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 (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 layouts `((:default ,(car pane)))))
859 (setq current-layout (first (first layouts)))
860 `(progn
861 (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 `((defmacro ,command-definer (name-and-options arguments &rest body)
888 (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 `(define-command (,name :command-table ,command-table ,@options) ,arguments ,@body))))))))
892
893 (defun get-application-frame-class-geometry (name indicator)
894 (getf (get name 'application-frame-geometry) indicator nil))
895
896 (defun make-application-frame (frame-name
897 &rest options
898 &key (pretty-name
899 (string-capitalize frame-name))
900 (frame-manager nil frame-manager-p)
901 enable
902 (state nil state-supplied-p)
903 (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 save-under (frame-class frame-name)
910 &allow-other-keys)
911 (declare (ignore save-under))
912 (with-keywords-removed (options (:pretty-name :frame-manager :enable :state
913 :left :top :right :bottom :width :height
914 :save-under :frame-class))
915 (let ((frame (apply #'make-instance frame-class
916 :name frame-name
917 :pretty-name pretty-name
918 :user-supplied-geometry
919 (list :left left :top top
920 :right right :bottom bottom
921 :width width :height height)
922 options)))
923 (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
934 ;;; Menu frame class
935
936 (defclass menu-frame ()
937 ((left :initform 0 :initarg :left)
938 (top :initform 0 :initarg :top)
939 (min-width :initform nil :initarg :min-width)
940 (top-level-sheet :initform nil :reader frame-top-level-sheet)
941 (panes :reader frame-panes :initarg :panes)
942 (graft :initform nil :accessor graft)
943 (manager :initform nil :accessor frame-manager)))
944
945 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
946 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
947 (setf (frame-manager frame) fm)
948 (let* ((t-l-s (make-pane-1 fm *application-frame*
949 'unmanaged-top-level-sheet-pane
950 :name 'top-level-sheet)))
951 (setf (slot-value frame 'top-level-sheet) t-l-s)
952 (sheet-adopt-child t-l-s (frame-panes frame))
953 (let ((graft (find-graft :port (frame-manager-port fm))))
954 (sheet-adopt-child graft t-l-s)
955 (setf (graft frame) graft))
956 (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
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 (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
986 ;;; Frames and presentations
987 (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
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 (defmethod frame-input-context-button-press-handler
1001 ((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 :frame frame
1010 :event button-press-event)))
1011 (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 (declare (ignore stream button-press-event))
1019 nil)
1020
1021 (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 (#.+pointer-right-button+ "R")
1027 (#.+pointer-wheel-up+ "WheelUp")
1028 (#.+pointer-wheel-down+ "WheelDown")))
1029
1030 (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 (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
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 (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 (declare (ignore input-context stream))
1104 (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 (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 (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
1200 ;;; 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 (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 (declare (ignore input-context stream event))
1228 nil)
1229
1230 (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 (flet ((maybe-unhighlight (presentation)
1235 (when (and (frame-hilited-presentation frame)
1236 (or (not highlight)
1237 (not (eq presentation
1238 (car (frame-hilited-presentation frame))))))
1239 (highlight-presentation-1 (car (frame-hilited-presentation frame))
1240 (cdr (frame-hilited-presentation frame))
1241 :unhighlight)
1242 (setf (frame-hilited-presentation frame) nil))))
1243 (if (output-recording-stream-p stream)
1244 (let ((presentation (find-innermost-applicable-presentation
1245 input-context
1246 stream
1247 x y
1248 :frame frame
1249 :modifier-state modifier)))
1250 (maybe-unhighlight presentation)
1251 (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 (progn
1260 (maybe-unhighlight nil)
1261 nil))))
1262
1263 (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 (frame-update-pointer-documentation frame input-context stream event))
1272
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 (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
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
1286
1287 (defmethod note-input-focus-changed (pane state)
1288 (declare (ignore pane state)))
1289
1290 (defmethod (setf keyboard-input-focus) :after (focus frame)
1291 (%set-port-keyboard-focus (port frame) focus))
1292
1293 (defmethod (setf client-setting) (value frame setting)
1294 (setf (getf (client-settings frame) setting) value))
1295
1296 (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
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 (highlight nil highlightp) context-type
1321 multiple-window)
1322 (declare (ignore multiple-window))
1323 (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 ;;; 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 (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 (highlight-for-tracking-pointer *application-frame* stream
1385 (device-event-x event)
1386 (device-event-y event)
1387 (input-context state))))))
1388
1389
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 :event event
1398 :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 (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
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 (find-innermost-presentation-match drag-context window
1459 x y :event event)))))))

  ViewVC Help
Powered by ViewVC 1.1.5