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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.119 - (show annotations)
Fri May 5 10:24:02 2006 UTC (7 years, 11 months ago) by crhodes
Branch: MAIN
Changes since 1.118: +2 -86 lines
Many more generic function defgenerics in decls.lisp
... moving some out from their individual files.
... one or two tiny code cleanups

I think the only substantive changes in this commit are:
* remove the workaround for sbcl-0.9.8 broken forward-referenced-class
  metacircularity;
* delete the unused uniform-design protocol-class;
* put the standard-sheet-input-mixin as a superclass of
  standard-extended-input-stream, not of the protocol class
  extended-input-stream.
If someone wants to tell me that these things are wrong, that's fine; at
least some things appear still to work.

Now we only emit 209 style warnings when loading mcclim under sbcl.
(When compiling and loading, it's closer to 500).

This commit cures all but a few redefinition style-warnings -- so now
almost all generic functions are defined before the first method
definition is seen.  It doesn't cure implicit definition of generic
function style warnings, so there are probably plenty of specified
generic functions which are not explicitly defined.  (Leaving aside the
issues with unspecified generic functions)

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

  ViewVC Help
Powered by ViewVC 1.1.5