diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 4f83bac417d6cca7d97b18e0b054e93cb9e94aa1..ff8658c244dbf65b528aeaefdfad846baa35478a 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: accept-values.lisp,v 1.5 92/01/31 14:57:29 cer Exp Locker: cer $ +;; $fiHeader: accept-values.lisp,v 1.6 92/02/05 21:45:37 cer Exp Locker: cer $ (in-package :clim-internals) @@ -161,37 +161,43 @@ query)))) (define-application-frame accept-values () - ((stream :initarg :stream) - (continuation :initarg :continuation) - (own-window :initform nil :initarg :own-window) - (own-window-x-position :initform nil :initarg :x-position) - (own-window-y-position :initform nil :initarg :y-position) - (own-window-width :initform nil :initarg :width) - (own-window-height :initform nil :initarg :height) - (own-window-right-margin :initform nil :initarg :right-margin) - (own-window-bottom-margin :initform nil :initarg :bottom-margin) - (exit-boxes :initform nil :initarg :exit-boxes) - (selected-item :initform nil) - ;;--- Do this through RUN-FRAME-TOP-LEVEL? - (initially-select-query-identifier :initform nil - :initarg :initially-select-query-identifier) - (resynchronize-every-pass :initform nil :initarg :resynchronize-every-pass) - (check-overlapping :initform t :initarg :check-overlapping)) + ((stream :initarg :stream) + exit-button-stream + (calling-frame :reader frame-calling-frame + :initarg :calling-frame) + (continuation :initarg :continuation) + (own-window :initform nil :initarg :own-window) + (own-window-x-position :initform nil :initarg :x-position) + (own-window-y-position :initform nil :initarg :y-position) + (own-window-width :initform nil :initarg :width) + (own-window-height :initform nil :initarg :height) + (own-window-right-margin :initform nil :initarg :right-margin) + (own-window-bottom-margin :initform nil :initarg :bottom-margin) + (exit-boxes :initform nil :initarg :exit-boxes) + (selected-item :initform nil) + ;;--- Do this through RUN-FRAME-TOP-LEVEL? + (initially-select-query-identifier :initform nil + :initarg :initially-select-query-identifier) + (resynchronize-every-pass :initform nil :initarg :resynchronize-every-pass) + (check-overlapping :initform t :initarg :check-overlapping)) (:top-level (accept-values-top-level)) (:command-definer t)) (define-application-frame accept-values-own-window (accept-values) () (:pane - (with-slots (stream own-window) *application-frame* - (scrolling () - (progn - (setq stream - (make-instance 'accept-values-stream - :stream (setf own-window - (realize-pane 'extended-stream-pane - :initial-cursor-visibility nil)))) - own-window)))) + (with-slots (stream own-window exit-button-stream) *application-frame* + (vertically () + (progn + (setq stream + (make-instance 'accept-values-stream + :stream (setf own-window + (realize-pane 'extended-stream-pane + :initial-cursor-visibility nil)))) + own-window) + (setf exit-button-stream + (realize-pane 'extended-stream-pane + :initial-cursor-visibility nil))))) (:menu-bar nil) (:command-table accept-values) (:command-definer nil)) @@ -270,19 +276,20 @@ (bottom-margin 10)) (if own-window (let ((frame (make-application-frame (or frame-class 'accept-values-own-window) - :continuation continuation - :exit-boxes exit-boxes - :own-window the-own-window - :x-position x-position - :y-position y-position - :right-margin right-margin - :bottom-margin bottom-margin - :initially-select-query-identifier - initially-select-query-identifier - :resynchronize-every-pass - resynchronize-every-pass - :check-overlapping - check-overlapping))) + :calling-frame *application-frame* + :continuation continuation + :exit-boxes exit-boxes + :own-window the-own-window + :x-position x-position + :y-position y-position + :right-margin right-margin + :bottom-margin bottom-margin + :initially-select-query-identifier + initially-select-query-identifier + :resynchronize-every-pass + resynchronize-every-pass + :check-overlapping + check-overlapping))) ;; What do we do about sizing????? ;; What do we do about positioning???? (let ((*avv-calling-frame* *application-frame*)) @@ -317,11 +324,13 @@ selected-item initially-select-query-identifier own-window own-window-x-position own-window-y-position own-window-width own-window-height - own-window-right-margin own-window-bottom-margin) frame + own-window-right-margin own-window-bottom-margin + exit-button-stream) frame (let ((command-table (frame-command-table frame)) (original-view (stream-default-view stream)) (return-values nil) (initial-query nil) + exit-button-stuff avv avv-record) (letf-globally (((stream-default-view stream) (port-dialog-view (sheet-port stream)))) @@ -330,9 +339,13 @@ (setf (slot-value stream 'avv-frame) frame) (with-output-recording-options (stream :draw nil :record t) (setq return-values (multiple-value-list - (let ((*application-frame* *avv-calling-frame*)) - (funcall continuation stream)))) - (display-exit-boxes frame stream (stream-default-view stream)))) + (let ((*application-frame* *avv-calling-frame*)) + (funcall continuation + stream))))) + (unless own-window + (display-exit-boxes frame + stream + (stream-default-view stream)))) (run-avv () (when (and initially-select-query-identifier (setq initial-query @@ -360,6 +373,8 @@ (with-output-recording-options (stream :draw nil) (redisplay avv stream :check-overlapping check-overlapping))) (setf (slot-value avv-record 'resynchronize) nil) + (when exit-button-stuff + (redisplay exit-button-stuff exit-button-stream)) (redisplay avv stream :check-overlapping check-overlapping)))) (declare (dynamic-extent #'run-continuation #'run-avv)) (with-simple-restart (frame-exit "Exit from the ACCEPT-VALUES dialog") @@ -370,9 +385,23 @@ (with-end-of-page-action (stream :allow) (with-new-output-record (stream 'accept-values-output-record avv-record) - (run-continuation stream avv-record))))))) + (run-continuation stream + avv-record))))))) + + ;; In own window dialogs the buttons are displayed + ;; separately + + (when own-window + (setq exit-button-stuff + (updating-output (exit-button-stream) + (with-end-of-line-action (exit-button-stream :allow) + (with-end-of-page-action (exit-button-stream :allow) + (display-exit-boxes frame + exit-button-stream + (stream-default-view stream))))))) (unwind-protect (cond (own-window + (size-menu-appropriately exit-button-stream) (size-menu-appropriately own-window :width own-window-width :height own-window-height @@ -390,6 +419,7 @@ (position-window-near-carefully own-window x y)) (window-expose own-window) (with-input-focus (own-window) + (replay exit-button-stuff exit-button-stream) (replay avv stream) (run-avv))) (t diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index e7b00a9002023474e94a5e7140137bd166d5406f..1a149873238a72f6adcff4f88591ccc8d160d17b 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -21,7 +21,7 @@ ;;; ;;; Copyright (c) 1990 by Xerox Corporations. All rights reserved. ;;; -;; $fiHeader: db-stream.lisp,v 1.5 92/01/06 20:44:18 cer Exp $ +;; $fiHeader: db-stream.lisp,v 1.6 92/01/31 14:57:47 cer Exp Locker: cer $ (in-package :clim-internals) @@ -42,11 +42,12 @@ ;;; Communicate with output-protocol what the new text constraints are. -(defmethod note-sheet-region-changed ((pane clim-pane-stream-mixin) &key &allow-other-keys) +(defmethod note-sheet-region-changed :after ((pane clim-pane-stream-mixin) &key &allow-other-keys) (let ((viewport (pane-viewport pane))) - (when viewport - (setf (stream-default-text-margin pane) - (bounding-rectangle-width (sheet-region (pane-viewport pane))))))) + (setf (stream-default-text-margin pane) + (if viewport + (bounding-rectangle-width (sheet-region (pane-viewport pane))) + (bounding-rectangle-width pane))))) ;;; Communicate with output-protocol what the new text constraints are. diff --git a/clim/menus.lisp b/clim/menus.lisp index d103a1c8e591027b6982a598eecc729e476cff59..51c37105bf4883322272c736fd57861bb6114e97 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: menus.lisp,v 1.7 92/01/31 14:58:22 cer Exp Locker: cer $ +;; $fiHeader: menus.lisp,v 1.8 92/02/05 21:45:43 cer Exp Locker: cer $ (in-package :clim-internals) @@ -20,6 +20,8 @@ nil))))) (:menu-bar nil)) +(defmethod frame-calling-frame ((frame menu-frame)) + *application-frame*) (defun get-menu (&key server-path) (let ((frame (make-application-frame 'menu-frame))) @@ -110,23 +112,18 @@ (gh (bounding-rectangle-height (sheet-region graft))) (width (min gw (+ (- maxx minx) right-margin))) (height (min gh (+ (- maxy miny) bottom-margin)))) - (change-space-requirement menu :width width :height height) - ;; --- Damn. How do we get this to propagate the size change up - ;; the tree so that the whole frame gets re-size to the pane? - ;; For now, kludge it by setting the frame size directly. - ;; Allow for scroll bar width - - (layout-frame (pane-frame menu)) - - ;; (when vw (change-space-requirement vw :hs width :vs height)) - ;; (resize-sheet* menu width height) - (silica::clear-space-requirement-caching-in-ancestors menu) - ;; --- RR needs to fix this at some point. - ;; --- It has to do with the viewport having a bad scrolling transform - ;; after a resize. - #+ignore - (setf (sheet-transformation (sheet-parent menu)) - (make-translation-transformation 0 0)))))) + (window-set-inside-size menu width height) + (window-set-viewport-position* menu minx miny))))) + +;;;---- should be somewhere else + +(defmethod (setf window-label) (nv window) + nil) + +(defun window-set-inside-size (menu width height) + (change-space-requirement menu :width width :height height) + (silica::clear-space-requirement-caching-in-ancestors menu) + (layout-frame (pane-frame menu))) #-Silica (defun position-window-near-carefully (window x y) diff --git a/notes/clim.todo b/notes/clim.todo index 0526f07909d1675e60260ba5ad7bb64b230015cf..4919de37e906c2f4f50353f0e705549eb173253d 100644 --- a/notes/clim.todo +++ b/notes/clim.todo @@ -1,91 +1,195 @@ %% $fiHeader: clim.todo,v 1.1 92/02/10 17:51:12 cer Exp Locker: cer $ %%%%%%%%%%%%%%%%%%%%%%%%% CLIM 2.0 plan - -% Silica backends +% Silica back-ends * Genera + * Raw CLX * Xt - Motif - OpenLook * Postscript -% Performance - * Make use of volatile regions and transformations - * Simplify transformation classes - * (deftype coordinate () ) - * Ink caches - * Sheet region and transformation caches. - * Meet CLIM 1.0 performance goals - * Surpass CLIM 1.0 performance goals - -% Size issues - * Modularize with load on demand/required modules - - Regions - - Transformations - -% Holes to Fill-in - * Rename defsys package to clim-defsys - * Reinstate clipping regions - * Complete abstract gadgetsd - * Gesture stuff - * Reinstate Menubars - * Stream defprotocols - * Layout for gadgets within accepting-values - * Implement clean interface to throw-to-highlighted-presentation - * Interprocess communication, i.e one process to another to execute - a frame command. - * accepting-values :own-window architecture that allows integration - with toolkit dialogs - * Temporary-medium sheets - - medium accessors on a sheet with no medium? - - temporary medium need to have their state decached - * Sheet protocol +% Holes to fill in + * Rename DEFSYS package to CLIM-DEFSYS. + * Reinstate clipping regions. + * Complete abstract gadgets. + - Take whatever is needed from ILA CLIM in order to get the non-adaptive + gadgets together. + * Write a "null" frame manager that implements the same look and feel for all + ports. + - Genera's frame manager will inherit from this. + * Take the keyboard gesture stuff code from ILA CLIM, but make it more + cons-efficient. + * Reinstate CLIM 0.9's :MENU-GROUP, but call it :MENU-BAR. + - NIL means no menu bar. + - T means use the current command table. + - A symbol names the command table to use. + * Stream defprotocols: be sure that all of the sheet and medium protocol + functions are explicitly defined with DEFOPERATION so that the stream + trampolines are properly created. + * Layout for gadgets within ACCEPTING-VALUES. + * ACCEPTING-VALUES :OWN-WINDOW architecture that allows integration with + toolkit dialogs. + - For example, :OWN-WINDOW T dialogs should use a separate pane to hold the + Exit and Abort buttons. + * Implement clean interface to THROW-HIGHLIGHTED-PRESENTATION. + - SWM claims that it is already clean. Why do SWM and CER disagree? + * Interprocess communication, i.e., one process to another to execute a frame + command. + * Temporary-medium sheets. + - Medium accessors on a sheet with no medium? + - Temporary medium need to have their state decached. + * Sheet protocol. - Where do event queues come from? - - Repaint protocol: who clears the area, sets the clipping region - when doing the repaint. - - How do we deal with the case where a sheet as one children and its - mirror allows one children only but the sheet actually has two children - (frame (horizontally () () ())) - - What is the precise value returned by event-sheet? Does the - event-sheet accessor return the sheet that the event was - dispatched to? - * Why does input-protocol-mixin define an input-buffer? Whats wrong - with the sheet-event queue? - * Multiple-layouts need to allow different size reqs for the sheets - * Implement :compute size spec - * Protocol to compute to the wm the desired geometry of the frame - * The code for switching layouts needs to be cleanup - * When the viewport is resized in might need to be moved, for - example, if it becomes big enough to display the entire window: In - the allocate-space for viewport. + - Repaint protocol: who clears the area and sets the clipping region when + doing the repaint? + - How do we deal with the case where a sheet has one children and its + mirror allows one children only but the sheet actually has two children, + e.g., (FRAME (HORIZONTALLY () () ())). + - What is the precise value returned by EVENT-SHEET? Does the EVENT-SHEET + accessor return the sheet that the event was dispatched to? + * Why does INPUT-PROTOCOL-MIXIN define an input buffer? What's wrong with the + sheet event queue? + * Multiple layouts need to allow different size reqs for the sheets. + * The code for switching layouts needs to be cleaned up. + * Implement :COMPUTE size spec, that is, panes that get their size from the + size of the output in the pane. + * Implement compatibility code for CLIM 1.0's :LAYOUT language. + * Protocol to compute to the WM the desired geometry of the frame. + * When the viewport is resized in might need to be moved, for example, if it + becomes big enough to display the entire window: in the ALLOCATE-SPACE for + viewport. * Pointer documentation panes and other pane types, - * Gadget-enable/disable protocol + * Gadget enable/disable protocol. * Event protocol: - - Consider design of distribute-event - - timestamp - - native-region - * On demand scrollbars + - Consider design of DISTRIBUTE-EVENT. + - Timestamp. + - Native region. + * On-demand scrollbars. + * Should we do "stream relative" coordinates (as opposed to the current + "parent relative" scheme) for output records? It solves some problems, but + introduces others. + * Should we divide the drawing protocol into a medium and a port layer, or + should it be a single layer as Bill suggests? + * Spiff up the code for defining new graphics operators. + - DEFINE-GRAPHICS-OPERATOR is like DEFGENERIC. + - DEFINE-GRAPHICS-METHOD is like DEFMETHOD. + - DEFINE-GRAPHICS-RECORDING. + - What of this goes into the spec? + * Figure out what things are part of the frame manager protocol and which are + part of the port protocol. + - PORT-MENU-CHOOSE should really be FRAME-MANAGER-MENU-CHOOSE. + - Ditto, PORT-DIALOG-VIEW. + * Figure out how views really interact with frame managers and dialogs. + - Indirect views. + * Implement more of DRAW-DESIGN for composites. + - Create a table that describes what works and what doesn't, for each port. + * Figure out which WINDOW-xxx functions from CLIM 1.0 make sense. It's OK to + change the names to correspond to newthink. + - WINDOW-VIEWPORT + - WINDOW-VIEWPORT-POSITION* and WINDOW-SET-VIEWPORT-POSITION*. + - WINDOW-INSIDE-xxx and WINDOW-SET-INSIDE-xxx. -% Bugs to fix. - * whats the problem with radio-boxes and move-cursor-after. The - alternative definitions almost work except for exit-buttons. I - think the bounding rectangle of gadget output records is computed - incorrectly and that it works because the update-gadget-position - is broken to match. +% Cleanups + * What should we retain from previous versions of CLIM? + - Go through CLIM 1.0 to make sure we didn't miss anything. + - Go through ILA CLIM with a fine-tooth comb. + * Flush all of the DRAW-xxx-INTERNAL junk. + * Find all the #+Silica/#-Silica stuff. + - Make sure that the #+Silica branch really does the right thing. + - Flush the #-Silica branch. + * Must we really convert all of the code to lowercase? Do it if we must. + * Sort out the whole server path mechanism and make sure we can + windows where we want. + +% Bugs to fix + * What's the problem with radio-boxes and move-cursor-after. The alternative + definitions almost work except for exit-buttons. I think the bounding + rectangle of gadget output records is computed incorrectly and that it + works because the update-gadget-position is broken to match. + * No output-recording for draw-text*. Hence the compass menu is + broken. + * why? #<standard-method stream-read-char-no-hang (motif-top-level-sheet) @ #x1b18eee> + * When default-text-margin slot yet bound. Drawing on a unexposed window + can cause problems. + +% Performance + * Meet CLIM 1.0 performance goals. + * Surpass CLIM 1.0 performance goals. + * Simplify transformation classes so that there is a single class of + transformation. Special-case +IDENTITY-TRANSFORMATION+. + * Make use of volatile transformations. + - Be careful never to modify +IDENTITY-TRANSFORMATION+. + * Make use of volatile rectangular regions. + * Reinstate sheet region and transformation caches (as in ILA CLIM). + * Add port-level caches for inks. + * (deftype coordinate () ...) + - Flush all inappropriate FIXNUM declarations from the code and replace them + with the new COORDINATE declaration. + - Look at callers of FLOOR, CEILING, TRUNCATE, and ROUND, and decide what of + those really mean to coerce to the COORDINATE type. + - The per-port code will needs to "devicize" all coordinates. For example, + for CLX that means integerizing, but not for PostScript. + * Reinstate graphics function optimizers. + - Is any of the CLIM 1.0 graphics-defining stuff useful? + - Is any of the ILA CLIM graphics-defining stuff useful? + +% Size issues + * Modularize with load on demand/required modules + - Extended geometry (lines, ellipses, polygons). + - DRAW-DESIGN and MAKE-DESIGN-FROM-OUTPUT-RECORD. + - Some formatted output stuff: graph formatting, FILLING-OUTPUT. % Specification - * what happens when you draw on a sheet that is not grafted? + * Write up the Silica API and protocol. + * Write up the gadget API and protocol. + - Document new callback function architecture. + * Specify and implement DEFINE-PANE-TYPE. + - Implement all of the CLIM 1.0 pane types. + * Write up the application frame and pane API and protocol. + - Include the layout protocol. + - What about RWK's "mosaics"? + * Rename all of the "POSITION*" functions to "POSITION", because a "position" + is unambiguously an (X,Y) pair. That is, POSITION, POSITION*, and POINT* + all mean the same thing. + - Update the code accordingly. + * What happens when you draw on a sheet that is not grafted? * Who enables a frame? - - run-frame-top-level or - - default-frame-top-level?? - * document new callback function architecture. - * Who calls realized mirror? - * enable-mirror and enable->mirror, mirror->enable? - * sheet-region/transformation can change for two reasons: program - does a setf or the port sends a configure notify. Should we use - that :port-trigger keyword in the notification protocol? + - RUN-FRAME-TOP-LEVEL? + - or DEFAULT-FRAME-TOP-LEVEL? + - The "command loop" proposal needs to explicitly address this. + * Who calls REALIZE-MIRROR? + * ENABLE-MIRROR and ENABLE->MIRROR, MIRROR->ENABLE? + * SHEET-REGION/TRANSFORMATION can change for two reasons: program does a SETF + or the port sends a configure notify. Should we use that :PORT-TRIGGER + keyword in the notification protocol? + * Enumerate the implicit inputs to all functions. + - *APPLICATION-FRAME* + - *INPUT-CONTEXT* and *NULL-PRESENTATION* + - *COMMAND-PARSER*, *COMMAND-UNPARSER*, and *PARTIAL-COMMAND-PARSER* + - *UNSUPPLIED-ARGUMENT-MARKER* and *NUMERIC-ARGUMENT-MARKER* + - *NUMERIC-ARGUMENT* + - *DELIMITER-GESTURES* and *ACTIVATION-GESTURES* + - *COMPLETION-GESTURES*, *HELP-GESTURES*, and *POSSIBILITIES-GESTURES* + - *ABORT-GESTURES* and *ACCELERATOR-GESTURES* + - *INPUT-WAIT-TEST* and *INPUT-WAIT-HANDLER* + - *POINTER-BUTTON-PRESS-HANDLER* + - *DEFAULT-TEXT-STYLE*, *NULL-TEXT-STYLE*, and *UNDEFINED-TEXT-STYLE* + * Unify the sheet and output record protocols by giving the same name to + generic functions that (conceptually) do the same thing. This could lay the + groundwork for tighter unification later, and costs us very little. + - SHEET-ADOPT-CHILD and ADD-OUTPUT-RECORD + - SHEET-DISOWN-CHILD and DELETE-OUTPUT-RECORD + - SHEET-PARENT and OUTPUT-RECORD-PARENT + - SHEET-CHILDREN and OUTPUT-RECORD-CHILDREN + - The mapping functions. + - SHEET-REGION and BOUNDING-RECTANGLE* + - What else? + +% User Guide. -% User Guide % Demos and example code. -% Franz specific stuff + +% Franz specific stuff. + % [todo: /vapor/usr/tech/cer/todo/franz-clim.todo] diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 650a70f84bf45217a42fffd35fdd7e28e756b55e..6a136c38ca8707f49fc9d9062dc8221d1b4419ab 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Syntax: Common-Lisp; Base: 10; Package: CLIM-USER; Mode: LISP; Lowercase: T -*- -;; $fiHeader: test-suite.lisp,v 1.7 92/01/31 14:59:04 cer Exp Locker: cer $ +;; $fiHeader: test-suite.lisp,v 1.8 92/02/05 21:45:54 cer Exp Locker: cer $ (in-package :clim-user) @@ -1601,7 +1601,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (draw-\\-diagonal t) (line-thickness 1) (line-thickness-units :normal)) - (accepting-values (stream) + (accepting-values (stream :own-window t) (setq square-dimension (accept 'number :stream stream :prompt "Size of square" :default square-dimension)) diff --git a/test/test.lisp b/test/test.lisp index 88867b43d6d731b7272192e78c542f587eb98b02..ca0dbd003a98810875d9d6c6ec4812e8deb66c3d 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -224,7 +224,7 @@ (letf-globally (((stream-default-view stream) (if textual-view +textual-dialog-view+ - +gadget-dialog-view+))) + (stream-default-view stream)))) (setq a (accept 'boolean :stream stream :default a @@ -246,6 +246,7 @@ :prompt "d" :default d)) (terpri stream) + #+ignore (accept-values-command-button (stream) "Press me" (setq a t b nil c :normal)))) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index a2c59b707a2dbd5b2cc15ecf1f3934375fa24f1b..ffc2d20a0b826f3584554e364c187f5fac086c03 100644 --- a/tk-silica/ol-gadgets.lisp +++ b/tk-silica/ol-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-gadgets.lisp,v 1.2 92/01/31 14:56:15 cer Exp Locker: cer $ +;; $fiHeader: ol-gadgets.lisp,v 1.3 92/02/05 21:45:22 cer Exp Locker: cer $ (in-package :xm-silica) @@ -59,7 +59,9 @@ silica::scrollbar) ()) -(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) +(defmethod find-widget-class-and-initargs-for-sheet ((port + openlook-port) + (parent t) (sheet openlook-scrollbar)) (with-accessors ((orientation silica::gadget-orientation)) sheet (values 'tk::scrollbar @@ -158,6 +160,11 @@ 'sheet-mirror-resized-callback sheet)) +(warn "This is really bogus") + +(defmethod stream-read-char-no-hang ((x openlook-top-level-sheet)) + nil) + (defmethod allocate-space ((sheet openlook-top-level-sheet) width height) (silica::resize-sheet* (car (sheet-children sheet)) width height)) @@ -165,7 +172,9 @@ (defmethod compose-space ((sheet openlook-top-level-sheet) &key width height) (compose-space (car (sheet-children sheet)))) -(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) +(defmethod find-widget-class-and-initargs-for-sheet ((port + openlook-port) + (parent t) (sheet openlook-top-level-sheet)) (values 'tk::draw-area (list :layout :ignore))) @@ -201,7 +210,9 @@ vp)) -(defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) (sheet ol-viewport)) +(defmethod find-widget-class-and-initargs-for-sheet ((port + openlook-port) + (parent t)(sheet ol-viewport)) (values 'tk::draw-area '(:layout :ignore))) @@ -237,3 +248,57 @@ ; 'sheet-mirror-event-handler ; sheet) ) + +(defclass openlook-menu-bar (xt-leaf-pane) + ((command-table :initarg :command-table))) + +(defmethod find-widget-class-and-initargs-for-sheet (port + (parent t) + (sheet openlook-menu-bar)) + (values 'tk::control nil)) + +(defmethod realize-mirror :around ((port openlook-port) (sheet openlook-menu-bar)) + + ;; This code fills the menu-bar. If top level items do not have + ;; submenus then it creates one with a menu of its own + + (let ((mirror (call-next-method))) + (labels ((make-menu-for-command-table (command-table parent top) + (map-over-command-table-menu-items + #'(lambda (menu keystroke item) + (declare (ignore keystroke)) + (let ((type (command-menu-item-type item))) + (case type + (:divider) + (:function + ;;--- Do this sometime + ) + (:menu + (let* ((mb (make-instance 'tk::menu-button + :parent parent + :label menu))) + (make-menu-for-command-table + (find-command-table (second item)) + (tk::get-values mb :menu-pane) + nil))) + (t + (let ((button + (make-instance 'tk::oblong-button + :label menu + :managed t + :parent parent))) + (tk::add-callback + button + :select + 'command-button-callback-ol + (slot-value sheet 'silica::frame) + item)))))) + command-table))) + (make-menu-for-command-table + (slot-value sheet 'command-table) + mirror + t)) + mirror)) + +(defun command-button-callback-ol (button frame item) + (command-button-callback button nil frame item)) diff --git a/tk-silica/ol-silica.lisp b/tk-silica/ol-silica.lisp index 4aa550d019622c88845da18d6d4c87a460346a50..d942a1cd635cb974ff72bef6f807692548968960 100644 --- a/tk-silica/ol-silica.lisp +++ b/tk-silica/ol-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-silica.lisp,v 1.2 92/01/31 14:56:19 cer Exp Locker: cer $ +;; $fiHeader: ol-silica.lisp,v 1.3 92/02/05 21:45:23 cer Exp Locker: cer $ (in-package :xm-silica) @@ -30,6 +30,9 @@ (defmethod find-port-type ((type (eql :openlook))) 'openlook-port) +(warn "Changing the default server path to ~S" + (setq silica::*default-server-path* '(:openlook :display "localhost:0"))) + (defmethod port-note-cursor-change ((port openlook-port) cursor stream diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 6514b103eb5825a2c942c2f045e77bfed7fd2d42..067713e8b9da1887e021754e6957d8dc2741b851 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-frames.lisp,v 1.6 92/01/31 14:56:27 cer Exp Locker: cer $ +;; $fiHeader: xm-frames.lisp,v 1.7 92/02/05 21:45:25 cer Exp Locker: cer $ (in-package :xm-silica) @@ -144,22 +144,14 @@ -(defmethod clim-internals::frame-wrapper ((frame t) (framem motif-frame-manager) pane) - (let ((mb (slot-value frame 'clim-internals::menu-bar))) - (if mb - (with-look-and-feel-realization (framem frame) - (vertically () - (realize-pane 'menu-bar - :command-table (if (eq mb t) - (frame-command-table frame) - (find-command-table mb))) - (call-next-method))) - (call-next-method)))) + (defclass motif-menu-bar (xt-leaf-pane) ((command-table :initarg :command-table))) -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-menu-bar)) +(defmethod find-widget-class-and-initargs-for-sheet (port + (parent t) + (sheet motif-menu-bar)) (values 'tk::xm-menu-bar (list :resize-height t :resize-width t))) @@ -227,29 +219,7 @@ t)) mirror)) -(defclass presentation-event (event) - ((value :initarg :value :reader presentation-event-value) - (sheet :initarg :sheet :reader event-sheet))) - -(defmethod handle-event (sheet (event presentation-event)) - (throw-highlighted-presentation - (make-instance 'standard-presentation - :object (presentation-event-value event) - :type 'command) - *input-context* - (make-instance 'pointer-button-press-event - :sheet sheet - :x 0 - :y 0 - :modifiers 0 - :button 256))) -(defun command-button-callback (button dunno frame item) - (distribute-event - (sheet-port frame) - (make-instance 'presentation-event - :sheet (frame-top-level-sheet frame) - :value (second item)))) (defmethod port-dialog-view ((port motif-port)) +gadget-dialog-view+) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index ccf9f1693424d53ae5e669319e8ef64bda5b59a8..ed92fc30605c215778ff18a2c44b49c2c4abedf4 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.8 92/02/05 21:45:26 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.9 92/02/08 14:51:40 cer Exp Locker: cer $ (in-package :xm-silica) @@ -105,7 +105,9 @@ -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet motif-push-button)) +(defmethod find-widget-class-and-initargs-for-sheet (port + (parent t) + (sheet motif-push-button)) (declare (ignore port)) (with-accessors ((label silica::gadget-label)) sheet (values 'tk::xm-push-button @@ -146,6 +148,7 @@ ()) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) (sheet motif-drawing-area)) (values 'tk::xm-drawing-area (list :margin-width 0 :resize-policy :none @@ -163,7 +166,9 @@ ()) -(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (sheet motif-slider)) +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) + (sheet motif-slider)) (with-accessors ((orientation silica::gadget-orientation) (label silica::gadget-label) (value gadget-value)) sheet @@ -200,6 +205,7 @@ ()) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) (sheet motif-scrollbar)) (with-accessors ((orientation silica::gadget-orientation)) sheet (values 'tk::xm-scroll-bar @@ -279,31 +285,8 @@ (defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-top-level-sheet) - widget) - -; (tk::add-callback widget -; :expose-callback -; 'sheet-mirror-exposed-callback -; sheet) -; (tk::add-callback widget -; :input-callback -; 'sheet-mirror-input-callback -; sheet) -; (tk::add-event-handler widget -; '(:enter-window -; :leave-window -; :pointer-motion-hint -; :pointer-motion -; :button1-motion -; :button2-motion -; :button3-motion -; :button4-motion -; :button5-motion -; :button-motion -; ) -; 0 -; 'sheet-mirror-event-handler -; sheet) + (widget tk::xm-drawing-area)) + (tk::add-callback widget :resize-callback 'sheet-mirror-resized-callback @@ -315,14 +298,51 @@ (defmethod compose-space ((sheet motif-top-level-sheet) &key width height) (compose-space (car (sheet-children sheet)) :width width :height height)) +;;;-- Test whether this is a dialog box or -(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) - (sheet motif-top-level-sheet)) - (values 'tk::xm-drawing-area - (list :resize-policy :none - :margin-width 0 :margin-height 0))) +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) + (sheet + motif-top-level-sheet)) + (cond + ;;--- hack alert + ;; Seems that we need to use a bulletin board so that everything + ;; comes up in the right place. + ((popup-frame-p sheet) + (values 'tk::xm-bulletin-board + nil)) + (t + (values 'tk::xm-drawing-area + (list :resize-policy :none + :margin-width 0 :margin-height 0))))) + +;;; + +(defmethod add-sheet-callbacks :after ((port motif-port) (sheet t) (widget tk::xm-bulletin-board)) + (tk::add-event-handler widget + '(:enter-window + :leave-window + :pointer-motion-hint + :pointer-motion + :button1-motion + :button2-motion + :button3-motion + :button4-motion + :button5-motion + :button-motion + :exposure + :structure-notify + :key-press + :key-release + :button-press + :button-release + ) + 0 + 'sheet-mirror-event-handler + sheet)) + ;;;; text field (defclass motif-text-field (xt-leaf-pane @@ -331,6 +351,7 @@ ()) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) (sheet motif-text-field)) (with-accessors ((value gadget-value)) sheet (values 'tk::xm-text-field @@ -346,6 +367,7 @@ ()) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) (sheet motif-toggle-button)) (with-accessors ((set gadget-value) (label silica::gadget-label) @@ -369,32 +391,8 @@ (defmethod xm-silica::add-sheet-callbacks :after ((port motif-port) (sheet clim-internals::extended-stream-sheet) - (widget t)) - (declare (ignore sheet)) -; (tk::add-callback widget -; :expose-callback -; 'sheet-mirror-exposed-callback -; sheet) -; (tk::add-callback widget -; :input-callback -; 'sheet-mirror-input-callback -; sheet) -; (tk::add-event-handler widget -; '(:enter-window -; :leave-window -; :pointer-motion-hint -; :pointer-motion -; :button1-motion -; :button2-motion -; :button3-motion -; :button4-motion -; :button5-motion -; :button-motion -; ) -; 0 -; 'sheet-mirror-event-handler -; sheet) - ;; It would suprise me if we needed this. + (widget tk::xm-drawing-area)) + ;;---- It would suprise me if we needed this. (tk::add-callback widget :resize-callback 'sheet-mirror-resized-callback @@ -463,45 +461,25 @@ vp)) -(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (sheet xm-viewport)) +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) + (sheet xm-viewport)) (values 'tk::xm-drawing-area '(:scrolling-policy :application-defined :margin-width 0 :margin-height 0 :resize-policy :none :scroll-bar-display-policy :static))) -(defmethod add-sheet-callbacks :after ((port motif-port) (sheet xm-viewport) widget) - ;; I wonder whether this is needed since it should not be resized by +(defmethod add-sheet-callbacks :after ((port motif-port) + (sheet xm-viewport) + (widget tk::xm-drawing-area)) + ;;--- I wonder whether this is needed since it should not be resized by ;; the toolkit and only as part of the goe management code that will ;; recurse to children anyway (tk::add-callback widget :resize-callback 'sheet-mirror-resized-callback - sheet) -; (tk::add-callback widget -; :expose-callback -; 'sheet-mirror-exposed-callback -; sheet) -; (tk::add-callback widget -; :input-callback -; 'sheet-mirror-input-callback -; sheet) -; (tk::add-event-handler widget -; '(:enter-window -; :leave-window -; :pointer-motion-hint -; :pointer-motion -; :button1-motion -; :button2-motion -; :button3-motion -; :button4-motion -; :button5-motion -; :button-motion -; ) -; 0 -; 'sheet-mirror-event-handler -; sheet) - ) + sheet)) (defclass motif-radio-box (motif-geometry-manager mirrored-sheet-mixin @@ -516,6 +494,7 @@ (setf (gadget-client child) gadget)) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) (sheet motif-radio-box)) (with-accessors ((orientation silica::gadget-orientation)) sheet @@ -544,6 +523,7 @@ ()) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) (sheet motif-frame-pane)) (values 'tk::xm-frame nil)) diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 796c6407500433c476b3484deafd18fcf6a2f045..39e1988902d912297f8570ade0a9c2223a91b4e9 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.6 92/01/31 14:56:35 cer Exp Locker: cer $ +;; $fiHeader: xm-silica.lisp,v 1.7 92/02/08 14:51:41 cer Exp Locker: cer $ (in-package :xm-silica) @@ -50,18 +50,25 @@ (setf (silica::port-keyboard-focus port) (and new stream))) - -(defmethod change-widget-geometry (parent child &rest args) - (declare (ignore parent)) - ;; In this case let the parent deal with it - (apply #'tk::set-values child args)) - (defmethod change-widget-geometry ((parent tk::xm-drawing-area) child &rest args &key x y width height) (declare (ignore x y width height)) (apply #'tk::configure-widget child args)) +(defmethod change-widget-geometry ((parent tk::xm-bulletin-board) child + &rest args + &key x y width height) + (declare (ignore x y width height)) + (apply #'tk::configure-widget child args)) + +(defmethod change-widget-geometry ((parent tk::shell) child + &rest args + &key x y width height) + (declare (ignore x y args)) + ;;-- shells decide where windows are positioned! + (tk::set-values child :width width :height height)) + (defclass motif-geometry-manager () ;; --- This is probably all ;; composites excepts drawing-area and shell @@ -95,3 +102,15 @@ about their children")) (defmethod update-geo-manager-sheet-children (geo-manager) (dolist (child (sheet-children geo-manager)) (mirror-region-updated (sheet-port geo-manager) child))) + +(defmethod find-shell-class-and-initargs ((port motif-port) sheet) + (declare (ignore port)) + (cond ( ;;--- hack alert + (popup-frame-p sheet) + (values 'xm-dialog-shell + (append + (let ((x (find-shell-of-calling-frame sheet))) + (and x `(:transient-for ,x))) + '(:keyboard-focus-policy :pointer)))) + (t + (call-next-method)))) diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index a634e6c5c66a8f78ec6cda3ce2680c26f051ab62..e530c1d5b9c24b70418de34203bd66b4231546c4 100644 --- a/tk-silica/xt-frames.lisp +++ b/tk-silica/xt-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-frames.cl,v 1.1 92/01/17 17:48:17 cer Exp $ +;; $fiHeader: xt-frames.lisp,v 1.2 92/01/31 14:56:37 cer Exp Locker: cer $ (in-package :xm-silica) @@ -51,3 +51,43 @@ (setf (frame-top-level-sheet frame) sheet (frame-shell frame) (sheet-shell sheet)) (sheet-adopt-child sheet (frame-panes frame))))) + + +(defmethod clim-internals::frame-wrapper ((frame t) (framem xt-frame-manager) pane) + (declare (ignore pane)) + (let ((mb (slot-value frame 'clim-internals::menu-bar))) + (if mb + (with-look-and-feel-realization (framem frame) + (vertically () + (realize-pane 'menu-bar + :command-table (if (eq mb t) + (frame-command-table frame) + (find-command-table mb))) + (call-next-method))) + (call-next-method)))) + +;;; + +(defclass presentation-event (event) + ((value :initarg :value :reader presentation-event-value) + (sheet :initarg :sheet :reader event-sheet))) + +(defmethod handle-event (sheet (event presentation-event)) + (throw-highlighted-presentation + (make-instance 'standard-presentation + :object (presentation-event-value event) + :type 'command) + *input-context* + (make-instance 'pointer-button-press-event + :sheet sheet + :x 0 + :y 0 + :modifiers 0 + :button 256))) + +(defun command-button-callback (button dunno frame item) + (distribute-event + (sheet-port frame) + (make-instance 'presentation-event + :sheet (frame-top-level-sheet frame) + :value (second item)))) diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index e664091cbb57f7b8d405daf6e4ce807a45c4e332..0e1433586851cc3fba1b78f29db88e3aba323f27 100644 --- a/tk-silica/xt-gadgets.lisp +++ b/tk-silica/xt-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-gadgets.lisp,v 1.2 92/01/31 14:56:38 cer Exp Locker: cer $ +;; $fiHeader: xt-gadgets.lisp,v 1.3 92/02/05 21:45:29 cer Exp Locker: cer $ (in-package :xm-silica) @@ -58,6 +58,7 @@ (defmethod find-widget-class-and-initargs-for-sheet :around ((port xt-port) + (parent t) (sheet silica::foreground-background-and-text-style-mixin)) (multiple-value-bind @@ -135,6 +136,7 @@ (defun clim-internals::scroll-extent (stream &key (x 0) (y 0)) (let ((vp (clim-internals::pane-viewport stream))) + (when vp (with-bounding-rectangle* (left top right bottom) (clim-internals::pane-viewport-region stream) ;;;---- This should actually bash the sheet-transformation @@ -180,7 +182,7 @@ (replay (stream-output-history stream) stream - (silica::xm-viewport-viewport vp)))))))) + (silica::xm-viewport-viewport vp))))))))) (defclass xt-pane (silica::pane) ()) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 200eca3968e43f15a03184b302d262d1be4da8fb..e6f339e8a9e6e96bc101a10832e6fa46bcd7c7af 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.4 92/01/31 16:22:09 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.5 92/02/05 21:45:30 cer Exp Locker: cer $ (in-package :xm-silica) @@ -542,7 +542,7 @@ (width (- from-right from-left)) (height (- from-bottom from-top)) (copy-gc (port-copy-gc port))) - (when (and from-medium to-medium) + (when (and from-window to-window) (tk::copy-area from-window copy-gc from-left from-top width height to-window to-left to-top))))))) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index f1e3b2e521cfe74bc6b6716ff6925a1becc4cef2..907b5817a52e1c72440c04c2dd32876d36c11f02 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.4 92/02/05 21:45:32 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.5 92/02/08 14:51:43 cer Exp Locker: cer $ (in-package :xm-silica) @@ -165,15 +165,16 @@ (tk::destroy-widget (sheet-direct-mirror sheet))) (defmethod realize-mirror ((port xt-port) sheet) - (multiple-value-bind - (class initargs) - (find-widget-class-and-initargs-for-sheet port sheet) - (let ((widget (apply #'make-instance class - :parent (find-widget-parent port sheet) - :managed (sheet-enabled-p sheet) - initargs))) - (add-sheet-callbacks port sheet widget) - widget))) + (let ((parent (find-widget-parent port sheet))) + (multiple-value-bind + (class initargs) + (find-widget-class-and-initargs-for-sheet port parent sheet) + (let ((widget (apply #'make-instance class + :parent parent + :managed (sheet-enabled-p sheet) + initargs))) + (add-sheet-callbacks port sheet widget) + widget)))) (defmethod add-sheet-callbacks ((port xt-port) sheet (widget t)) (declare (ignore sheet))) @@ -185,74 +186,90 @@ (declare (ignore same-p root child root-x root-y)) (let ((modifiers (logand #16rff mask)) (button (ash mask -8))) - (distribute-event - (sheet-port sheet) - (ecase (tk::event-type event) - (:key-press - (multiple-value-bind - (ignore character keysym) - (tk::lookup-string event) - (declare (ignore ignore)) - (make-instance 'key-press-event - :key-name keysym - :character (and (= (length character) 1) - (aref character 0)) - :sheet sheet - :modifiers (x11::xkeyevent-state event)))) + (let ((clim-event + (ecase (tk::event-type event) + ((:map-notify :unmap-notify) + nil) + (:configure-notify + (sheet-mirror-resized-callback + widget nil event sheet) + nil) + (:expose + (sheet-mirror-exposed-callback + widget + nil ; window + event + sheet) + nil) + (:key-press + (multiple-value-bind + (ignore character keysym) + (tk::lookup-string event) + (declare (ignore ignore)) + (make-instance 'key-press-event + :key-name keysym + :character (and (= (length character) 1) + (aref character 0)) + :sheet sheet + :modifiers (x11::xkeyevent-state event)))) - (:key-release - (multiple-value-bind - (ignore character keysym) - (tk::lookup-string event) - (declare (ignore ignore)) - (make-instance 'key-release-event - :key-name keysym - :character (and (= (length character) 1) - (aref character 0)) - :sheet sheet - :modifiers (x11::xkeyevent-state event)))) + (:key-release + (multiple-value-bind + (ignore character keysym) + (tk::lookup-string event) + (declare (ignore ignore)) + (make-instance 'key-release-event + :key-name keysym + :character (and (= (length character) 1) + (aref character 0)) + :sheet sheet + :modifiers (x11::xkeyevent-state event)))) - (:button-press - (make-instance 'pointer-button-press-event - :sheet sheet - :x :?? - :y :?? - :modifiers (x11::xkeyevent-state event) - :button (x-button->silica-button - (x11::xbuttonevent-button event)) - :native-x (x11::xbuttonevent-x event) - :native-y (x11::xbuttonevent-y event))) - (:button-release - (make-instance 'pointer-button-release-event - :sheet sheet - :x :?? - :y :?? - :modifiers (x11::xkeyevent-state event) - :button (x-button->silica-button - (x11::xbuttonevent-button event)) - :native-x (x11::xbuttonevent-x event) - :native-y (x11::xbuttonevent-y event))) - (:leave-notify - (make-instance 'pointer-exit-event - :native-x native-x - :native-y native-y - :button (x-button->silica-button button) - :modifiers modifiers - :sheet sheet)) - (:enter-notify - (make-instance 'pointer-enter-event - :native-x native-x - :native-y native-y - :button (x-button->silica-button button) - :modifiers modifiers - :sheet sheet)) - (:motion-notify - (make-instance 'pointer-motion-event - :native-x native-x - :native-y native-y - :button (x-button->silica-button button) - :modifiers modifiers - :sheet sheet))))))) + (:button-press + (make-instance 'pointer-button-press-event + :sheet sheet + :x :?? + :y :?? + :modifiers (x11::xkeyevent-state event) + :button (x-button->silica-button + (x11::xbuttonevent-button event)) + :native-x (x11::xbuttonevent-x event) + :native-y (x11::xbuttonevent-y event))) + (:button-release + (make-instance 'pointer-button-release-event + :sheet sheet + :x :?? + :y :?? + :modifiers (x11::xkeyevent-state event) + :button (x-button->silica-button + (x11::xbuttonevent-button event)) + :native-x (x11::xbuttonevent-x event) + :native-y (x11::xbuttonevent-y event))) + (:leave-notify + (make-instance 'pointer-exit-event + :native-x native-x + :native-y native-y + :button (x-button->silica-button button) + :modifiers modifiers + :sheet sheet)) + (:enter-notify + (make-instance 'pointer-enter-event + :native-x native-x + :native-y native-y + :button (x-button->silica-button button) + :modifiers modifiers + :sheet sheet)) + (:motion-notify + (make-instance 'pointer-motion-event + :native-x native-x + :native-y native-y + :button (x-button->silica-button button) + :modifiers modifiers + :sheet sheet))))) + (when clim-event + (distribute-event + (sheet-port sheet) + clim-event)))))) (defun x-button->silica-button (button) (ecase button @@ -351,20 +368,24 @@ :native-x (x11::xbuttonevent-x event) :native-y (x11::xbuttonevent-y event)))))) -(defmethod find-widget-class-and-initargs-for-sheet (port (sheet sheet)) +(defmethod find-widget-class-and-initargs-for-sheet (port + (parent t) + (sheet sheet)) (declare (ignore port)) (values 'xm-drawing-area (list :resize-policy :grow))) -(defmethod find-widget-class-and-initargs-for-sheet :around (port (sheet sheet)) +(defmethod find-widget-class-and-initargs-for-sheet :around (port + (parent t) + (sheet sheet)) (declare (ignore port)) (multiple-value-bind (class initargs) (call-next-method) - (setq initargs (set-mirror-geometry sheet initargs)) + (setq initargs (set-mirror-geometry parent sheet initargs)) (values class initargs))) -(defmethod set-mirror-geometry (sheet initargs) +(defmethod set-mirror-geometry (parent sheet initargs) ;;--- Should we pass in the size of the sheet even though it is ;; liable to be quite stupid ;; We really want to just create the gadgets and then let the layout @@ -373,9 +394,12 @@ (multiple-value-bind (left top right bottom) (sheet-actual-native-edges sheet) - (setf (getf initargs :x) (floor left) - (getf initargs :y) (floor top) - (getf initargs :width) (floor (- right left)) + ;;--- We do not want to specify the x,y if this is a top-level + ;;sheet. + (unless (typep parent 'tk::shell) + (setf (getf initargs :x) (floor left) + (getf initargs :y) (floor top))) + (setf (getf initargs :width) (floor (- right left)) (getf initargs :height) (floor (- bottom top))))) initargs) @@ -389,23 +413,42 @@ (class initargs) (find-shell-class-and-initargs port sheet) (apply #'make-instance class - :parent (port-application-shell port) + :parent (find-shell-parent port sheet) initargs)) (sheet-mirror ma)))) +(defmethod find-shell-of-calling-frame ((sheet sheet)) + (find-shell-of-calling-frame (pane-frame sheet))) + +(defmethod find-shell-of-calling-frame ((frame application-frame)) + (let (cf) + (and (setq cf (clim-internals::frame-calling-frame frame)) + (sheet-shell (frame-top-level-sheet cf))))) + +(defmethod find-shell-parent (port sheet) + (or (and ;;--- hack alert + (popup-frame-p sheet) + (find-shell-of-calling-frame sheet)) + (port-application-shell port))) + + (defmethod find-shell-class-and-initargs (port sheet) + (declare (ignore port)) (values 'top-level-shell ;; Need this so that an interactive pane can have children ;; but still accept the focus '(:keyboard-focus-policy :pointer))) + + + (defmethod enable-mirror (port sheet) (declare (ignore port)) (let ((mirror (sheet-mirror sheet))) (typecase (widget-parent mirror) (null) - (top-level-shell - ;; this is a nasty hack just to make sure that the child is managed. + ((or top-level-shell tk::xm-dialog-shell) + ;;--- this is a nasty hack just to make sure that the child is managed. ;; top-level-sheets are created unmanaged because they are ;; disabled to we have to do not! (manage-child mirror) @@ -476,6 +519,8 @@ w (floor w) h (floor h)) (change-widget-geometry + ;;--- For top level sheets the sheet-parent is the graft whose + ;; mirror is the application shell (sheet-mirror (sheet-parent sheet)) (sheet-direct-mirror sheet) :x target-left @@ -589,3 +634,15 @@ (defmethod clim-internals::port-finish-output ((port xt-port)) nil) + +(defmethod change-widget-geometry (parent child &rest args) + (declare (ignore parent)) + ;; In this case let the parent deal with it + (apply #'tk::set-values child args)) + + +(defmethod popup-frame-p ((frame application-frame)) + (typep frame '(or clim-internals::menu-frame clim-internals::accept-values-own-window))) + +(defmethod popup-frame-p ((sheet sheet)) + (popup-frame-p (pane-frame sheet))) diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index 1c27f0095606c4f495697ef9391221250cabe34a..9407654aecf84741213e0ff773af7c559c9ba934 100644 --- a/tk/callbacks.lisp +++ b/tk/callbacks.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: callbacks.cl,v 1.4 92/01/17 17:49:05 cer Exp $ +;; $fiHeader: callbacks.lisp,v 1.5 92/01/31 14:54:14 cer Exp Locker: cer $ (in-package :tk) @@ -127,7 +127,7 @@ ;; OpenLook Callbacks ("sliderMoved" slider-moved) - + ("select") ))) (defun convert-callback-name (x) diff --git a/tk/event.lisp b/tk/event.lisp index 4b5f0012c4454c8ae88366aa32c88425d20d2960..40bc567b44b5995ae31810e3ce505066e170107d 100644 --- a/tk/event.lisp +++ b/tk/event.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: event.cl,v 1.2 92/01/02 15:08:38 cer Exp $ +;; $fiHeader: event.lisp,v 1.3 92/01/31 14:54:23 cer Exp Locker: cer $ (in-package :tk) @@ -35,6 +35,11 @@ (loop (process-one-event context))) +(defconstant *xt-im-xevent* 1) +(defconstant *xt-im-timer* 2) +(defconstant *xt-im-alternate-input* 4) +(defconstant *xt-im-all* (logior *xt-im-xevent* *xt-im-timer* *xt-im-alternate-input*)) + (defun process-one-event (context &key timeout wait-function) (let (mask (fds (mapcar #'(lambda (display) @@ -59,7 +64,11 @@ #'wait-function)))) (mapc #'multiprocessing::mpunwatchfor fds)) (cond ((plusp mask) - (app-process-event context mask) + (app-process-event + context + ;; Because of a feature in the OLIT toolkit we need to + ;; give preference to events rather than timer events + (if (logtest mask *xt-im-xevent*) *xt-im-xevent* mask)) t) (reason :wait-function) (t :timeout))))