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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37 - (hide annotations)
Thu May 23 06:55:05 2002 UTC (11 years, 10 months ago) by moore
Branch: MAIN
Changes since 1.36: +4 -2 lines
Presentation translators, including define-presentation-to-command-translator
and command translators generated by the :gesture option in define-command
arguments.  With this checkin the address book demo mostly works as intended,
except for creating new address book entries.

Added builtin-commands.lisp to hold global commands and presentation
translators.

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

  ViewVC Help
Powered by ViewVC 1.1.5