[cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp

[Peter Denno]

Update of /project/cells-gtk/cvsroot/root/cells-gtk
In directory common-lisp.net:/tmp/cvs-serv24931/cells-gtk

Modified Files:
	gtk-app.lisp 
Log Message:
A initialize-instance :after method to create user-defined stock icons -- these do not involve clos objects or cells,  just gtk (that's why its a i-i on gtk-app).
Date: Wed Feb 16 23:20:37 2005
Author: pdenno

Index: root/cells-gtk/gtk-app.lisp
diff -u root/cells-gtk/gtk-app.lisp:1.11 root/cells-gtk/gtk-app.lisp:1.12
--- root/cells-gtk/gtk-app.lisp:1.11	Sun Feb 13 18:25:13 2005
+++ root/cells-gtk/gtk-app.lisp	Wed Feb 16 23:20:37 2005
@@ -22,13 +22,23 @@
   ((splash-screen-image :accessor splash-screen-image :initarg :splash-screen-image :initform nil)
    (tooltips :initarg :tooltips :accessor tooltips :initform (make-be 'tooltips))
    (tooltips-enable :accessor tooltips-enable :initarg :tooltips-enable :initform (c-in t))
-   (tooltips-delay :accessor tooltips-delay :initarg :tooltips-delay :initform (c-in nil)))
+   (tooltips-delay :accessor tooltips-delay :initarg :tooltips-delay :initform (c-in nil))
+   (stock-icons :cell nil :accessor stock-icons :initarg :stock-icons :initform nil))
   (:default-initargs
       :on-delete-event (lambda (self widget event data)
                          (declare (ignore self widget event data))
                          (gtk-main-quit)
                          0)))
 
+(defmethod initialize-instance :after ((self gtk-app) &key stock-icons)
+  (loop for (name pathname) in stock-icons do
+       (let* ((image (gtk-image-new-from-file pathname))
+              (pixbuf (gtk-image-get-pixbuf image))
+              (icon-set (gtk-icon-set-new-from-pixbuf pixbuf))
+              (factory (gtk-icon-factory-new)))
+         (gtk-icon-factory-add factory (format nil "gtk-~A" (string-downcase (string name))) icon-set)
+         (gtk-icon-factory-add-default factory))))
+ 
 (def-c-output tooltips-enable ((self gtk-app))
   (when (tooltips self)
     (if new-value
@@ -78,7 +88,7 @@
             (not-to-be splash)
             (gtk-window-set-auto-startup-notification t))
           (setf (visible app) t)
-          
+
           (when *gtk-debug*
             (trc nil "STARTING GTK-MAIN") (force-output))
           #-lispworks(gtk-main)