diff --git a/demo/bitmap-editor.lisp b/demo/bitmap-editor.lisp index d8bdc167e2636e8ea7626420286881ce5f627d5d..17e334a33230b7c744a27ff1ab4b473d148f0dfc 100644 --- a/demo/bitmap-editor.lisp +++ b/demo/bitmap-editor.lisp @@ -21,7 +21,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: bitmap-editor.lisp,v 1.6 92/10/07 14:43:14 cer Exp $ +;; $fiHeader: bitmap-editor.lisp,v 1.7 92/10/28 11:32:49 cer Exp $ (in-package :clim-demo) @@ -79,7 +79,7 @@ (formatting-cell (stream) (accept-values-command-button (stream) "Add Color" - (add-color-to-palette frame))) + (bitmap-editor-add-color-to-palette frame))) (formatting-cell (stream) (accept-values-command-button (stream) "Edit Color" @@ -98,7 +98,7 @@ ;;--- Exercise for the reader ) -(defun add-color-to-palette (frame) +(defun bitmap-editor-add-color-to-palette (frame) (let ((fr (make-application-frame 'color-chooser))) (run-frame-top-level fr) (with-slots (colors) frame diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 46211a6e9c4333b77be329e3a7015d8b3aeb7b5e..a8d99ca1a29e7635c1722a363df5af2c953f28cd 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -1,6 +1,6 @@ ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadgets.lisp,v 1.38 92/11/06 19:03:51 cer Exp $ +;; $fiHeader: gadgets.lisp,v 1.39 92/11/13 14:46:44 cer Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -110,6 +110,29 @@ (defmethod activate-callback ((gadget action-gadget) (client t) (id t)) nil) +(defclass focus-gadget (gadget) + ((focus-out-callback :initarg :focus-out-callback :initform nil + :reader gadget-focus-out-callback) + (focus-in-callback :initarg :focus-in-callback :initform nil + :reader gadget-focus-in-callback))) + +(defmethod focus-out-callback :around ((gadget focus-gadget) (client t) (id t)) + (let ((callback (gadget-focus-out-callback gadget))) + (if callback + (invoke-callback-function callback gadget) + (call-next-method)))) + +(defmethod focus-out-callback ((gadget focus-gadget) (client t) (id t)) + nil) + +(defmethod focus-in-callback :around ((gadget focus-gadget) (client t) (id t)) + (let ((callback (gadget-focus-in-callback gadget))) + (if callback + (invoke-callback-function callback gadget) + (call-next-method)))) + +(defmethod focus-in-callback ((gadget focus-gadget) (client t) (id t)) + nil) ;;; Basic gadgets-mixins @@ -349,6 +372,9 @@ (defmethod value-changed-callback :around ((selection gadget) (client radio-box) gadget-id value) (declare (ignore gadget-id)) + ;;--- The following comment is wrong. Perhaps these should be + ;; :BEFORE methods since the use could define a more specific around + ;; method only. ;; This and the one below have to be :AROUND because if the user has ;; specified a callback function only :AROUNDs ever get executed. (when (eq value t) @@ -407,7 +433,7 @@ ;;--- Do we want to specify a binding to commands? (defclass text-field - (value-gadget action-gadget) + (value-gadget focus-gadget action-gadget) ((editable-p :initarg :editable-p :accessor gadget-editable-p)) (:default-initargs :editable-p t)) @@ -646,6 +672,15 @@ (defmethod handle-event ((gadget action-gadget) (event activate-gadget-event)) (activate-callback gadget (gadget-client gadget) (gadget-id gadget))) +(defclass focus-out-gadget-event (gadget-event) ()) + +(defmethod handle-event ((gadget focus-gadget) (event focus-out-gadget-event)) + (focus-out-callback gadget (gadget-client gadget) (gadget-id gadget))) + +(defclass focus-in-gadget-event (gadget-event) ()) + +(defmethod handle-event ((gadget focus-gadget) (event focus-in-gadget-event)) + (focus-in-callback gadget (gadget-client gadget) (gadget-id gadget))) (defclass drag-gadget-event (gadget-event) ((value :initarg :value :reader event-value))) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 81d8e365405638abf9544cf8599c3e8b94023855..cd68b20043d1fb72a978e2348416d0e25b0bc4e6 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.56 92/11/09 19:56:00 cer Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.57 92/11/13 14:47:16 cer Exp $ (in-package :xm-silica) @@ -68,7 +68,7 @@ ;;; Motif widgets that support the value-changed callback -(defclass motif-value-changed-callback-pane () ()) +(defclass motif-value-changed-callback-pane (motif-value-pane) ()) (defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-value-changed-callback-pane) (widget t)) @@ -79,13 +79,13 @@ ;;; Motif widgets that support the losing-focus callback -(defclass motif-losing-focus-callback-pane () ()) +(defclass motif-losing-focus-callback-pane (motif-value-pane) ()) (defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-losing-focus-callback-pane) (widget t)) (tk::add-callback widget :losing-focus-callback - 'queue-value-changed-event + 'queue-losing-focus-event sheet)) ;; Gadgets that have a :label initarg @@ -203,8 +203,7 @@ ;;; range pane mixin -(defclass motif-range-pane (motif-value-pane - motif-value-changed-callback-pane) +(defclass motif-range-pane (motif-value-changed-callback-pane) ()) @@ -495,8 +494,8 @@ ;;;; text field -(defclass motif-text-field (motif-value-pane - motif-losing-focus-callback-pane +(defclass motif-text-field (motif-losing-focus-callback-pane + motif-value-changed-callback-pane motif-action-pane text-field xt-leaf-pane) @@ -513,10 +512,23 @@ `(:editable ,editable) (and value `(:value ,value)))))) +#+ignore +(defmethod add-sheet-callbacks :after + ((port motif-port) (sheet motif-text-field) (widget t)) + (tk::add-callback widget + :modify-verify-callback + 'queue-modify-verify-event + sheet)) + +#+ignore +(defmethod queue-modify-verify-event (widget doit sheet) + (format excl:*initial-terminal-io* "~&~s,~s,~s" widget doit sheet)) + + + ;;; -(defclass motif-text-editor (motif-value-pane - motif-losing-focus-callback-pane +(defclass motif-text-editor (motif-losing-focus-callback-pane motif-action-pane text-editor xt-leaf-pane) @@ -588,7 +600,6 @@ ;;; Toggle button (defclass motif-toggle-button (motif-labelled-gadget - motif-value-pane motif-value-changed-callback-pane toggle-button xt-leaf-pane) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 10bfe5b934d3bf4291a7a7a61f4a127e0eb38713..720ba76251d96bbf414d932b0f4c315171ec725b 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.50 92/11/06 19:04:40 cer Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.51 92/11/09 10:56:14 cer Exp $ (in-package :tk-silica) @@ -130,10 +130,14 @@ (setf (gethash name named-color-cache) (let ((xcolor (tk::lookup-color (palette-colormap palette) name)) (x #.(1- (ash 1 16)))) - (make-rgb-color (/ (x11:xcolor-red xcolor) x) - (/ (x11:xcolor-green xcolor) x) - (/ (x11:xcolor-blue xcolor) x))))))) - + (if xcolor + (make-rgb-color (/ (x11:xcolor-red xcolor) x) + (/ (x11:xcolor-green xcolor) x) + (/ (x11:xcolor-blue xcolor) x)) + (if errorp + (error 'color-not-found :color name) + (return-from find-named-color nil)))))))) + (defmethod update-palette-entry ((palette xt-palette) pixel color) (let ((xcolor (get-xcolor color palette))) (setf (x11:xcolor-pixel xcolor) pixel) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 9f8a67ba82a35092c4fcc9dcac3ffcac254754c2..27d3d418f5826d4470aecf2684744a6e3dff7f7f 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.56 92/11/06 19:04:44 cer Exp $ +;; $fiHeader: xt-silica.lisp,v 1.57 92/11/13 14:47:27 cer Exp $ (in-package :xm-silica) @@ -1397,6 +1397,22 @@ the geometry of the children. Instead the parent has control. ")) :gadget sheet :value value)))) +(defmethod queue-losing-focus-event (widget sheet) + (declare (ignore widget)) + (unless *dont-invoke-callbacks* + (distribute-event + (port sheet) + (allocate-event 'focus-out-gadget-event + :gadget sheet)))) + +(defmethod queue-gaining-focus-event (widget sheet) + (declare (ignore widget)) + (unless *dont-invoke-callbacks* + (distribute-event + (port sheet) + (allocate-event 'focus-in-gadget-event + :gadget sheet)))) + (defmethod queue-drag-event (widget sheet &optional (value (gadget-value sheet))) (declare (ignore widget)) (distribute-event diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index 65029fbc2dc0727fb47cef0a8bf82da4fbb5a9a6..82c9ba1245e018fe89c435ff516b855a17edc642 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.lisp,v 1.18 92/09/24 09:37:16 cer Exp $ +;; $fiHeader: callbacks.lisp,v 1.19 92/11/09 10:55:55 cer Exp $ (in-package :tk) @@ -118,7 +118,7 @@ ("toTopCallback") ("focusCallback") ("losingFocusCallback") - ("modifyVerifyCallback") + ("modifyVerifyCallback" :modify-verify) ("motionVerifyCallback") ("valueChangedCallback") ("noMatchCallback") @@ -143,6 +143,8 @@ ("gainPrimaryCallback") ("losePrimaryCallback") + ;; Motif Callbacks + ;; OpenLook Callbacks ("sliderMoved" slider-moved) ("select") @@ -161,6 +163,10 @@ (defmethod spread-callback-data (widget data (type (eql :activate))) (x-push-button-callback-struct-click-count data)) +(defmethod spread-callback-data (widget data (type (eql + :modify-verify))) + (xm-text-field-callback-struct-doit data)) + (defmethod spread-callback-data (widget call-data (type (eql 'drawing-area))) (values (x-drawing-area-callback-window call-data) (x-drawing-area-callback-event call-data))) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index e894490d58a8992b1d9867c7f8b3d1a32e32ad8d..61c656410f75338f072899225540cd1fe4f069e3 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.32 92/10/29 16:54:51 cer Exp $ +;; $fiHeader: xlib.lisp,v 1.33 92/11/06 19:04:21 cer Exp $ (in-package :tk) @@ -311,13 +311,12 @@ (defun lookup-color (colormap name) (let ((exact (x11::make-xcolor :in-foreign-space t)) (closest (x11::make-xcolor :in-foreign-space t))) - (if (zerop (x11:xlookupcolor - (object-display colormap) - colormap - name - exact - closest)) - (error "Could not find ~S in colormap ~S" name colormap) + (unless (zerop (x11:xlookupcolor + (object-display colormap) + colormap + name + exact + closest)) (values (make-instance 'color :foreign-address exact) (make-instance 'color :foreign-address closest))))) diff --git a/utils/designs.lisp b/utils/designs.lisp index fa30145adc2cc769fef8c053df4b4bfccd3f395b..f4dbecba68c3cb0b593923adf5770aafeb120e1f 100644 --- a/utils/designs.lisp +++ b/utils/designs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: designs.lisp,v 1.10 92/10/29 16:55:05 cer Exp $ +;; $fiHeader: designs.lisp,v 1.11 92/11/06 19:05:00 cer Exp $ (in-package :clim-utils) @@ -314,7 +314,7 @@ (format stream "The palette ~S is full" (palette-full-palette condition))))) -(defmethod add-colors-to-palette ((palette basic-palette) &rest colors) +(defmethod add-color-to-palette ((palette basic-palette) &rest colors) (declare (dynamic-extent colors)) (let ((colors-done nil)) (dolist (color colors) @@ -327,7 +327,7 @@ (deallocate-color color palette)) (error condition)))))) -(defmethod remove-colors-from-palette ((palette basic-palette) &rest colors) +(defmethod remove-color-from-palette ((palette basic-palette) &rest colors) (declare (dynamic-extent colors)) (dolist (color colors) (deallocate-color color palette))) diff --git a/utils/packages.lisp b/utils/packages.lisp index c2edca7685c7fd3d501f4438541d85343fad6e8b..1e3f3ebfdf9fb3dd0aa73d86fe5e4295b14a9016 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.36 92/10/29 16:55:06 cer Exp $ +;; $fiHeader: packages.lisp,v 1.37 92/11/06 19:05:10 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -3371,6 +3371,8 @@ fetch-medium-drawable find-port-type fit-region*-in-region* + focus-in-gadget-event + focus-out-gadget-event foreground-background-and-text-style-mixin frame-input-buffer frame-manager-clear-progress-note