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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5