X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/1a1949c751306b0f02c8e76df425ffbae58c6e5d..aa9ceddc987ea92cb20b319ff7b1a51bc176b6e8:/gtk/gtkutils.lisp

diff --git a/gtk/gtkutils.lisp b/gtk/gtkutils.lisp
index bd11006..cc234a9 100644
--- a/gtk/gtkutils.lisp
+++ b/gtk/gtkutils.lisp
@@ -15,7 +15,7 @@
 ;; License along with this library; if not, write to the Free Software
 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
-;; $Id: gtkutils.lisp,v 1.3 2004-11-07 17:55:29 espen Exp $
+;; $Id: gtkutils.lisp,v 1.5 2004-12-17 00:34:01 espen Exp $
 
 
 (in-package "GTK")
@@ -90,3 +90,57 @@
   (make-instance 'adjustment 
    :value value :lower lower :upper upper :step-increment step-increment
    :page-increment page-increment :page-size page-size))
+
+(defun create-action (name &optional stock-id label accelerator tooltip 
+		      callback &rest initargs)
+  (let ((action (apply #'make-instance 'action
+		 :name (string name) :stock-id stock-id  :label label
+		 :tooltip tooltip :accelerator accelerator initargs)))
+    (when callback
+      (apply #'signal-connect action 'activate (mklist callback)))
+    action))
+
+(defun create-toggle-action (name &optional stock-id label accelerator 
+			     tooltip active callback &rest initargs)
+  (let ((action (apply #'make-instance 'toggle-action 
+		 :name (string name) :stock-id stock-id :label label
+		 :tooltip tooltip :active active :accelerator accelerator
+		 initargs)))
+    (when callback
+      (destructuring-bind (function &key object after) (mklist callback)
+	(signal-connect action 'activate
+	 (if object 
+	     #'(lambda (object)
+		 (funcall function object (toggle-action-active-p action)))
+	   #'(lambda ()
+	       (funcall function (toggle-action-active-p action))))
+	 :object object :after after)
+	;(funcall callback active)
+	(when active
+	  (action-activate action))))
+    action))
+
+(defun create-radio-actions (specs &optional active callback &rest initargs)
+  (loop
+   with group = nil
+   for spec in specs
+   collect (destructuring-bind (name &optional stock-id label accelerator 
+				tooltip (value name)) 
+	       (mklist spec)
+	     (let ((action (apply #'make-instance 'radio-action 
+			    :name (string name) :stock-id stock-id 
+			    :label label :tooltip tooltip 
+			    :accelerator accelerator initargs)))
+	       (when (equal active value)
+		 (setf (toggle-action-active-p action) t)
+		 (when callback
+		   (funcall callback value)))
+
+	       (if (not group)
+		   (setq group action)
+		 (radio-action-add-to-group action group))
+	       (when callback
+		 (signal-connect action 'activate
+		  #'(lambda ()
+		      (funcall callback value))))
+	       action))))