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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.72 - (show annotations)
Sun Sep 14 17:55:56 2003 UTC (10 years, 7 months ago) by hefner1
Branch: MAIN
Changes since 1.71: +11 -7 lines
Attempt to address the annoying CLX buffering issues, by calling
XLIB:DISPLAY-FORCE-OUTPUT when applications check their event queues.

* Created a subclass of STANDARD-EVENT-QUEUE called PORT-EVENT-QUEUE, which
  knows what port will be putting events on the queue. (Arguably I could've
  just added a port slot to STANDARD-EVENT-QUEUE either directly or through
  a mixin, or even added a slot for a "force output" hook, but this is what
  I've done for now.)

* When creating frames or sheet-with-input-mixins, use PORT-EVENT-QUEUE
  instead and initialize the PORT slot.

* Introduced a new method, PORT-FORCE-OUTPUT.

* Wrote :before methods on EVENT-QUEUE-READ, EVENT-QUEUE-PEEK, etc, which
  call PORT-FORCE-OUTPUT.

* Before exiting RUN-FRAME-TOPLEVEL, be sure to get the port from the frame
  manager and call PORT-FORCE-OUTPUT on that too, to make sure the app
  window really goes away when it should instead of being stuck in limbo.

* Also squashed a couple warnings in Backends/CLX/image.lisp from bad format
  strings to ERROR.
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
9 ;;; This library is free software; you can redistribute it and/or
10 ;;; modify it under the terms of the GNU Library General Public
11 ;;; License as published by the Free Software Foundation; either
12 ;;; version 2 of the License, or (at your option) any later version.
13 ;;;
14 ;;; This library is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;;; Library General Public License for more details.
18 ;;;
19 ;;; You should have received a copy of the GNU Library General Public
20 ;;; License along with this library; if not, write to the
21 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;;; Boston, MA 02111-1307 USA.
23
24 (in-package :clim-internals)
25
26 ;; *application-frame* is in decls.lisp
27 (defvar *default-frame-manager* nil)
28
29 ;;; Frame-Manager class
30
31 (define-protocol-class frame-manager ()
32 ((port :initarg :port
33 :reader frame-manager-port)
34 (frames :initform nil
35 :reader frame-manager-frames)))
36
37 (defun find-frame-manager (&rest options &key port &allow-other-keys)
38 (declare (special *frame-manager*))
39 (if (boundp '*frame-manager*)
40 *frame-manager*
41 (if (and *default-frame-manager*
42 (frame-manager-p *default-frame-manager*))
43 *default-frame-manager*
44 (first (frame-managers (or port (apply #'find-port options)))))))
45
46 (defmacro with-frame-manager ((frame-manager) &body body)
47 `(let ((*frame-manager* ,frame-manager))
48 (declare (special *frame-manager*))
49 (locally ,@body)))
50
51 ;;; Application-Frame class
52 ;;; XXX All these slots should move to a mixin or to standard-application-frame.
53 ;;; -- moore
54
55 (define-protocol-class application-frame ()
56 ((port :initform nil
57 :initarg :port
58 :accessor port)
59 (graft :initform nil
60 :initarg :graft
61 :accessor graft)
62 (name :initarg :name
63 :reader frame-name)
64 (pretty-name :initarg :pretty-name
65 :accessor frame-pretty-name)
66 (command-table :initarg :command-table
67 :initform nil
68 :accessor frame-command-table)
69 (disabled-commands :initarg :disabled-commands
70 :initform nil
71 :accessor frame-disabled-commands)
72 (pane :reader frame-pane)
73 (panes :initform nil
74 :reader frame-panes)
75 (layouts :initform nil
76 :initarg :layouts
77 :reader frame-layouts)
78 (current-layout :initform nil
79 :initarg :current-layout
80 :reader frame-current-layout)
81 (top-level-sheet :initform nil
82 :reader frame-top-level-sheet)
83 (menu-bar :initarg :menu-bar
84 :initform nil)
85 (calling-frame :initarg :calling-frame
86 :initform nil)
87 (state :initarg :state
88 :initform :disowned
89 :reader frame-state)
90 (manager :initform nil
91 :reader frame-manager
92 :accessor %frame-manager)
93 (keyboard-input-focus :initform nil
94 :accessor keyboard-input-focus)
95 (properties :initarg :properties
96 :initform nil)
97 (top-level :initform '(default-frame-top-level)
98 :initarg :top-level
99 :reader frame-top-level)
100 (hilited-presentation :initform nil
101 :initarg :hilited-presentation
102 :accessor frame-hilited-presentation)
103 (user-supplied-geometry :initform nil
104 :initarg :user-supplied-geometry)))
105
106 ;;; Generic operations
107 ; (defgeneric frame-name (frame))
108 ; (defgeneric frame-pretty-name (frame))
109 ; (defgeneric (setf frame-pretty-name) (name frame))
110 ; (defgeneric frame-command-table (frame))
111 ; (defgeneric (setf frame-command-table) (command-table frame))
112 (defgeneric frame-standard-output (frame)
113 (:documentation
114 "Returns the stream that will be used for *standard-output* for the FRAME."))
115 (defgeneric frame-standard-input (frame)
116 (:documentation
117 "Returns the stream that will be used for *standard-input* for the FRAME."))
118 (defgeneric frame-query-io (frame)
119 (:documentation
120 "Returns the stream that will be used for *query-io* for the FRAME."))
121 (defgeneric frame-error-output (frame)
122 (:documentation
123 "Returns the stream that will be used for *error-output* for the FRAME."))
124 (defgeneric frame-pointer-documentation-output (frame)
125 (:documentation
126 "Returns the stream that will be used for *pointer-documentation-output*
127 for the FRAME."))
128 (defgeneric frame-calling-frame (frame)
129 (:documentation
130 "Returns the application frame that invoked the FRAME."))
131 (defgeneric frame-parent (frame)
132 (:documentation
133 "Returns the object that acts as the parent for the FRAME."))
134 ;(defgeneric frame-pane (frame) ; XXX Is it in Spec?
135 ; (:documentation
136 ; "Returns the pane that is the top-level pane in the current layout
137 ;of the FRAME's named panes."))
138 (defgeneric frame-top-level-sheet (frame)
139 (:documentation
140 "Returns the shhet that is the top-level sheet for the FRAME. This
141 is the sheet that has as its descendants all of the panes of the FRAME."))
142 (defgeneric frame-current-panes (frame)
143 (:documentation
144 "Returns a list of those named panes in the FRAME's current layout.
145 If there are no named panes, only the single, top level pane is returned."))
146 (defgeneric get-frame-pane (frame pane-name)
147 (:documentation
148 "Returns the named CLIM stream pane in the FRAME whose name is PANE-NAME."))
149 (defgeneric find-pane-named (frame pane-name)
150 (:documentation
151 "Returns the pane in the FRAME whose name is PANE-NAME."))
152 ;(defgeneric frame-current-layout (frame))
153 ;(defgeneric frame-all-layouts (frame)) ; XXX Is it in Spec?
154 (defgeneric layout-frame (frame &optional width height))
155 (defgeneric frame-exit-frame (condition)
156 (:documentation
157 "Returns the frame that is being exited from associated with the
158 FRAME-EXIT condition."))
159 (defgeneric frame-exit (frame) ; XXX Is it in Spec?
160 (:documentation
161 "Exits from the FRAME."))
162 (defgeneric pane-needs-redisplay (pane))
163 (defgeneric (setf pane-needs-redisplay) (value pane))
164 (defgeneric redisplay-frame-pane (frame pane &key force-p))
165 (defgeneric redisplay-frame-panes (frame &key force-p))
166 (defgeneric frame-replay (frame stream &optional region))
167 (defgeneric notify-user (frame message &key associated-window title
168 documentation exit-boxes name style text-style))
169 ;(defgeneric frame-properties (frame property))
170 ;(defgeneric (setf frame-properties) (value frame property))
171
172 ; extension
173 (defgeneric frame-schedule-timer-event (frame sheet delay token))
174
175 (defgeneric note-input-focus-changed (pane state)
176 (:documentation "Called when a pane receives or loses the keyboard
177 input focus. This is a McCLIM extension."))
178
179 (defclass standard-application-frame (application-frame)
180 ((event-queue :initarg :frame-event-queue
181 :initarg :input-buffer
182 :initform nil
183 :accessor frame-event-queue
184 :documentation "The event queue that, by default, will be
185 shared by all panes in the stream")
186 (documentation-state :accessor frame-documentation-state
187 :initform nil
188 :documentation "Used to keep of track of what
189 needs to be rendered in the pointer documentation frame.")))
190
191 ;;; Support the :input-buffer initarg for compatibility with "real CLIM"
192
193 (defmethod initialize-instance :after ((obj standard-application-frame)
194 &key &allow-other-keys)
195 (unless (frame-event-queue obj)
196 (setf (frame-event-queue obj)
197 (make-instance 'port-event-queue :port (port obj)))))
198
199
200 (defmethod (setf frame-manager) (fm (frame application-frame))
201 (let ((old-manager (frame-manager frame)))
202 (setf (%frame-manager frame) nil)
203 (when old-manager
204 (disown-frame old-manager frame)
205 (setf (slot-value frame 'panes) nil)
206 (setf (slot-value frame 'layouts) nil))
207 (setf (%frame-manager frame) fm)))
208
209 (defmethod (setf frame-current-layout) (name (frame application-frame))
210 (declare (ignore name))
211 (generate-panes (frame-manager frame) frame))
212
213 (defmethod generate-panes :before (fm (frame application-frame))
214 (declare (ignore fm))
215 (when (and (slot-boundp frame 'pane)
216 (frame-pane frame))
217 (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
218
219 (defmethod generate-panes :after (fm (frame application-frame))
220 (declare (ignore fm))
221 (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
222 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
223 (let* ((space (compose-space (frame-top-level-sheet frame)))
224 (bbox (or (slot-value frame 'user-supplied-geometry)
225 (make-bounding-rectangle 0 0
226 (space-requirement-width space)
227 (space-requirement-height space)))))
228 ;; automatically generates a window-configuation-event
229 ;; which then calls allocate-space
230 ;;
231 ;; Not any longer, we turn of CONFIGURE-NOTIFY events until the
232 ;; window is mapped and do the space allocation now, so that all
233 ;; sheets will have their correct geometry at once. --GB
234 (setf (sheet-region (frame-top-level-sheet frame))
235 bbox)
236 (allocate-space (frame-top-level-sheet frame)
237 (bounding-rectangle-width bbox)
238 (bounding-rectangle-height bbox))
239 ))
240
241 (defmethod layout-frame ((frame application-frame) &optional width height)
242 (let ((pane (frame-pane frame)))
243 (if (and width (not height))
244 (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
245 (if (and (null width) (null height))
246 (let ((space (compose-space pane)))
247 (setq width (space-requirement-width space))
248 (setq height (space-requirement-height space))))
249 (let ((tpl-sheet (frame-top-level-sheet frame)))
250 (unless (and (= width (bounding-rectangle-width tpl-sheet))
251 (= height (bounding-rectangle-height tpl-sheet)))
252 (resize-sheet (frame-top-level-sheet frame) width height)))
253 (allocate-space pane width height)))
254
255 (defun find-pane-if (predicate panes)
256 "Returns a pane satisfying PREDICATE in the forest growing from PANES"
257 (loop for pane in panes
258 do (map-over-sheets #'(lambda (p)
259 (when (funcall predicate p)
260 (return-from find-pane-if p)))
261 pane)
262 finally (return nil)))
263
264 (defun find-pane-of-type (panes type)
265 (find-pane-if #'(lambda (pane) (typep pane type)) panes))
266
267 (defmethod frame-current-panes ((frame application-frame))
268 (find-pane-if #'(lambda (pane) (pane-name pane))
269 (frame-current-layout frame)))
270
271 (defmethod get-frame-pane ((frame application-frame) pane-name)
272 (find-pane-if #'(lambda (pane)
273 (and (typep pane 'clim-stream-pane)
274 (eq pane-name
275 (pane-name pane))))
276 (frame-panes frame)))
277
278 (defmethod find-pane-named ((frame application-frame) pane-name)
279 (find-pane-if #'(lambda (pane)
280 (eq pane-name
281 (pane-name pane)))
282 (frame-panes frame)))
283
284 (defmethod frame-standard-output ((frame application-frame))
285 (or (find-pane-of-type (frame-panes frame) 'application-pane)
286 (find-pane-of-type (frame-panes frame) 'interactor-pane)))
287
288 (defmethod frame-standard-input ((frame application-frame))
289 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
290 (frame-standard-output frame)))
291
292 (defmethod frame-query-io ((frame application-frame))
293 (or (frame-standard-input frame)
294 (frame-standard-output frame)))
295
296 (defmethod frame-error-output ((frame application-frame))
297 (frame-standard-output frame))
298
299 (defvar *pointer-documentation-output* nil)
300
301 (defmethod frame-pointer-documentation-output ((frame application-frame))
302 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
303
304 (defmethod redisplay-frame-panes ((frame application-frame) &key force-p)
305 (map-over-sheets
306 (lambda (sheet)
307 (when (typep sheet 'pane)
308 (when (and (typep sheet 'clim-stream-pane)
309 (not (eq :no-clear (pane-redisplay-needed sheet))))
310 (window-clear sheet))
311 (redisplay-frame-pane frame sheet :force-p force-p)))
312 (frame-top-level-sheet frame)))
313
314 ;;; Command loop interface
315
316 (define-condition frame-exit (condition)
317 ((frame :initarg :frame :reader %frame-exit-frame)))
318
319 ;; I make the assumption here that the contents of *application-frame* is
320 ;; the frame the top-level loop is running. With the introduction of
321 ;; window-stream frames that may be sharing the event queue with the main
322 ;; application frame, we need to discriminate between them here to avoid
323 ;; shutting down the application at the wrong time.
324 ;; ...
325 ;; A better way to do this would be to make the handler bound in
326 ;; run-frame-top-level check whether the frame signalled is the one
327 ;; it was invoked on.. -- Hefner
328
329 (defmethod frame-exit ((frame standard-application-frame))
330 (if (eq *application-frame* frame)
331 (signal 'frame-exit :frame frame)
332 (disown-frame (frame-manager frame) frame)))
333
334 (defmethod frame-exit-frame ((c frame-exit))
335 (%frame-exit-frame c))
336
337 (defmethod redisplay-frame-pane ((frame application-frame) pane &key force-p)
338 (declare (ignore pane force-p))
339 nil)
340
341 (defmethod run-frame-top-level ((frame application-frame) &key &allow-other-keys)
342 (handler-bind ((frame-exit #'(lambda (condition)
343 (declare (ignore condition))
344 (return-from run-frame-top-level nil))))
345 (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame)))))
346
347 (defmethod run-frame-top-level :around ((frame application-frame) &key)
348 (let ((*application-frame* frame)
349 (*input-context* nil)
350 (*input-wait-test* nil)
351 (*input-wait-handler* nil)
352 (*pointer-button-press-handler* nil)
353 (original-state (frame-state frame)))
354 (declare (special *input-context* *input-wait-test* *input-wait-handler*
355 *pointer-button-press-handler*))
356 (when (eq (frame-state frame) :disowned)
357 (adopt-frame (or (frame-manager frame) (find-frame-manager))
358 frame))
359 (unless (or (eq (frame-state frame) :enabled)
360 (eq (frame-state frame) :shrunk))
361 (enable-frame frame))
362 (let ((query-io (frame-query-io frame)))
363 (unwind-protect
364 (if query-io
365 (with-input-focus (query-io)
366 (call-next-method))
367 (call-next-method))
368 (progn
369 (let ((fm (frame-manager frame)))
370 (case original-state
371 (:disabled
372 (disable-frame frame))
373 (:disowned
374 (disown-frame (frame-manager frame) frame)))
375 (port-force-output (frame-manager-port fm))))))))
376
377 (defun redisplay-changed-panes (frame)
378 (map-over-sheets #'(lambda (pane)
379 (multiple-value-bind (redisplayp clearp)
380 (pane-needs-redisplay pane)
381 (when redisplayp
382 (when (and clearp
383 (or (not (pane-incremental-redisplay
384 pane))
385 (not *enable-updating-output*)))
386 (window-clear pane))
387 (redisplay-frame-pane frame pane)
388 (unless (eq redisplayp :command-loop)
389 (setf (pane-needs-redisplay pane) nil)))))
390 (frame-top-level-sheet frame)))
391
392 (defmethod default-frame-top-level
393 ((frame application-frame)
394 &key (command-parser 'command-line-command-parser)
395 (command-unparser 'command-line-command-unparser)
396 (partial-command-parser
397 'command-line-read-remaining-arguments-for-partial-command)
398 (prompt "Command: "))
399 (loop
400 (let ((*standard-input* (frame-standard-input frame))
401 (*standard-output* (frame-standard-output frame))
402 (*query-io* (frame-query-io frame))
403 (*pointer-documentation-output* (frame-pointer-documentation-output
404 frame))
405 ;; during development, don't alter *error-output*
406 ;; (*error-output* (frame-error-output frame))
407 (*command-parser* command-parser)
408 (*command-unparser* command-unparser)
409 (*partial-command-parser* partial-command-parser)
410 (prompt-style (make-text-style :fix :italic :normal)))
411 (redisplay-changed-panes frame)
412 (when *standard-input*
413 ;; We don't need to turn the cursor on here, as Goatee has its own
414 ;; cursor which will appear. In fact, as a sane interface policy,
415 ;; leave it off by default, and hopefully this doesn't violate the spec.
416 (setf (cursor-visibility (stream-text-cursor *standard-input*)) nil)
417 (when prompt
418 (with-text-style (*standard-input* prompt-style)
419 (if (stringp prompt)
420 (write-string prompt *standard-input*)
421 (funcall prompt *standard-input* frame))
422 (finish-output *standard-input*)))
423 (let ((command (read-frame-command frame)))
424 (fresh-line *standard-input*)
425 (when command
426 (execute-frame-command frame command))
427 (fresh-line *standard-input*))))))
428
429
430 (defmethod read-frame-command ((frame application-frame)
431 &key (stream *standard-input*))
432 (with-input-context ('menu-item)
433 (object)
434 ;; Is this the intended behavior of interactor-panes
435 ;; (vs. application panes)?
436 (if (typep stream 'interactor-pane)
437 (read-command (frame-command-table frame) :stream stream)
438 (loop (read-gesture :stream stream)))
439 (menu-item
440 (let ((command (command-menu-item-value object)))
441 (if (listp command)
442 command
443 (list command))))))
444
445
446 (defmethod execute-frame-command ((frame application-frame) command)
447 (apply (command-name command) (command-arguments command)))
448
449 (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
450 `(make-pane-1 ,fm ,frame ',type ,@args))
451
452 (defmethod make-pane-1 :around (fm (frame standard-application-frame) type
453 &rest args
454 &key (input-buffer nil input-buffer-p)
455 &allow-other-keys)
456 "Default input-buffer to the frame event queue."
457 (if input-buffer-p
458 (call-next-method)
459 (apply #'call-next-method fm frame type
460 :input-buffer (frame-event-queue frame)
461 args)))
462
463 (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
464 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
465 (setf (frame-manager frame) fm)
466 (setf (port frame) (frame-manager-port fm))
467 (setf (graft frame) (find-graft :port (port frame)))
468 (let* ((*application-frame* frame)
469 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
470 :name 'top-level-sheet
471 ;; enabling should be left to enable-frame
472 :enabled-p nil)))
473 (setf (slot-value frame 'top-level-sheet) t-l-s)
474 (generate-panes fm frame)
475 (setf (slot-value frame 'state) :disabled)
476 frame))
477
478 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
479 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
480 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
481 (setf (%frame-manager frame) nil)
482 (setf (slot-value frame 'state) :disowned)
483 frame)
484
485 (defgeneric enable-frame (frame))
486 (defgeneric disable-frame (frame))
487
488 (defgeneric note-frame-enabled (frame-manager frame))
489 (defgeneric note-frame-disbled (frame-manager frame))
490
491 (defmethod enable-frame ((frame application-frame))
492 (setf (sheet-enabled-p (frame-top-level-sheet frame)) t)
493 (setf (slot-value frame 'state) :enabled)
494 (note-frame-enabled (frame-manager frame) frame))
495
496 (defmethod disable-frame ((frame application-frame))
497 (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil)
498 (setf (slot-value frame 'state) :disabled)
499 (note-frame-disabled (frame-manager frame) frame))
500
501 (defmethod note-frame-enabled ((fm frame-manager) frame)
502 (declare (ignore frame))
503 t)
504
505 (defmethod note-frame-disabled ((fm frame-manager) frame)
506 t)
507
508 (defvar *pane-realizer* nil)
509
510 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
511 `(let ((*pane-realizer* ,frame-manager)
512 (*application-frame* ,frame))
513 (locally
514 ,@body)))
515
516 ; The menu-bar code in the following two functions is incorrect.
517 ; it needs to be moved to somewhere after the backend, since
518 ; it depends on the backend chosen.
519 ;
520 ; This hack slaps a menu-bar into the start of the application-frame,
521 ; in such a way that it is hard to find.
522 ;
523 ; FIXME
524 (defun make-single-pane-generate-panes-form (class-name menu-bar pane)
525 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
526 ; v-- hey, how can this be?
527 (with-look-and-feel-realization (fm frame)
528 (let ((pane ,(cond
529 ((eq menu-bar t)
530 `(vertically () (clim-internals::make-menu-bar
531 ',class-name)
532 ,pane))
533 ((consp menu-bar)
534 `(vertically () (clim-internals::make-menu-bar
535 (make-command-table nil
536 :menu ',menu-bar))
537 ,pane))
538 (menu-bar
539 `(vertically () (clim-internals::make-menu-bar
540 ',menu-bar)
541 ,pane))
542 ;; The form below is unreachable with (listp
543 ;; menu-bar) instead of (consp menu-bar) above
544 ;; --GB
545 (t pane))))
546 (setf (slot-value frame 'pane) pane)))))
547
548 ; could do with some refactoring [BTS] FIXME
549 (defun make-panes-generate-panes-form (class-name menu-bar panes layouts
550 pointer-documentation)
551 (when pointer-documentation
552 (setf panes (append panes
553 '((%pointer-documentation%
554 pointer-documentation-pane)))))
555 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
556 (let ((*application-frame* frame))
557 (with-look-and-feel-realization (fm frame)
558 (let ,(loop for (name . form) in panes
559 collect `(,name (or (find-pane-named frame ',name)
560 (let ((pane
561 ,(cond
562 ((and (= (length form) 1)
563 (listp (first form)))
564 (first form))
565 ((keywordp (first form))
566 (let ((maker (intern (concatenate 'string
567 (symbol-name '#:make-clim-)
568 (symbol-name (first form))
569 (symbol-name '#:-pane))
570 :clim)))
571 (if (fboundp maker)
572 `(,maker :name ',name ,@(cdr form))
573 `(make-pane ',(first form)
574 :name ',name ,@(cdr form)))))
575 (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
576 ;; hmm?! --GB
577 (setf (slot-value pane 'name) ',name)
578 ;;
579 (push pane (slot-value frame 'panes))
580 pane))))
581 ; [BTS] added this, but is not sure that this is correct for adding
582 ; a menu-bar transparently, should also only be done where the
583 ; exterior window system does not support menus
584 ,(if (or menu-bar pointer-documentation)
585 `(setf (slot-value frame 'pane)
586 (ecase (frame-current-layout frame)
587 ,@(mapcar (lambda (layout)
588 `(,(first layout)
589 (vertically ()
590 ,@(cond
591 ((eq menu-bar t)
592 `((clim-internals::make-menu-bar
593 ',class-name)))
594 ((consp menu-bar)
595 `((clim-internals::make-menu-bar
596 (make-command-table
597 nil
598 :menu ',menu-bar))))
599 (menu-bar
600 `((clim-internals::make-menu-bar
601 ',menu-bar)))
602 (t nil))
603 ,@(rest layout)
604 ,@(when pointer-documentation
605 '(%pointer-documentation%)))))
606 layouts)))
607 `(setf (slot-value frame 'pane)
608 (ecase (frame-current-layout frame)
609 ,@layouts))))))))
610
611 (defmacro define-application-frame (name superclasses slots &rest options)
612 (if (null superclasses)
613 (setq superclasses '(standard-application-frame)))
614 (let ((pane nil)
615 (panes nil)
616 (layouts nil)
617 (current-layout nil)
618 (command-table (list name))
619 (menu-bar t)
620 (disabled-commands nil)
621 (command-definer t)
622 (top-level '(default-frame-top-level))
623 (others nil)
624 (command-name (intern (concatenate 'string
625 (symbol-name '#:define-)
626 (symbol-name name)
627 (symbol-name '#:-command))))
628 (pointer-documentation nil)
629 (geometry nil))
630 (loop for (prop . values) in options
631 do (case prop
632 (:pane (setq pane (first values)))
633 (:panes (setq panes values))
634 (:layouts (setq layouts values))
635 (:command-table (setq command-table (first values)))
636 (:menu-bar (setq menu-bar (if (listp values)
637 (first values)
638 values)))
639 (:disabled-commands (setq disabled-commands values))
640 (:command-definer (setq command-definer (first values)))
641 (:top-level (setq top-level (first values)))
642 (:pointer-documentation (setq pointer-documentation (car values)))
643 (:geometry (setq geometry values))
644 (t (push (cons prop values) others))))
645 (if (or (and pane panes)
646 (and pane layouts))
647 (error ":pane cannot be specified along with either :panes or :layouts"))
648 (if pane
649 (setq panes (list 'single-pane pane)
650 layouts `((:default ,(car pane)))))
651 (setq current-layout (first (first layouts)))
652 `(progn
653 (defclass ,name ,superclasses
654 ,slots
655 (:default-initargs
656 :name ',name
657 :pretty-name ,(string-capitalize name)
658 :command-table (find-command-table ',(first command-table))
659 :disabled-commands ',disabled-commands
660 :menu-bar ',menu-bar
661 :current-layout ',current-layout
662 :layouts ',layouts
663 :top-level ',top-level
664 )
665 ,@others)
666 ,@(if geometry
667 `((setf (get ',name 'application-frame-geometry) ',geometry)))
668 ,(if pane
669 (make-single-pane-generate-panes-form name menu-bar pane)
670 (make-panes-generate-panes-form name menu-bar panes layouts
671 pointer-documentation))
672 ,@(if command-table
673 `((define-command-table ,@command-table)))
674 ,@(if command-definer
675 `((defmacro ,command-name (name-and-options arguements &rest body)
676 (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
677 (options (if (listp name-and-options) (cdr name-and-options) nil))
678 (command-table ',(first command-table)))
679 `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body))))))))
680
681 (defun get-application-frame-geometry (name indicator)
682 (let ((geometry (get name 'application-frame-geometry)))
683 (if geometry
684 (getf geometry indicator nil))))
685
686 (defun compose-user-supplied-geometry (left top right bottom width height)
687 (flet ((compute-range (min max diff)
688 (cond
689 ((and min max)
690 (values min max))
691 ((and min diff)
692 (values min (+ min diff)))
693 ((and max diff)
694 (values (- max diff) max))
695 (t
696 (values nil nil)))))
697 (multiple-value-bind (x1 x2) (compute-range left right width)
698 (multiple-value-bind (y1 y2) (compute-range top bottom height)
699 (if (and x1 x2 y1 y2)
700 (make-bounding-rectangle x1 y1 x2 y2)
701 nil)))))
702
703 (defun make-application-frame (frame-name
704 &rest options
705 &key (pretty-name
706 (string-capitalize frame-name))
707 (frame-manager nil frame-manager-p)
708 enable
709 (state nil state-supplied-p)
710 (left (get-application-frame-geometry frame-name :left))
711 (top (get-application-frame-geometry frame-name :top))
712 (right (get-application-frame-geometry frame-name :right))
713 (bottom (get-application-frame-geometry frame-name :bottom))
714 (width (get-application-frame-geometry frame-name :width))
715 (height (get-application-frame-geometry frame-name :height))
716 save-under (frame-class frame-name)
717 &allow-other-keys)
718 (declare (ignore save-under))
719 (with-keywords-removed (options (:pretty-name :frame-manager :enable :state
720 :left :top :right :bottom :width :height
721 :save-under :frame-class))
722 (let ((frame (apply #'make-instance frame-class
723 :name frame-name
724 :pretty-name pretty-name
725 :user-supplied-geometry (compose-user-supplied-geometry
726 left top right bottom width height)
727 options)))
728 (when frame-manager-p
729 (adopt-frame frame-manager frame))
730 (cond ((or enable (eq state :enabled))
731 (enable-frame frame))
732 ((and (eq state :disowned)
733 (not (eq (frame-state frame) :disowned)))
734 (disown-frame (frame-manager frame) frame))
735 (state-supplied-p
736 (warn ":state ~S not supported yet." state)))
737 frame)))
738
739 ;;; Menu frame class
740
741 (defclass menu-frame ()
742 ((left :initform 0 :initarg :left)
743 (top :initform 0 :initarg :top)
744 (top-level-sheet :initform nil :reader frame-top-level-sheet)
745 (pane :reader frame-pane :initarg :pane)
746 (graft :initform nil :accessor graft)
747 (manager :initform nil :accessor frame-manager)))
748
749 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
750 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
751 (setf (frame-manager frame) fm)
752 (let* ((t-l-s (make-pane-1 fm *application-frame*
753 'unmanaged-top-level-sheet-pane
754 :name 'top-level-sheet)))
755 (setf (slot-value frame 'top-level-sheet) t-l-s)
756 (sheet-adopt-child t-l-s (frame-pane frame))
757 (let ((graft (find-graft :port (frame-manager-port fm))))
758 (sheet-adopt-child graft t-l-s)
759 (setf (graft frame) graft))
760 (let ((space (compose-space t-l-s)))
761 (allocate-space (frame-pane frame)
762 (space-requirement-width space)
763 (space-requirement-height space))
764 (setf (sheet-region t-l-s)
765 (make-bounding-rectangle 0 0
766 (space-requirement-width space)
767 (space-requirement-height space))))
768 (setf (sheet-transformation t-l-s)
769 (make-translation-transformation (slot-value frame 'left)
770 (slot-value frame 'top)))))
771
772 (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
773 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
774 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
775 (setf (frame-manager frame) nil))
776
777 (defun make-menu-frame (pane &key (left 0) (top 0))
778 (make-instance 'menu-frame :pane pane :left left :top top))
779
780 ;;; Frames and presentations
781
782 (defmethod frame-find-innermost-applicable-presentation
783 ((frame standard-application-frame) input-context stream x y
784 &key event)
785 (find-innermost-applicable-presentation input-context stream
786 x y
787 :frame frame :event event))
788
789 (defmethod frame-input-context-button-press-handler
790 ((frame standard-application-frame)
791 (stream output-recording-stream)
792 button-press-event)
793 (let ((presentation (find-innermost-applicable-presentation
794 *input-context*
795 stream
796 (pointer-event-x button-press-event)
797 (pointer-event-y button-press-event)
798 :frame frame
799 :event button-press-event)))
800 (when presentation
801 (throw-highlighted-presentation presentation
802 *input-context*
803 button-press-event))))
804
805 (defmethod frame-input-context-button-press-handler
806 ((frame standard-application-frame) stream button-press-event)
807 (declare (ignore stream button-press-event))
808 nil)
809
810 (defgeneric frame-update-pointer-documentation
811 (frame input-context stream event))
812
813 (defconstant +button-documentation+ '((#.+pointer-left-button+ "L")
814 (#.+pointer-middle-button+ "M")
815 (#.+pointer-right-button+ "R")))
816
817 (defconstant +modifier-documentation+
818 '((#.+shift-key+ "sh" "Shift")
819 (#.+control-key+ "c" "Control")
820 (#.+meta-key+ "m" "Meta")
821 (#.+super-key+ "s" "Super")
822 (#.+hyper-key+ "h" "Hyper")))
823
824 ;;; Give a coherent order to sets of modifier combinations. Multi-key combos
825 ;;; come after single keys.
826
827 (defun cmp-modifiers (a b)
828 (let ((cnt-a (logcount a))
829 (cnt-b (logcount b)))
830 (cond ((eql cnt-a cnt-b)
831 (< a b))
832 (t (< cnt-a cnt-b)))))
833
834 (defun print-modifiers (stream modifiers style)
835 (if (zerop modifiers)
836 (when (eq style :long)
837 (write-string "<nothing>" stream))
838 (loop with trailing = nil
839 for (bit short long) in +modifier-documentation+
840 when (logtest bit modifiers)
841 do (progn
842 (format stream "~:[~;-~]~A" trailing (if (eq style :short)
843 short
844 long))
845 (setq trailing t)))))
846
847
848 ;;; We don't actually want to print out the translator documentation and redraw
849 ;;; the pointer documentation window on every motion event. So, we compute a
850 ;;; state object (basically modifier state and a list of the applicable
851 ;;; presentation, translator and input context on each mouse button),
852 ;;; compare it to the previous state object, and only write out documentation
853 ;;; if they are different. I suppose it's possible that this state object
854 ;;; doesn't capture all possible documentation changes -- the doc generator is
855 ;;; a function, after all -- but that's just tough.
856 ;;;
857 ;;; It would be nice to evolve this into a protocol so that elements other than
858 ;;; presentations -- menu choices, for example -- could influence pointer
859 ;;; documentation window.
860
861 (defgeneric frame-compute-pointer-documentation-state
862 (frame input-context stream event)
863 (:documentation
864 "Compute a state object that will be used to generate pointer documentation."))
865
866 (defmethod frame-compute-pointer-documentation-state
867 ((frame standard-application-frame) input-context stream event)
868 (let* ((current-modifier (event-modifier-state event))
869 (x (device-event-x event))
870 (y (device-event-y event))
871 (new-translators
872 (loop for (button) in +button-documentation+
873 for context-list = (multiple-value-list
874 (find-innermost-presentation-context
875 input-context
876 stream
877 x y
878 :modifier-state current-modifier
879 :button button))
880 when (car context-list)
881 collect (cons button context-list))))
882 (list current-modifier new-translators)))
883
884 (defgeneric frame-compare-pointer-documentation-state
885 (frame input-context stream old-state new-state))
886
887 (defmethod frame-compare-pointer-documentation-state
888 ((frame standard-application-frame) input-context stream
889 old-state new-state)
890 (equal old-state new-state))
891
892 (defgeneric frame-print-pointer-documentation
893 (frame input-context stream state event))
894
895 (defmethod frame-print-pointer-documentation
896 ((frame standard-application-frame) input-context stream state event)
897 (unless state
898 (return-from frame-print-pointer-documentation nil))
899 (destructuring-bind (current-modifier new-translators)
900 state
901 (let ((x (device-event-x event))
902 (y (device-event-y event))
903 (pstream *pointer-documentation-output*))
904 (loop for (button presentation translator context)
905 in new-translators
906 for name = (cadr (assoc button +button-documentation+))
907 for first-one = t then nil
908 do (progn
909 (unless first-one
910 (write-string "; " pstream))
911 (unless (zerop current-modifier)
912 (print-modifiers pstream current-modifier :short)
913 (write-string "-" pstream))
914 (format pstream "~A: " name)
915 (document-presentation-translator translator
916 presentation
917 (input-context-type context)
918 *application-frame*
919 event
920 stream
921 x y
922 :stream pstream
923 :documentation-type
924 :pointer))
925 finally (when new-translators
926 (write-char #\. pstream)))
927 ;; Wasteful to do this after doing
928 ;; find-innermost-presentation-context above... look at doing this
929 ;; first and then doing the innermost test.
930 (let ((all-translators (find-applicable-translators
931 (stream-output-history stream)
932 input-context
933 *application-frame*
934 stream
935 x y
936 :for-menu t))
937 (other-modifiers nil))
938 (loop for (translator) in all-translators
939 for gesture = (gesture translator)
940 unless (eq gesture t)
941 do (loop for (name type modifier) in gesture
942 unless (eql modifier current-modifier)
943 do (pushnew modifier other-modifiers)))
944 (when other-modifiers
945 (setf other-modifiers (sort other-modifiers #'cmp-modifiers))
946 (terpri pstream)
947 (write-string "To see other commands, press " pstream)
948 (loop for modifier-tail on other-modifiers
949 for (modifier) = modifier-tail
950 for count from 0
951 do (progn
952 (if (null (cdr modifier-tail))
953 (progn
954 (when (> count 1)
955 (write-char #\, pstream))
956 (when (> count 0)
957 (write-string " or " pstream)))
958 (when (> count 0)
959 (write-string ", " pstream)))
960 (print-modifiers pstream modifier :long)))
961 (write-char #\. pstream))))))
962
963 (defmethod frame-update-pointer-documentation
964 ((frame standard-application-frame) input-context stream event)
965 (when *pointer-documentation-output*
966 (with-accessors ((frame-documentation-state frame-documentation-state))
967 frame
968 (let ((new-state (frame-compute-pointer-documentation-state frame
969 input-context
970 stream
971 event)))
972 (unless (frame-compare-pointer-documentation-state
973 frame
974 input-context
975 stream
976 frame-documentation-state
977 new-state)
978 (window-clear *pointer-documentation-output*)
979 (frame-print-pointer-documentation frame
980 input-context
981 stream
982 new-state
983 event)
984 (setq frame-documentation-state new-state))))))
985
986 (defmethod frame-input-context-track-pointer
987 ((frame standard-application-frame)
988 input-context
989 (stream output-recording-stream) event)
990 (declare (ignore input-context event))
991 nil)
992
993 (defmethod frame-input-context-track-pointer
994 ((frame standard-application-frame) input-context stream event)
995 (declare (ignore input-context stream event))
996 nil)
997
998 (defmethod frame-input-context-track-pointer :before
999 ((frame standard-application-frame) input-context stream event)
1000 (flet ((maybe-unhighlight (presentation)
1001 (when (and (frame-hilited-presentation frame)
1002 (not (eq presentation
1003 (car (frame-hilited-presentation frame)))))
1004 (highlight-presentation-1 (car (frame-hilited-presentation frame))
1005 (cdr (frame-hilited-presentation frame))
1006 :unhighlight))))
1007 (if (output-recording-stream-p stream)
1008 (let ((presentation (find-innermost-applicable-presentation
1009 input-context
1010 stream
1011 (device-event-x event)
1012 (device-event-y event)
1013 :frame frame
1014 :modifier-state (event-modifier-state event))))
1015 (maybe-unhighlight presentation)
1016 (if presentation
1017 (when (not (eq presentation
1018 (car (frame-hilited-presentation frame))))
1019 (setf (frame-hilited-presentation frame)
1020 (cons presentation stream))
1021 (highlight-presentation-1 presentation stream :highlight))
1022 (setf (frame-hilited-presentation frame) nil)))
1023 (progn
1024 (maybe-unhighlight nil)
1025 (setf (frame-hilited-presentation frame) nil))))
1026 (frame-update-pointer-documentation frame input-context stream event))
1027
1028 (defun simple-event-loop ()
1029 "An simple event loop for applications that want all events to be handled by
1030 handle-event methods"
1031 (let ((queue (frame-event-queue *application-frame*)))
1032 (loop for event = (event-queue-read queue)
1033 ;; EVENT-QUEUE-READ in single-process mode calls PROCESS-NEXT-EVENT itself.
1034 do (handle-event (event-sheet event) event))))
1035
1036 ;;; Am I missing something? Does this need to do more? - moore
1037 (defmacro with-application-frame ((frame) &body body)
1038 `(let ((,frame *application-frame*))
1039 ,@body))
1040
1041
1042 (defmethod note-input-focus-changed (pane state)
1043 (declare (ignore pane state)))
1044
1045 (defmethod (setf keyboard-input-focus) :after (focus frame)
1046 (set-port-keyboard-focus focus (port frame)))
1047

  ViewVC Help
Powered by ViewVC 1.1.5