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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.90 - (hide annotations)
Sat Feb 7 14:05:50 2004 UTC (10 years, 2 months ago) by moore
Branch: MAIN
Changes since 1.89: +233 -201 lines
Cleaned up the frame layout code. It's now possible to change layouts
on the fly. Got rid of frame-pane and replaced it with a proper
definition of frame-panes that conforms to the Spec. All the frame
pane and layout functions in the spec should be implemented now.

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

  ViewVC Help
Powered by ViewVC 1.1.5