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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (show annotations)
Thu Jun 27 17:25:09 2002 UTC (11 years, 9 months ago) by gilbert
Branch: MAIN
Changes since 1.38: +11 -8 lines
GENERATE-PANES :after t application-frame

    I invoke ALLOCATE-SPACE now to have sheet's nicely layout, when
    the application frame eventually gets mapped.

[hopefully last commit for now...]
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 (defclass frame-manager ()
32 ((port :initarg :port
33 :reader frame-manager-port)
34 (frames :initform nil
35 :reader frame-manager-frames)
36 )
37 )
38
39 (defun frame-manager-p (x)
40 (typep x 'frame-manager))
41
42 (defun find-frame-manager (&rest options &key port &allow-other-keys)
43 (declare (special *frame-manager*))
44 (if (boundp '*frame-manager*)
45 *frame-manager*
46 (if (and *default-frame-manager*
47 (frame-manager-p *default-frame-manager*))
48 *default-frame-manager*
49 (first (frame-managers (or port (apply #'find-port options)))))))
50
51 (defmacro with-frame-manager ((frame-manager) &body body)
52 `(let (('*frame-manager* ,frame-manager))
53 (declare (special *frame-manager*))
54 (block ,@body)))
55
56 ;;; Application-Frame class
57 ;;; XXX All these slots should move to a mixin or to standard-application-frame.
58 ;;; -- moore
59
60 (defclass application-frame ()
61 ((port :initform nil
62 :initarg :port
63 :accessor port)
64 (graft :initform nil
65 :initarg :graft
66 :accessor graft)
67 (name :initarg :name
68 :reader frame-name)
69 (pretty-name :initarg :pretty-name
70 :accessor frame-pretty-name)
71 (command-table :initarg :command-table
72 :initform nil
73 :accessor frame-command-table)
74 (disabled-commands :initarg :disabled-commands
75 :initform nil
76 :accessor frame-disabled-commands)
77 (pane :reader frame-pane)
78 (panes :initform nil
79 :reader frame-panes)
80 (layouts :initform nil
81 :initarg :layouts
82 :reader frame-layouts)
83 (current-layout :initform nil
84 :initarg :current-layout
85 :reader frame-current-layout)
86 (top-level-sheet :initform nil
87 :reader frame-top-level-sheet)
88 (menu-bar :initarg :menu-bar
89 :initform nil)
90 (calling-frame :initarg :calling-frame
91 :initform nil)
92 (state :initarg :state
93 :initform nil
94 :accessor frame-state)
95 (manager :initform nil
96 :reader frame-manager)
97 (properties :initarg :properties
98 :initform nil)
99 (top-level :initform '(default-frame-top-level)
100 :initarg :top-level
101 :reader frame-top-level)
102 (hilited-presentation :initform nil
103 :initarg :hilited-presentation
104 :accessor frame-hilited-presentation)))
105
106 (defun application-frame-p (x)
107 (typep x 'application-frame))
108
109 (defmethod initialize-instance :after ((frame application-frame) &rest args)
110 (declare (ignore args)))
111
112 ;;; Generic operations
113 ; (defgeneric frame-name (frame))
114 ; (defgeneric frame-pretty-name (frame))
115 ; (defgeneric (setf frame-pretty-name) (name frame))
116 ; (defgeneric frame-command-table (frame))
117 ; (defgeneric (setf frame-command-table) (command-table frame))
118 (defgeneric frame-standard-output (frame)
119 (:documentation
120 "Returns the stream that will be used for *standard-output* for the FRAME."))
121 (defgeneric frame-standard-input (frame)
122 (:documentation
123 "Returns the stream that will be used for *standard-input* for the FRAME."))
124 (defgeneric frame-query-io (frame)
125 (:documentation
126 "Returns the stream that will be used for *query-io* for the FRAME."))
127 (defgeneric frame-error-output (frame)
128 (:documentation
129 "Returns the stream that will be used for *error-output* for the FRAME."))
130 (defgeneric frame-pointer-documentation-output (frame)
131 (:documentation
132 "Returns the stream that will be used for *pointer-documentation-output*
133 for the FRAME."))
134 (defgeneric frame-calling-frame (frame)
135 (:documentation
136 "Returns the application frame that invoked the FRAME."))
137 (defgeneric frame-parent (frame)
138 (:documentation
139 "Returns the object that acts as the parent for the FRAME."))
140 ;(defgeneric frame-pane (frame) ; XXX Is it in Spec?
141 ; (:documentation
142 ; "Returns the pane that is the top-level pane in the current layout
143 ;of the FRAME's named panes."))
144 (defgeneric frame-top-level-sheet (frame)
145 (:documentation
146 "Returns the shhet that is the top-level sheet for the FRAME. This
147 is the sheet that has as its descendants all of the panes of the FRAME."))
148 (defgeneric frame-current-panes (frame)
149 (:documentation
150 "Returns a list of those named panes in the FRAME's current layout.
151 If there are no named panes, only the single, top level pane is returned."))
152 (defgeneric get-frame-pane (frame pane-name)
153 (:documentation
154 "Returns the named CLIM stream pane in the FRAME whose name is PANE-NAME."))
155 (defgeneric find-pane-named (frame pane-name)
156 (:documentation
157 "Returns the pane in the FRAME whose name is PANE-NAME."))
158 ;(defgeneric frame-current-layout (frame))
159 ;(defgeneric frame-all-layouts (frame)) ; XXX Is it in Spec?
160 (defgeneric layout-frame (frame &optional width height))
161 (defgeneric frame-exit-frame (condition)
162 (:documentation
163 "Returns the frame that is being exited from associated with the
164 FRAME-EXIT condition."))
165 (defgeneric frame-exit (frame) ; XXX Is it in Spec?
166 (:documentation
167 "Exits from the FRAME."))
168 (defgeneric pane-needs-redisplay (pane))
169 (defgeneric (setf pane-needs-redisplay) (value pane))
170 (defgeneric redisplay-frame-pane (frame pane &key force-p))
171 (defgeneric redisplay-frame-panes (frame &key force-p))
172 (defgeneric frame-replay (frame stream &optional region))
173 (defgeneric notify-user (frame message &key associated-window title
174 documentation exit-boxes name style text-style))
175 ;(defgeneric frame-properties (frame property))
176 ;(defgeneric (setf frame-properties) (value frame property))
177
178
179 (defclass standard-application-frame (application-frame)
180 ((event-queue :initarg :frame-event-queue
181 :accessor frame-event-queue
182 :documentation "The event queue that, by default, will be
183 shared by all panes in the stream")))
184
185 ;;; Support the :input-buffer initarg for compatibility with "real CLIM"
186
187 (defmethod initialize-instance :after ((obj standard-application-frame)
188 &key (input-buffer nil input-buffer-p))
189 (cond (input-buffer-p
190 (setf (frame-event-queue obj) input-buffer))
191 ((not (slot-boundp obj 'event-queue))
192 (setf (frame-event-queue obj) (make-instance 'standard-event-queue)))
193 (t nil)))
194
195
196 (defmethod (setf frame-manager) (fm (frame application-frame))
197 (let ((old-manager (frame-manager frame)))
198 (setf (slot-value frame 'manager) nil)
199 (when old-manager
200 (disown-frame old-manager frame)
201 (setf (slot-value frame 'panes) nil)
202 (setf (slot-value frame 'layouts) nil))
203 (setf (slot-value frame 'manager) fm)))
204
205 (defmethod (setf frame-current-layout) (name (frame application-frame))
206 (declare (ignore name))
207 (generate-panes (frame-manager frame) frame))
208
209 (defmethod generate-panes :before (fm (frame application-frame))
210 (declare (ignore fm))
211 (when (and (slot-boundp frame 'pane)
212 (frame-pane frame))
213 (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
214
215 (defmethod generate-panes :after (fm (frame application-frame))
216 (declare (ignore fm))
217 (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
218 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
219 (let ((space (compose-space (frame-top-level-sheet frame))))
220 ;; automatically generates a window-configuation-event
221 ;; which then calls allocate-space
222 ;;
223 ;; Not any longer, we turn of CONFIGURE-NOTIFY events until the
224 ;; window is mapped and do the space allocation now, so that all
225 ;; sheets will have their correct geometry at once. --GB
226 (setf (sheet-region (frame-top-level-sheet frame))
227 (make-bounding-rectangle 0 0
228 (space-requirement-width space)
229 (space-requirement-height space)))
230 (allocate-space (frame-top-level-sheet frame)
231 (space-requirement-width space)
232 (space-requirement-height space)) ))
233
234 (defmethod layout-frame ((frame application-frame) &optional width height)
235 (let ((pane (frame-pane frame)))
236 (if (and width (not height))
237 (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
238 (if (and (null width) (null height))
239 (let ((space (compose-space pane)))
240 (setq width (space-requirement-width space))
241 (setq height (space-requirement-height space))))
242 (allocate-space pane width height)))
243
244 (defun find-pane-if (predicate panes)
245 "Returns a pane satisfying PREDICATE in the forest growing from PANES"
246 (loop for pane in panes
247 do (map-over-sheets #'(lambda (p)
248 (when (funcall predicate p)
249 (return-from find-pane-if p)))
250 pane)
251 finally (return nil)))
252
253 (defun find-pane-of-type (panes type)
254 (find-pane-if #'(lambda (pane) (typep pane type)) panes))
255
256 (defmethod frame-current-panes ((frame application-frame))
257 (find-pane-if #'(lambda (pane) (pane-name pane))
258 (frame-current-layout frame)))
259
260 (defmethod get-frame-pane ((frame application-frame) pane-name)
261 (find-pane-if #'(lambda (pane)
262 (and (typep pane 'clim-stream-pane)
263 (eq pane-name
264 (pane-name pane))))
265 (frame-panes frame)))
266
267 (defmethod find-pane-named ((frame application-frame) pane-name)
268 (find-pane-if #'(lambda (pane)
269 (eq pane-name
270 (pane-name pane)))
271 (frame-panes frame)))
272
273 (defmethod frame-standard-output ((frame application-frame))
274 (or (find-pane-of-type (frame-panes frame) 'application-pane)
275 (find-pane-of-type (frame-panes frame) 'interactor-pane)))
276
277 (defmethod frame-standard-input ((frame application-frame))
278 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
279 (frame-standard-output frame)))
280
281 (defmethod frame-query-io ((frame application-frame))
282 (or (frame-standard-input frame)
283 (frame-standard-output frame)))
284
285 (defmethod frame-error-output ((frame application-frame))
286 (frame-standard-output frame))
287
288 (defvar *pointer-documentation-output* nil)
289
290 (defmethod frame-pointer-documentation-output ((frame application-frame))
291 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
292
293 ;;; Command loop interface
294
295 (define-condition frame-exit (condition)
296 ((frame :initarg :frame :reader %frame-exit-frame)))
297
298 (defmethod frame-exit ((frame standard-application-frame))
299 (signal 'frame-exit :frame frame))
300
301 (defmethod frame-exit-frame ((c frame-exit))
302 (%frame-exit-frame c))
303
304 (defmethod run-frame-top-level ((frame application-frame))
305 (handler-bind ((frame-exit #'(lambda (condition)
306 (declare (ignore condition))
307 (return-from run-frame-top-level nil))))
308 (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame)))))
309
310 (defmethod run-frame-top-level :around ((frame application-frame))
311 (let ((*application-frame* frame)
312 (*input-context* nil)
313 (*input-wait-test* nil)
314 (*input-wait-handler* nil)
315 (*pointer-button-press-handler* nil))
316 (declare (special *input-context* *input-wait-test* *input-wait-handler*
317 *pointer-button-press-handler*))
318 (let ((query-io (frame-query-io frame)))
319 (if query-io
320 (with-input-focus (query-io)
321 (call-next-method))
322 (call-next-method)))))
323
324 (defmethod default-frame-top-level
325 ((frame application-frame)
326 &key (command-parser 'command-line-command-parser)
327 (command-unparser 'command-line-command-unparser)
328 (partial-command-parser
329 'command-line-read-remaining-arguments-for-partial-command)
330 (prompt "Command: "))
331 (loop
332 (let ((*standard-input* (frame-standard-input frame))
333 (*standard-output* (frame-standard-output frame))
334 (*query-io* (frame-query-io frame))
335 ;; during development, don't alter *error-output*
336 ;; (*error-output* (frame-error-output frame))
337 (*command-parser* command-parser)
338 (*command-unparser* command-unparser)
339 (*partial-command-parser* partial-command-parser)
340 (prompt-style (make-text-style :fix :italic :normal)))
341 (map-over-sheets #'(lambda (pane)
342 (if (and (typep pane 'clim-stream-pane)
343 (eq (pane-display-time pane) :command-loop)
344 (pane-display-function pane))
345 (let ((func (pane-display-function pane)))
346 (window-clear pane)
347 (funcall func frame pane))))
348 (frame-top-level-sheet frame))
349 (when *standard-input*
350 (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
351 (when prompt
352 (with-text-style (*standard-input* prompt-style)
353 (if (stringp prompt)
354 (write-string prompt *standard-input*)
355 (funcall prompt *standard-input* frame))
356 (finish-output *standard-input*)))
357 (let ((command (read-frame-command frame)))
358 (fresh-line *standard-input*)
359 (when command
360 (execute-frame-command frame command))
361 (fresh-line *standard-input*))))))
362
363
364 (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*))
365 (read-command (frame-command-table frame) :stream stream))
366
367 (defmethod execute-frame-command ((frame application-frame) command)
368 (apply (command-name command) (command-arguments command)))
369
370 (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
371 `(make-pane-1 ,fm ,frame ',type ,@args))
372
373 (defmethod make-pane-1 :around (fm (frame standard-application-frame) type
374 &rest args
375 &key (input-buffer nil input-buffer-p))
376 "Default input-buffer to the frame event queue."
377 (if input-buffer-p
378 (call-next-method)
379 (apply #'call-next-method fm frame type
380 :input-buffer (frame-event-queue frame)
381 args)))
382
383 (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
384 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
385 (setf (frame-manager frame) fm)
386 (let* ((*application-frame* frame)
387 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
388 :name 'top-level-sheet)))
389 (setf (slot-value frame 'top-level-sheet) t-l-s)
390 (generate-panes fm frame)))
391
392 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
393 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
394 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
395 (setf (frame-manager frame) nil))
396
397 (defvar *pane-realizer* nil)
398
399 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
400 `(let ((*pane-realizer* ,frame-manager)
401 (*application-frame* ,frame))
402 (progn
403 ,@body)))
404
405 ; The menu-bar code in the following two functions is incorrect.
406 ; it needs to be moved to somewhere after the backend, since
407 ; it depends on the backend chosen.
408 ;
409 ; This hack slaps a menu-bar into the start of the application-frame,
410 ; in such a way that it is hard to find.
411 ;
412 ; FIXME
413 (defun make-single-pane-generate-panes-form (class-name menu-bar pane)
414 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
415 ; v-- hey, how can this be?
416 (with-look-and-feel-realization (fm frame)
417 (let ((pane ,(cond
418 ((eq menu-bar t)
419 `(vertically () (clim-internals::make-menu-bar
420 ',class-name)
421 ,pane))
422 ((consp menu-bar)
423 `(vertically () (clim-internals::make-menu-bar
424 (make-command-table nil
425 :menu ',menu-bar))
426 ,pane))
427 (menu-bar
428 `(vertically () (clim-internals::make-menu-bar
429 ',menu-bar)
430 ,pane))
431 ;; The form below is unreachable with (listp
432 ;; menu-bar) instead of (consp menu-bar) above
433 ;; --GB
434 (t pane))))
435 (setf (slot-value frame 'pane) pane)))))
436
437 ; could do with some refactoring [BTS] FIXME
438 (defun make-panes-generate-panes-form (class-name menu-bar panes layouts)
439 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
440 (let ((*application-frame* frame))
441 (with-look-and-feel-realization (fm frame)
442 (let ,(loop for (name . form) in panes
443 collect `(,name (or (find-pane-named frame ',name)
444 (let ((pane
445 ,(cond
446 ((and (= (length form) 1)
447 (listp (first form)))
448 (first form))
449 ((keywordp (first form))
450 (let ((maker (intern (concatenate 'string
451 "MAKE-CLIM-"
452 (symbol-name (first form))
453 "-PANE") :clim)))
454 (if (fboundp maker)
455 `(,maker :name ',name ,@(cdr form))
456 `(make-pane ',(first form)
457 :name ',name ,@(cdr form)))))
458 (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
459 ;; hmm?! --GB
460 (setf (slot-value pane 'name) ',name)
461 ;;
462 (push pane (slot-value frame 'panes))
463 pane))))
464 ; [BTS] added this, but is not sure that this is correct for adding
465 ; a menu-bar transparently, should also only be done where the
466 ; exterior window system does not support menus
467 ,(if menu-bar
468 `(setf (slot-value frame 'pane)
469 (ecase (frame-current-layout frame)
470 ,@(mapcar (lambda (layout)
471 `(,(first layout) (vertically ()
472 ,(cond
473 ((eq menu-bar t)
474 `(clim-internals::make-menu-bar
475 ',class-name))
476 ((consp menu-bar)
477 `(raising (:border-width 2 :background +Gray83+)
478 (clim-internals::make-menu-bar
479 (make-command-table nil
480 :menu ',menu-bar))))
481 (menu-bar
482 `(clim-internals::make-menu-bar
483 ',menu-bar)))
484 ,@(rest layout))))
485 layouts)))
486 `(setf (slot-value frame 'pane)
487 (ecase (frame-current-layout frame)
488 ,@layouts))))))))
489
490 (defmacro define-application-frame (name superclasses slots &rest options)
491 (if (null superclasses)
492 (setq superclasses '(standard-application-frame)))
493 (let ((pane nil)
494 (panes nil)
495 (layouts nil)
496 (current-layout nil)
497 (command-table (list name))
498 (menu-bar t)
499 (disabled-commands nil)
500 (command-definer t)
501 (top-level '(default-frame-top-level))
502 (others nil)
503 (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
504 (loop for (prop . values) in options
505 do (case prop
506 (:pane (setq pane (first values)))
507 (:panes (setq panes values))
508 (:layouts (setq layouts values))
509 (:command-table (setq command-table (first values)))
510 (:menu-bar (setq menu-bar (if (listp values)
511 (first values)
512 values)))
513 (:disabled-commands (setq disabled-commands values))
514 (:command-definer (setq command-definer (first values)))
515 (:top-level (setq top-level (first values)))
516 (t (push (cons prop values) others))))
517 (if (or (and pane panes)
518 (and pane layouts))
519 (error ":pane cannot be specified along with either :panes or :layouts"))
520 (if pane
521 (setq panes (list 'single-pane pane)
522 layouts `((:default ,(car pane)))))
523 (setq current-layout (first (first layouts)))
524 `(progn
525 (defclass ,name ,superclasses
526 ,slots
527 (:default-initargs
528 :name ',name
529 :pretty-name ,(string-capitalize name)
530 :command-table (find-command-table ',(first command-table))
531 :disabled-commands ',disabled-commands
532 :menu-bar ',menu-bar
533 :current-layout ',current-layout
534 :layouts ',layouts
535 :top-level ',top-level
536 )
537 ,@others)
538 ,(if pane
539 (make-single-pane-generate-panes-form name menu-bar pane)
540 (make-panes-generate-panes-form name menu-bar panes layouts))
541 ,@(if command-table
542 `((define-command-table ,@command-table)))
543 ,@(if command-definer
544 `((defmacro ,command-name (name-and-options arguements &rest body)
545 (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
546 (options (if (listp name-and-options) (cdr name-and-options) nil))
547 (command-table ',(first command-table)))
548 `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body))))))))
549
550 (defun make-application-frame (frame-name
551 &rest options
552 &key pretty-name frame-manager enable state
553 left top right bottom width height save-under
554 frame-class
555 &allow-other-keys)
556 (declare (ignore enable state left top right bottom width height save-under))
557 (setq options (loop for (key value) on options by #'cddr
558 if (not (member key '(:pretty-name :frame-manager :enable :state
559 :left :top :right :bottom :width :height :save-under
560 :frame-class)
561 :test #'eq))
562 nconc (list key value)))
563 (if (null frame-class)
564 (setq frame-class frame-name))
565 (if (null pretty-name)
566 (setq pretty-name (string-capitalize frame-name)))
567 (if (null frame-manager)
568 (setq frame-manager (find-frame-manager)))
569 (let ((frame (apply #'make-instance frame-class
570 :port (frame-manager-port frame-manager)
571 :graft (find-graft :port (frame-manager-port frame-manager))
572 :name frame-name :pretty-name pretty-name options)))
573 (adopt-frame frame-manager frame)
574 frame))
575
576 ;;; Menu frame class
577
578 (defclass menu-frame ()
579 ((left :initform 0 :initarg :left)
580 (top :initform 0 :initarg :top)
581 (top-level-sheet :initform nil :reader frame-top-level-sheet)
582 (pane :reader frame-pane :initarg :pane)
583 (graft :initform nil :accessor graft)
584 (manager :initform nil :accessor frame-manager)))
585
586 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
587 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
588 (setf (slot-value frame 'manager) fm)
589 (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
590 :name 'top-level-sheet)))
591 (setf (slot-value frame 'top-level-sheet) t-l-s)
592 (sheet-adopt-child t-l-s (frame-pane frame))
593 (let ((graft (find-graft :port (frame-manager-port fm))))
594 (sheet-adopt-child graft t-l-s)
595 (setf (graft frame) graft))
596 (let ((space (compose-space t-l-s)))
597 (allocate-space (frame-pane frame)
598 (space-requirement-width space)
599 (space-requirement-height space))
600 (setf (sheet-region t-l-s)
601 (make-bounding-rectangle 0 0
602 (space-requirement-width space)
603 (space-requirement-height space))))
604 (setf (sheet-transformation t-l-s)
605 (make-translation-transformation (slot-value frame 'left)
606 (slot-value frame 'top)))))
607
608 (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
609 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
610 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
611 (setf (frame-manager frame) nil))
612
613 (defun make-menu-frame (pane &key (left 0) (top 0))
614 (make-instance 'menu-frame :pane pane :left left :top top))
615
616 ;;; Frames and presentations
617
618 (defmethod frame-find-innermost-applicable-presentation
619 ((frame standard-application-frame) input-context stream x y
620 &key event)
621 (find-innermost-applicable-presentation input-context stream
622 x y
623 :frame frame :event event))
624
625 (defmethod frame-input-context-button-press-handler
626 ((frame standard-application-frame)
627 (stream output-recording-stream)
628 button-press-event)
629 (format *debug-io* "frame button press event: ~D ~D in ~S~%"
630 (pointer-event-x button-press-event)
631 (pointer-event-y button-press-event)
632 stream)
633 (let ((presentation (find-innermost-applicable-presentation
634 *input-context*
635 stream
636 (pointer-event-x button-press-event)
637 (pointer-event-y button-press-event)
638 :frame frame
639 :event button-press-event)))
640 (when presentation
641 (format *debug-io* "presentation: ~S of type ~S~%"
642 (presentation-object presentation)
643 (presentation-type presentation))
644 (throw-highlighted-presentation presentation
645 *input-context*
646 button-press-event))))
647
648 (defmethod frame-input-context-button-press-handler
649 ((frame standard-application-frame) stream button-press-event)
650 (declare (ignore stream button-press-event))
651 nil)
652
653 (defmethod frame-input-context-track-pointer
654 ((frame standard-application-frame)
655 input-context
656 (stream output-recording-stream) event)
657 (declare (ignore input-context event))
658 nil)
659
660 (defmethod frame-input-context-track-pointer
661 ((frame standard-application-frame) input-context stream event)
662 (declare (ignore input-context stream event))
663 nil)
664
665 (defmethod frame-input-context-track-pointer :before
666 ((frame standard-application-frame) input-context stream event)
667 (if (output-recording-stream-p stream)
668 (let ((presentation (find-innermost-applicable-presentation
669 input-context
670 stream
671 (pointer-event-x event)
672 (pointer-event-y event)
673 :frame frame
674 :modifier-state (event-modifier-state event))))
675 (when (and (frame-hilited-presentation frame)
676 (not (eq presentation
677 (car (frame-hilited-presentation frame)))))
678 (highlight-presentation-1 (car (frame-hilited-presentation frame))
679 (cdr (frame-hilited-presentation frame))
680 :unhighlight))
681 (if presentation
682 (when (not (eq presentation
683 (car (frame-hilited-presentation frame))))
684 (setf (frame-hilited-presentation frame)
685 (cons presentation stream))
686 (highlight-presentation-1 presentation stream :highlight))
687 (setf (frame-hilited-presentation frame) nil)))))
688
689
690 (defun simple-event-loop ()
691 "An simple event loop for applications that want all events to be handled by
692 handle-event methods"
693 (if *multiprocessing-p*
694 (let ((queue (frame-event-queue *application-frame*)))
695 (loop for event = (event-queue-read queue)
696 do (handle-event (event-sheet event) event)))
697 (let ((port (port *application-frame*)))
698 (loop
699 (process-next-event port)))))

  ViewVC Help
Powered by ViewVC 1.1.5