10.5.1 Abstract Gadgets
;; A PUSH-BUTTON uses the ACTIVATE-CALLBACK, and has a label. ;; This is the abstract class (defclass push-button (action-gadget labelled-gadget) ()) ;; Here is a concrete implementation of a PUSH-BUTTON. ;; The "null" frame manager create a pane of type PUSH-BUTTON-PANE when ;; asked to create a PUSH-BUTTON. (defclass push-button-pane (push-button leaf-pane space-requirement-mixin) ((show-as-default :initarg :show-as-default :accessor push-button-show-as-default) (armed :initform nil))) ;; General highlight-by-inverting method (defmethod highlight-button ((pane push-button-pane) medium) (with-bounding-rectangle* (left top right bottom) (sheet-region pane) (draw-rectangle* medium left top right bottom :ink +flipping-ink+ :filled t))) ;; Compute the amount of space required by a PUSH-BUTTON-PANE (defmethod compose-space ((pane push-button-pane) &key width height) (multiple-value-bind (width height) (compute-gadget-label-size pane) (make-space-requirement :width width :height height))) ;; This gets invoked to draw the push button. (defmethod repaint-sheet ((pane push-button-pane) region) (declare (ignore region)) (with-sheet-medium (medium pane) (let ((text (gadget-label pane)) (text-style (slot-value pane 'text-style)) (armed (slot-value pane 'armed)) (region (sheet-region pane))) (multiple-value-call #'draw-rectangle* medium (bounding-rectangle* (sheet-region pane)) :filled nil) (draw-textmedium text (clim-utils::bounding-rectangle-center region) :text-style text-style :align-x ':center :align-y ':top) (when (eql armed ':button-press) (highlight-button pane medium))))) ;; When we enter the push button's region, arm it. (defmethod handle-event ((pane push-button-pane) (event pointer-enter-event)) (with-slots (armed) pane (unless armed (setf armed t) (armed-callback pane (gadget-client pane) (gadget-id pane))))) ;; When we leave the push button's region, disarm it. (defmethod handle-event ((pane push-button-pane) (event pointer-exit-event)) (with-slots (armed) pane (when armed (when (eql armed ':button-press) (highlight-button pane medium)) (setf armed nil) (disarmed-callback pane (gadget-client pane) (gadget-id pane))))) ;; When the user presses a pointer button, ensure that the button ;; is armed, and highlight it. (defmethod handle-event ((pane push-button-pane) (event pointer-button-press-event)) (with-slots (armed) pane (unless armed (setf armed ':button-press) (armed-callback pane (gadget-client pane) (gadget-id pane)) (with-sheet-medium (medium pane) (highlight-button pane medium))))) ;; When the user releases the button and the button is still armed, ;; call the activate callback. (defmethod handle-event ((pane push-button-pane) (event pointer-button-release-event)) (with-slots (armed) pane (when (eql armed ':button-press) (activate-callback pane (gadget-client pane) (gadget-id pane)) (setf armed t) (with-sheet-medium (medium pane) (highlight-button pane medium)))))
Generated with Harlequin WebMaker