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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.100 - (show annotations)
Thu Oct 14 06:30:11 2004 UTC (9 years, 6 months ago) by hefner1
Branch: MAIN
Changes since 1.99: +4 -4 lines
Improved (fixed) support for keystroke accelerators
---------------------------------------------------

File commands.lisp:

add-command-to-command-table: When given a keystroke, call
add-keystroke-to-command-table.
%add-keystroke-item: Changed error handling logic, added support for
literal keystroke specifications
remove-keystroke-from-command-table: When searching keystroke
accelerators, use :test #'equal


New function partial-command-from-name, which given a command name
produces a command whose
requried args are *unsupplied-argument-marker*

lookup-keystroke-command-item: Add support for keystroke accelerators
which specify only a command name. A partial command is created via
partial-command-from-name.

Class command-parsers: Added slots required-args and keyword-args,
needed in order to construct a partial command.

%define-command: Init required/keyword arguments in command-parser
object

read-command-using-keystrokes: Invoke partial command parser if a
partial command is returned.


File events.lisp:

Add :wheel-up and :wheel-down to key-modifier-state-match-p button
mapping. (This has been sitting around my tree for months, but somehow
never got committed..)


File frames.lisp:

In read-frame-command, supply ':use-keystrokes t' by default.


File stream-input.lisp:

Factored the bulk of add-gesture-name out into a new function,
realize-gesture-spec, which converts modifier names to symbols and does
general massaging of the gesture specification. Added translations for
:wheel-up, :wheel-down device names, which have also been sitting around
my tree for months.

realize-gesture-spec: Don't signal an error if the device-name is not
found in +name-to-char+, doing so would preclude the use of
port-specific keyboard gestures.

%event-matches-gesture: In the method specialized on key-press-event and
gesture type :keyboard, compare against the key-name of the event when
there is no key-character available, so that we can match keys/gestures
outside the CL character set via device names.

event-matches-gesture-name-p: Added the ability to match against other
than defined gesture-names. Specifically, it can now match against a
'physical' gesture-spec of the form (type device-name modifier-state).
Matching against characters is also supported.

Fix random typo.


Misc changes
------------

recording.lisp: Comment on 'constructor' arg to
invoke-with-output-recording-options, use of untransform on rotation
angles.

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

  ViewVC Help
Powered by ViewVC 1.1.5