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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5