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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5