The following shows how a push button gadget might be implemented.
;; 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)))))
Common Lisp Interface Manager 2.0 User's Guide - 3 Mar 2015