[lgtk-devel] [PATCH:] A few more button functions

[Sverker Wiberg]

Here's a patch to add gtk-button-new-from-stock as well as functions to
handle a buttons label and relief state.

These functions (except for gtk-button-set-label) are showcased in
'button-flavours.lisp', which also contains a very first sketch (done in
five minutes) on a somewhat thicker and more Lispy binding for GTK.

Right now I'm thinking on adding docstring support to def-binding and
friends. Any thoughts?

/Sverker Wiberg

-------------- next part --------------
A non-text attachment was scrubbed...
Name: button-stuff.diff
Type: text/x-patch
Size: 1430 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/lgtk-devel/attachments/20040301/de2f21b7/attachment.bin>
-------------- next part --------------
;; All kinds of plain buttons
(use-package :gtk)

;; A function for creating GTK buttons of various variants.
(defun make-gtk-button (&key label mnemonic from-stock)
  (cond (label	
	 (gtk-button-new-with-label label))
	(mnemonic
	 (gtk-button-new-with-mnemonic mnemonic))
	(from-stock
	 (gtk-button-new-from-stock from-stock))
	(t
	 (gtk-button-new))))

;; Getters for button stuff...
(defun gtk-button-relief (b) (gtk-button-get-relief b))
(defun gtk-button-label (b) (gtk-button-get-label b))

;; ...and setters
(defsetf gtk-button-relief (button) (relief)
  `(progn (gtk-button-set-relief ,button ,relief)
	  ,relief))


(defun button-flavours ()
  (labels
      ((done (&rest args)
	     (declare (ignore args))
	     (gtk-main-quit)
	     0)

       (clicked (wid arg)
                (declare (ignore arg))
		(format t "(~s) '~a'~%"
			(gtk-button-relief wid)
			(gtk-button-label wid)))
		
       (add-button (button box flavour)
		   (g-signal-connect button gtkclicked #'clicked)
		   (gtk-box-pack-start box button
				       :expand t :fill t :padding 10)
		   (setf (gtk-button-relief button) flavour)
		   (gtk-widget-show button))
		   
       (mk-hbox (flavour)
		(let ((hbox (gtk-hbox-new :homogeneous t :spacing 4)))
		  (add-button (make-gtk-button)
			      hbox flavour)
		  (add-button (make-gtk-button :label "Label")
			      hbox flavour)
		  (add-button (make-gtk-button :mnemonic "M_nemonic")
			      hbox flavour)
		  (add-button (make-gtk-button :from-stock "gtk-ok")
			      hbox flavour)
		  (gtk-widget-show hbox)
		  hbox)))
  
  (let ((window (gtk-window-new :gtk-window-toplevel))
	(vbox (gtk-vbox-new :homogeneous t :spacing 4)))

    (dolist (flavour '(:gtk-relief-normal :gtk-relief-half :gtk-relief-none))
      (gtk-box-pack-start vbox (mk-hbox flavour)
			  :expand t :fill t :padding 10))
    (gtk-widget-show vbox)
    
    (gtk-container-add window vbox)

    (g-signal-connect window gtkdelete-event #'done)
    (gtk-window-set-title window "Button Flavours!")
    (gtk-container-set-border-width window 10)
    (gtk-widget-show window)
    
    (gtk-main)))))