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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.82 - (show annotations)
Mon Nov 10 21:40:34 2003 UTC (10 years, 5 months ago) by moore
Branch: MAIN
Changes since 1.81: +24 -10 lines

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

  ViewVC Help
Powered by ViewVC 1.1.5