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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5