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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5