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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5