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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.125 - (show annotations)
Wed Feb 7 12:44:16 2007 UTC (7 years, 2 months ago) by crhodes
Branch: MAIN
Changes since 1.124: +0 -6 lines
New click-to-focus policy for text-editor gadgets and panes, implemented
for the CLX, Null and gtkairo backends (but gtk_window_get_focus()
hand-inserted into gtkairo/ffi.lisp).

PORT-KEYBOARD-INPUT-FOCUS is now a trampoline to
PORT-FRAME-KEYBOARD-INPUT-FOCUS, a per-port function to set the keyboard
focus for a particular frame.  Not implemented for Beagle or OpenGL
backends.

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

  ViewVC Help
Powered by ViewVC 1.1.5