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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5