From pdenno at common-lisp.net Sat Feb 12 19:09:24 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 12 Feb 2005 20:09:24 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/compat.lisp Message-ID: <20050212190924.DE4E288171@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv1581/cells-gtk Modified Files: compat.lisp Log Message: in lispworks, when process-wait-with-timeout is supplied with a predicate, event if #'(lambda () t) it has much different characteristics, than when it isn't supplied with one at all. So why isn't this just mp:sleep? I don't know. Date: Sat Feb 12 20:09:24 2005 Author: pdenno Index: root/cells-gtk/compat.lisp diff -u root/cells-gtk/compat.lisp:1.1 root/cells-gtk/compat.lisp:1.2 --- root/cells-gtk/compat.lisp:1.1 Sat Feb 12 15:38:37 2005 +++ root/cells-gtk/compat.lisp Sat Feb 12 20:09:24 2005 @@ -28,13 +28,16 @@ #+CMU (mp:process-wait whostate (lambda () (apply predicate args))) #+LispWorks (apply #'mp:process-wait whostate predicate args)) -;;; From clocc port -(defun process-wait-with-timeout (timeout whostate predicate &rest args) - "Sleep until PREDICATE becomes true, or for TIMEOUT seconds, -whichever comes first." +;;; From clocc port, but with additions and deletions +(defun process-wait-with-timeout (timeout whostate + &optional (predicate #'(lambda () t) pred-supplied-p) + &rest args) + "Sleep until PREDICATE becomes true, or for TIMEOUT seconds, whichever comes first." #+Allegro (apply #'mp:process-wait-with-timeout whostate timeout predicate args) #+CMU (mp:process-wait-with-timeout whostate timeout (lambda () (apply predicate args))) #+LispWorks - (apply #'mp:process-wait-with-timeout whostate timeout predicate args)) + (if pred-supplied-p + (apply #'mp:process-wait-with-timeout whostate timeout predicate args) + (mp:process-wait-with-timeout whostate timeout))) From pdenno at common-lisp.net Sat Feb 12 19:11:56 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 12 Feb 2005 20:11:56 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp Message-ID: <20050212191156.AB6DE88171@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv1611/cells-gtk Modified Files: gtk-app.lisp Log Message: The wait loop approach that works for lispworks doesn't really work for cmucl (uses too much processor). Nor does simple process-wait with gtk-event-pending work, which is unfortunate. Date: Sat Feb 12 20:11:56 2005 Author: pdenno Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.9 root/cells-gtk/gtk-app.lisp:1.10 --- root/cells-gtk/gtk-app.lisp:1.9 Sat Feb 12 15:50:29 2005 +++ root/cells-gtk/gtk-app.lisp Sat Feb 12 20:11:55 2005 @@ -81,14 +81,14 @@ (when *gtk-debug* (trc nil "STARTING GTK-MAIN") (force-output)) - #+clisp(gtk-main) - #-clisp + #-lispworks(gtk-main) + #+lispworks (catch 'try-again (handler-case (loop (loop while (gtk-events-pending) do (gtk-main-iteration-do nil)) - (process-wait-with-timeout .01 "GTK event loop waiting" #'(lambda () t))) + (process-wait-with-timeout .01 "GTK event loop waiting")) (gtk-cells-error (err) (show-message (format nil "Error: ~a" err) :message-type :error) (process-wait "Acknowledge error" #'gtk-events-pending) From pdenno at common-lisp.net Sun Feb 13 17:24:04 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sun, 13 Feb 2005 18:24:04 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/dialogs.lisp Message-ID: <20050213172404.22F82884E1@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv6914/cells-gtk Modified Files: dialogs.lisp Log Message: Without the gtk-object-forget, with frequent use of the file-chooser, you will get an error: Error: gtk-object-store id 136368864 already known as #, not # There are probably other places where widgets are destroyed but the hash-table not cleaned up, but this is the only one so far where I have seen an error. Date: Sun Feb 13 18:24:02 2005 Author: pdenno Index: root/cells-gtk/dialogs.lisp diff -u root/cells-gtk/dialogs.lisp:1.2 root/cells-gtk/dialogs.lisp:1.3 --- root/cells-gtk/dialogs.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/dialogs.lisp Sun Feb 13 18:24:02 2005 @@ -132,7 +132,8 @@ (if (select-multiple self) (setf (md-value self) (gtk-file-chooser-get-filenames-strs (id self))) (setf (md-value self) (gtk-file-chooser-get-filename (id self))))) - (gtk-widget-destroy (id self)))) + (gtk-widget-destroy (id self)) + (gtk-object-forget (id self) self))) (defun file-chooser (&rest inits) (let ((dialog (to-be (apply #'mk-file-chooser-dialog inits)))) From pdenno at common-lisp.net Sun Feb 13 17:25:15 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sun, 13 Feb 2005 18:25:15 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp Message-ID: <20050213172515.3F507884E1@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv6944/cells-gtk Modified Files: gtk-app.lisp Log Message: better error message Date: Sun Feb 13 18:25:14 2005 Author: pdenno Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.10 root/cells-gtk/gtk-app.lisp:1.11 --- root/cells-gtk/gtk-app.lisp:1.10 Sat Feb 12 20:11:55 2005 +++ root/cells-gtk/gtk-app.lisp Sun Feb 13 18:25:13 2005 @@ -90,7 +90,7 @@ do (gtk-main-iteration-do nil)) (process-wait-with-timeout .01 "GTK event loop waiting")) (gtk-cells-error (err) - (show-message (format nil "Error: ~a" err) :message-type :error) + (show-message (format nil "Cells-GTK Error: ~a" err) :message-type :error) (process-wait "Acknowledge error" #'gtk-events-pending) (loop while (gtk-events-pending) do (gtk-main-iteration-do nil)) (throw 'try-again nil)))))))) From pdenno at common-lisp.net Sun Feb 13 17:28:04 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sun, 13 Feb 2005 18:28:04 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-utilities.lisp Message-ID: <20050213172804.7F655884E1@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv6967/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: Andras's #+allegro patch for tree selection Date: Sun Feb 13 18:28:02 2005 Author: pdenno Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.9 root/gtk-ffi/gtk-utilities.lisp:1.10 --- root/gtk-ffi/gtk-utilities.lisp:1.9 Sat Feb 12 16:09:52 2005 +++ root/gtk-ffi/gtk-utilities.lisp Sun Feb 13 18:28:02 2005 @@ -180,7 +180,7 @@ (g-value-unset value)))) ;;; todo: The deref-pointer-runtime-typed used by case needs work if -;;; it is going to be used for lispworks and cmu. +;;; it is going to be used for lispworks, cmu and allegro. ;;; (needs someone who knows how ffi-to-uffi-type maps types for those lisps.) ;;; Even better, eliminate it. It is ill-conceived. (defun gtk-tree-model-get-cell (model iter column-no cell-type) @@ -189,15 +189,19 @@ column-no = num-columns. (See gtk-tree-store-set-kids)." (with-foreign-object (item :pointer-void) (gtk-tree-model-get model iter column-no item -1) - #-(or lispworks cmu) (cast item (as-gtk-type-name cell-type)) - #+lispworks - (case cell-type - (:string (fli:convert-from-foreign-string (fli:dereference item))) - (t (fli:dereference item))) - #+cmu - (case cell-type - (:string (alien:cast (alien:deref item) c-call:c-string)) - (t (alien:deref item))))) + ??#-(or lispworks cmu allegro) (cast item (as-gtk-type-name cell-type)) +?? ??#+allegro +?? ??(case cell-type +?? ?? ??(:string (uffi:convert-from-cstring (uffi:deref-pointer item :cstring))) +?? ?? ??(t (cast item (as-gtk-type-name cell-type)))) + #+lispworks + (case cell-type + (:string (fli:convert-from-foreign-string (fli:dereference item))) + (t (fli:dereference item))) + #+cmu + (case cell-type + (:string (alien:cast (alien:deref item) c-call:c-string)) + (t (alien:deref item))))) (defun parse-cell-attrib (attribs) (loop for (attrib val) on attribs by #'cddr collect From pdenno at common-lisp.net Sun Feb 13 18:21:30 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sun, 13 Feb 2005 19:21:30 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-utilities.lisp Message-ID: <20050213182130.264D0884E1@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv10004/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: non-printing characters in cut-and-paste of Andras's patch Date: Sun Feb 13 19:21:29 2005 Author: pdenno Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.10 root/gtk-ffi/gtk-utilities.lisp:1.11 --- root/gtk-ffi/gtk-utilities.lisp:1.10 Sun Feb 13 18:28:02 2005 +++ root/gtk-ffi/gtk-utilities.lisp Sun Feb 13 19:21:29 2005 @@ -190,11 +190,11 @@ (with-foreign-object (item :pointer-void) (gtk-tree-model-get model iter column-no item -1) ??#-(or lispworks cmu allegro) (cast item (as-gtk-type-name cell-type)) -?? ??#+allegro -?? ??(case cell-type -?? ?? ??(:string (uffi:convert-from-cstring (uffi:deref-pointer item :cstring))) -?? ?? ??(t (cast item (as-gtk-type-name cell-type)))) - #+lispworks + #+allegro + (case cell-type + (:string (uffi:convert-from-cstring (uffi:deref-pointer item :cstring))) + (t (cast item (as-gtk-type-name cell-type)))) + #+lispworks (case cell-type (:string (fli:convert-from-foreign-string (fli:dereference item))) (t (fli:dereference item))) From pdenno at common-lisp.net Mon Feb 14 22:46:20 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Mon, 14 Feb 2005 23:46:20 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/widgets.lisp Message-ID: <20050214224620.E4F9788171@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv2871/cells-gtk Modified Files: widgets.lisp Log Message: def-c-output on event-box, slot popup should have been wrapped in a (when new-value ...) Date: Mon Feb 14 23:46:20 2005 Author: pdenno Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.8 root/cells-gtk/widgets.lisp:1.9 --- root/cells-gtk/widgets.lisp:1.8 Sat Feb 12 16:02:56 2005 +++ root/cells-gtk/widgets.lisp Mon Feb 14 23:46:19 2005 @@ -392,7 +392,8 @@ :above-child t) (def-c-output popup ((self event-box)) - (setf (fm-parent new-value) self)) + (when new-value + (setf (fm-parent new-value) self))) (def-c-output visible-window ((self event-box)) (gtk-event-box-set-visible-window (id self) new-value)) From pdenno at common-lisp.net Wed Feb 16 22:18:09 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Wed, 16 Feb 2005 23:18:09 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/display.lisp Message-ID: <20050216221809.110E5884E2@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv24903/cells-gtk Modified Files: display.lisp Log Message: One line of documentation Date: Wed Feb 16 23:18:06 2005 Author: pdenno Index: root/cells-gtk/display.lisp diff -u root/cells-gtk/display.lisp:1.2 root/cells-gtk/display.lisp:1.3 --- root/cells-gtk/display.lisp:1.2 Sun Dec 5 07:33:22 2004 +++ root/cells-gtk/display.lisp Wed Feb 16 23:18:05 2005 @@ -97,6 +97,7 @@ (list (or (filename self) ""))))) (def-c-output stock ((self image)) + "Set the image of a stock icon" (when new-value (gtk-image-set-from-stock (id self) (stock-id self) (icon-size-id self)))) From pdenno at common-lisp.net Wed Feb 16 22:20:38 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Wed, 16 Feb 2005 23:20:38 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp Message-ID: <20050216222038.5BBED884E2@common-lisp.net> 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) From pdenno at common-lisp.net Wed Feb 16 22:22:01 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Wed, 16 Feb 2005 23:22:01 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/menus.lisp Message-ID: <20050216222201.D149F884E2@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv24960/cells-gtk Modified Files: menus.lisp Log Message: owner slot on menu object -- useful for situation like popup menus, where the menu isn't in the kids hierarchy. Date: Wed Feb 16 23:22:01 2005 Author: pdenno Index: root/cells-gtk/menus.lisp diff -u root/cells-gtk/menus.lisp:1.7 root/cells-gtk/menus.lisp:1.8 --- root/cells-gtk/menus.lisp:1.7 Sat Feb 12 15:53:18 2005 +++ root/cells-gtk/menus.lisp Wed Feb 16 23:22:01 2005 @@ -140,7 +140,7 @@ () () ()) (def-widget menu (menu-shell) - () + ((owner :initarg :owner :accessor owner :initform (c-in nil))) (title) ()) From pdenno at common-lisp.net Wed Feb 16 22:24:08 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Wed, 16 Feb 2005 23:24:08 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/widgets.lisp Message-ID: <20050216222408.C63E1884E2@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv24983/cells-gtk Modified Files: widgets.lisp Log Message: Removed def-c-output method on event-box. I added it two versions ago, but it is the wrong approach to the problem. Date: Wed Feb 16 23:24:08 2005 Author: pdenno Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.9 root/cells-gtk/widgets.lisp:1.10 --- root/cells-gtk/widgets.lisp:1.9 Mon Feb 14 23:46:19 2005 +++ root/cells-gtk/widgets.lisp Wed Feb 16 23:24:07 2005 @@ -310,7 +310,7 @@ (trc nil "VISIBLE" (md-name self) new-value) (force-output)) (if new-value (gtk-widget-show (id self)) - (gtk-widget-hide (id self)))) + (gtk-widget-hide (id self)))) (def-c-output tooltip ((self widget)) (when new-value @@ -390,10 +390,6 @@ (above-child) () :above-child t) - -(def-c-output popup ((self event-box)) - (when new-value - (setf (fm-parent new-value) self))) (def-c-output visible-window ((self event-box)) (gtk-event-box-set-visible-window (id self) new-value)) From pdenno at common-lisp.net Wed Feb 16 22:30:06 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Wed, 16 Feb 2005 23:30:06 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-other.lisp Message-ID: <20050216223006.66DFE884E2@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv25057/gtk-ffi Modified Files: gtk-other.lisp Log Message: New ffi definitions for gtk icon-factory and icon-set. Date: Wed Feb 16 23:30:04 2005 Author: pdenno Index: root/gtk-ffi/gtk-other.lisp diff -u root/gtk-ffi/gtk-other.lisp:1.2 root/gtk-ffi/gtk-other.lisp:1.3 --- root/gtk-ffi/gtk-other.lisp:1.2 Tue Dec 14 05:02:05 2004 +++ root/gtk-ffi/gtk-other.lisp Wed Feb 16 23:30:03 2005 @@ -278,6 +278,18 @@ (gtk-image-get-pixbuf ((image c-pointer)) c-pointer) + ;;icon-factory + (gtk-icon-factory-new () + c-pointer) + (gtk-icon-factory-add-default ((factory c-pointer))) + (gtk-icon-factory-add ((factory c-pointer) + (stock-id c-string) + (icon-set c-pointer))) + + ;;icon-set + (gtk-icon-set-new-from-pixbuf ((pixbuf c-pointer)) + c-pointer) + ;;statusbar (gtk-statusbar-new () c-pointer) From pdenno at common-lisp.net Wed Feb 16 22:31:54 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Wed, 16 Feb 2005 23:31:54 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-utilities.lisp Message-ID: <20050216223154.82BA3884E2@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv25789/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: fix another non-printing character problem. Man, I get these things every time I cut and paste from email, and only cmucl gets stuck on them. Anyone know what's causing this? Date: Wed Feb 16 23:31:53 2005 Author: pdenno Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.11 root/gtk-ffi/gtk-utilities.lisp:1.12 --- root/gtk-ffi/gtk-utilities.lisp:1.11 Sun Feb 13 19:21:29 2005 +++ root/gtk-ffi/gtk-utilities.lisp Wed Feb 16 23:31:53 2005 @@ -189,7 +189,7 @@ column-no = num-columns. (See gtk-tree-store-set-kids)." (with-foreign-object (item :pointer-void) (gtk-tree-model-get model iter column-no item -1) - ??#-(or lispworks cmu allegro) (cast item (as-gtk-type-name cell-type)) + #-(or lispworks cmu allegro) (cast item (as-gtk-type-name cell-type)) #+allegro (case cell-type (:string (uffi:convert-from-cstring (uffi:deref-pointer item :cstring))) From pdenno at common-lisp.net Wed Feb 16 22:32:53 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Wed, 16 Feb 2005 23:32:53 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/test-images/my-g.png Message-ID: <20050216223253.B9043884E2@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/test-images In directory common-lisp.net:/tmp/cvs-serv25811/test-images Added Files: my-g.png Log Message: New graphic file to demonstrate user stocked icons. Date: Wed Feb 16 23:32:53 2005 Author: pdenno From pdenno at common-lisp.net Wed Feb 16 22:34:44 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Wed, 16 Feb 2005 23:34:44 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/config.lisp Message-ID: <20050216223444.C6E48884E2@common-lisp.net> Update of /project/cells-gtk/cvsroot/root In directory common-lisp.net:/tmp/cvs-serv25831 Modified Files: config.lisp Log Message: New global - pathname for user-define icon. The actual file, called my-g.png is provided. Date: Wed Feb 16 23:34:44 2005 Author: pdenno Index: root/config.lisp diff -u root/config.lisp:1.1 root/config.lisp:1.2 --- root/config.lisp:1.1 Tue Jan 25 16:57:31 2005 +++ root/config.lisp Wed Feb 16 23:34:43 2005 @@ -11,13 +11,13 @@ |# -(push (make-pathname :directory '(:absolute "cell-cultures" "utils-kt")) +(push (make-pathname :directory '(:absolute "local" "lisp" "cells-gtk" "utils-kt")) asdf:*central-registry*) -(push (make-pathname :directory '(:absolute "cell-cultures" "cells")) +(push (make-pathname :directory '(:absolute "local" "lisp" "cells-gtk" "cells")) asdf:*central-registry*) -(push (make-pathname :directory '(:absolute "cell-cultures" "hello-c")) +(push (make-pathname :directory '(:absolute "local" "lisp" "cells-gtk" "hello-c")) asdf:*central-registry*) (push (merge-pathnames @@ -56,4 +56,10 @@ (merge-pathnames (make-pathname :directory '(:relative "test-images") :name "tst" :type "gif") + *load-pathname*)) + +(defparameter *stock-icon-image* + (merge-pathnames + (make-pathname :directory '(:relative "test-images") + :name "my-g" :type "png") *load-pathname*)) From pdenno at common-lisp.net Wed Feb 16 22:35:59 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Wed, 16 Feb 2005 23:35:59 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-display.lisp Message-ID: <20050216223559.2CBBA884E2@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv25864/cells-gtk/test-gtk Modified Files: test-display.lisp Log Message: Add definitions to demonstrate user-defined stock icon. Date: Wed Feb 16 23:35:57 2005 Author: pdenno Index: root/cells-gtk/test-gtk/test-display.lisp diff -u root/cells-gtk/test-gtk/test-display.lisp:1.4 root/cells-gtk/test-gtk/test-display.lisp:1.5 --- root/cells-gtk/test-gtk/test-display.lisp:1.4 Tue Jan 25 16:57:28 2005 +++ root/cells-gtk/test-gtk/test-display.lisp Wed Feb 16 23:35:57 2005 @@ -12,8 +12,9 @@ :expand t :fill t :kids (list (mk-hbox - :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar :button :dnd :dialog) collect - (mk-image :stock :harddisk :icon-size icon-size))) + :kids (loop for icon-size in '(:menu :small-toolbar :large-toolbar :button :dnd :dialog) + collect (mk-image :stock :harddisk :icon-size icon-size) + collect (mk-image :stock :my-g :icon-size icon-size))) (mk-hseparator) (mk-aspect-frame :ratio 1 From pdenno at common-lisp.net Wed Feb 16 22:36:49 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Wed, 16 Feb 2005 23:36:49 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-gtk.lisp Message-ID: <20050216223649.0C546884E2@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv25886/cells-gtk/test-gtk Modified Files: test-gtk.lisp Log Message: Added initarg to specify a user-defined stock icon. Date: Wed Feb 16 23:36:45 2005 Author: pdenno Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.9 root/cells-gtk/test-gtk/test-gtk.lisp:1.10 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.9 Tue Jan 25 16:57:28 2005 +++ root/cells-gtk/test-gtk/test-gtk.lisp Wed Feb 16 23:36:45 2005 @@ -10,6 +10,7 @@ ;;:tooltips nil ;;dkwt ;;:tooltips-enable nil ;;dkwt :icon (namestring cl-user::*small-image*) + :stock-icons (list (list :my-g (namestring cl-user::*stock-icon-image*))) :position :center :splash-screen-image (namestring cl-user::*splash-image*) :width 550 :height 550 From pdenno at common-lisp.net Wed Feb 16 22:38:01 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Wed, 16 Feb 2005 23:38:01 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-menus.lisp Message-ID: <20050216223801.46E6D884E2@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv25911/cells-gtk/test-gtk Modified Files: test-menus.lisp Log Message: Added demonstration of user-defined stock icon. Date: Wed Feb 16 23:38:00 2005 Author: pdenno Index: root/cells-gtk/test-gtk/test-menus.lisp diff -u root/cells-gtk/test-gtk/test-menus.lisp:1.2 root/cells-gtk/test-gtk/test-menus.lisp:1.3 --- root/cells-gtk/test-gtk/test-menus.lisp:1.2 Mon Jan 3 23:33:20 2005 +++ root/cells-gtk/test-gtk/test-menus.lisp Wed Feb 16 23:38:00 2005 @@ -28,7 +28,10 @@ (mk-image-menu-item :image (mk-image :stock :dialog-info :icon-size :menu) :label-widget (mk-label :markup (with-markup (:foreground :blue) - "Blue label"))))) + "Blue label"))) + (mk-image-menu-item + :stock :my-g + :label "user stock icon"))) (mk-menu-item :label "Menu 2" :visible (c? (md-value (fm^ :menu2-visible))) From pdenno at common-lisp.net Thu Feb 17 20:00:15 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Thu, 17 Feb 2005 21:00:15 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/dialogs.lisp Message-ID: <20050217200015.21054884FA@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv28441/cells-gtk Modified Files: dialogs.lisp Log Message: After you gtk-destroy a dialog widget, forget it (remove if from the clos object / gtk object hash table). Date: Thu Feb 17 21:00:13 2005 Author: pdenno Index: root/cells-gtk/dialogs.lisp diff -u root/cells-gtk/dialogs.lisp:1.3 root/cells-gtk/dialogs.lisp:1.4 --- root/cells-gtk/dialogs.lisp:1.3 Sun Feb 13 18:24:02 2005 +++ root/cells-gtk/dialogs.lisp Thu Feb 17 21:00:13 2005 @@ -52,7 +52,8 @@ (-7 :close) (-8 :yes) (-9 :no)))) - (gtk-widget-destroy (id self))) + (gtk-widget-destroy (id self)) + (gtk-object-forget (id self) self)) (defun show-message (text &rest inits) (let ((message-widget (to-be (apply #'mk-message-dialog :message text inits)))) From pdenno at common-lisp.net Sat Feb 26 22:17:53 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:17:53 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/Makefile Message-ID: <20050226221753.4B4C788672@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv7318/gtk-ffi Added Files: Makefile Log Message: New file, makefile for libcellsgtk.so Date: Sat Feb 26 23:17:52 2005 Author: pdenno From pdenno at common-lisp.net Sat Feb 26 22:18:25 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:18:25 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-adds.c Message-ID: <20050226221825.3B82C88672@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv7336/gtk-ffi Added Files: gtk-adds.c Log Message: New file, compiles to libcellsgtk.so Date: Sat Feb 26 23:18:24 2005 Author: pdenno From pdenno at common-lisp.net Sat Feb 26 22:19:04 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:19:04 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/FAQ.txt Message-ID: <20050226221904.8FD2488672@common-lisp.net> Update of /project/cells-gtk/cvsroot/root In directory common-lisp.net:/tmp/cvs-serv7356 Added Files: FAQ.txt Log Message: New file, the start of a FAQ. Date: Sat Feb 26 23:19:03 2005 Author: pdenno From pdenno at common-lisp.net Sat Feb 26 22:20:20 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:20:20 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-textview.lisp Message-ID: <20050226222020.A002688672@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv7398/cells-gtk/test-gtk Modified Files: test-textview.lisp Log Message: New stuff to demonstrate GTK Treeview populate-popup. Date: Sat Feb 26 23:20:20 2005 Author: pdenno Index: root/cells-gtk/test-gtk/test-textview.lisp diff -u root/cells-gtk/test-gtk/test-textview.lisp:1.1 root/cells-gtk/test-gtk/test-textview.lisp:1.2 --- root/cells-gtk/test-gtk/test-textview.lisp:1.1 Fri Nov 19 00:40:14 2004 +++ root/cells-gtk/test-gtk/test-textview.lisp Sat Feb 26 23:20:19 2005 @@ -9,4 +9,15 @@ (mk-scrolled-window :kids (list (mk-text-view - :buffer (c? (buffer (upper self test-textview))))))))) + :buffer (c? (buffer (upper self test-textview))) + #+libcellsgtk :populate-popup + #+libcellsgtk + (c? + (def-populate-adds + (:menu-item :label "My menu item" + :owner self + :on-activate + (callback (w e d) + (show-message (format nil "My menu item says = ~A" + (owner self))))))))))))) + From pdenno at common-lisp.net Sat Feb 26 22:21:08 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:21:08 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/cells-gtk.lisp Message-ID: <20050226222108.20FB388672@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv7424/cells-gtk Modified Files: cells-gtk.lisp Log Message: Trivial documentation Date: Sat Feb 26 23:21:07 2005 Author: pdenno Index: root/cells-gtk/cells-gtk.lisp diff -u root/cells-gtk/cells-gtk.lisp:1.4 root/cells-gtk/cells-gtk.lisp:1.5 --- root/cells-gtk/cells-gtk.lisp:1.4 Sat Feb 12 15:47:00 2005 +++ root/cells-gtk/cells-gtk.lisp Sat Feb 26 23:21:07 2005 @@ -26,7 +26,7 @@ (defun gtk-tree-store-set-kids (model val-tree par-iter index column-types print-fn children-fn &optional path) (with-tree-iter (iter) - (gtk-ffi::gtk-tree-store-append model iter par-iter) + (gtk-ffi::gtk-tree-store-append model iter par-iter) ; sets iter (gtk-ffi::gtk-tree-store-set model iter column-types (append @@ -34,5 +34,5 @@ (list (format nil "(~{~d ~})" (reverse (cons index path)))))) (loop for sub-tree in (funcall children-fn val-tree) for pos from 0 do - (gtk-tree-store-set-kids model sub-tree iter + (gtk-tree-store-set-kids model sub-tree iter pos column-types print-fn children-fn (cons index path))))) From pdenno at common-lisp.net Sat Feb 26 22:22:07 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:22:07 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/conditions.lisp Message-ID: <20050226222207.806DA88672@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv7447/cells-gtk Modified Files: conditions.lisp Log Message: New conditions for continuable errors, though the details of that are not resolved in the gtk main loop. Date: Sat Feb 26 23:22:06 2005 Author: pdenno Index: root/cells-gtk/conditions.lisp diff -u root/cells-gtk/conditions.lisp:1.1 root/cells-gtk/conditions.lisp:1.2 --- root/cells-gtk/conditions.lisp:1.1 Sat Feb 12 15:43:27 2005 +++ root/cells-gtk/conditions.lisp Sat Feb 26 23:22:05 2005 @@ -21,7 +21,9 @@ (defmacro gtk-report-error (type string &body args) `(error ',type :format-string ,string :format-arguments (list , at args))) -(define-condition gtk-cells-error (error) +(define-condition gtk-continuable-error (condition) ()) + +(define-condition gtk-cells-error (gtk-continuable-error) ((format-string :initarg :format-string) (format-arguments :initarg :format-arguments)) (:report (lambda (err stream) @@ -29,5 +31,8 @@ (apply #'format stream format-string format-arguments))))) (define-condition gtk-object-id-error (gtk-cells-error) + ()) + +(define-condition gtk-user-signals-quit (condition) ()) From pdenno at common-lisp.net Sat Feb 26 22:24:28 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:24:28 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/dialogs.lisp Message-ID: <20050226222428.911E288672@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv7473/cells-gtk Modified Files: dialogs.lisp Log Message: New stuff to implement add a child widget to dialogs (for prompting for strings, for example). This reminds me that I don't have this in the test-gtk demo yet. Date: Sat Feb 26 23:24:27 2005 Author: pdenno Index: root/cells-gtk/dialogs.lisp diff -u root/cells-gtk/dialogs.lisp:1.4 root/cells-gtk/dialogs.lisp:1.5 --- root/cells-gtk/dialogs.lisp:1.4 Thu Feb 17 21:00:13 2005 +++ root/cells-gtk/dialogs.lisp Sat Feb 26 23:24:27 2005 @@ -18,12 +18,14 @@ (in-package :cgtk) + (def-widget message-dialog (window) ((message :accessor message :initarg :message :initform nil) (message-type :accessor message-type :initarg :message-type :initform :info) (buttons-type :accessor buttons-type :initarg :buttons-type :initform (c? (if (eql (message-type self) :question) :yes-no - :close)))) + :close))) + (content-area :accessor content-area :initarg :content-area :initform nil)) (markup) () :position :mouse @@ -40,7 +42,7 @@ (:close 2) (:cancel 3) (:yes-no 4) - (:ok-cancel 4)) + (:ok-cancel 5)) (message self)))) (defmethod md-awaken :after ((self message-dialog)) @@ -53,18 +55,27 @@ (-8 :yes) (-9 :no)))) (gtk-widget-destroy (id self)) - (gtk-object-forget (id self) self)) + (gtk-object-forget (id self) self) + (with-slots (content-area) self + (when content-area + (setf (md-value self) (md-value content-area)) + (gtk-object-forget (id content-area) content-area)))) (defun show-message (text &rest inits) (let ((message-widget (to-be (apply #'mk-message-dialog :message text inits)))) (md-value message-widget))) - (def-object file-filter () ((mime-types :accessor mime-types :initarg :mime-types :initform nil) (patterns :accessor patterns :initarg :patterns :initform nil)) (name) ()) + +(def-c-output content-area ((self message-dialog)) + (when new-value + (to-be new-value) + (let ((vbox (gtk-adds-dialog-vbox (id self)))) + (gtk-box-pack-start vbox (id new-value) nil nil 5)))) (def-c-output mime-types ((self file-filter)) (dolist (mime-type new-value) From pdenno at common-lisp.net Sat Feb 26 22:26:10 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:26:10 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp Message-ID: <20050226222610.799D388672@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv7500/cells-gtk Modified Files: gtk-app.lisp Log Message: More work toward straightening out the gtk main loop in lispworks. Also stuff for loading of libcellsgtk.so Date: Sat Feb 26 23:26:09 2005 Author: pdenno Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.12 root/cells-gtk/gtk-app.lisp:1.13 --- root/cells-gtk/gtk-app.lisp:1.12 Wed Feb 16 23:20:37 2005 +++ root/cells-gtk/gtk-app.lisp Sat Feb 26 23:26:09 2005 @@ -27,9 +27,11 @@ (:default-initargs :on-delete-event (lambda (self widget event data) (declare (ignore self widget event data)) - (gtk-main-quit) + #+lispworks(signal 'gtk-user-signals-quit) + #-lispworks(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)) @@ -69,6 +71,7 @@ (gdk-threads-init) (assert (gtk-init-check c-null-int c-null)) (setf *gtk-initialized* t)) + (setf (gtk-user-quit-p) nil) (with-gdk-threads (let ((app (make-instance app-name :visible (c-in nil))) @@ -91,19 +94,28 @@ (when *gtk-debug* (trc nil "STARTING GTK-MAIN") (force-output)) - #-lispworks(gtk-main) + #-lispworks + (gtk-main) #+lispworks - (catch 'try-again - (handler-case - (loop - (loop while (gtk-events-pending) - do (gtk-main-iteration-do nil)) - (process-wait-with-timeout .01 "GTK event loop waiting")) - (gtk-cells-error (err) - (show-message (format nil "Cells-GTK Error: ~a" err) :message-type :error) - (process-wait "Acknowledge error" #'gtk-events-pending) - (loop while (gtk-events-pending) do (gtk-main-iteration-do nil)) - (throw 'try-again nil)))))))) + (flet ((do-gtk () (loop while (gtk-events-pending) do (gtk-main-iteration-do nil)))) + (unwind-protect + (catch 'try-again + (handler-case + (loop + (do-gtk) + (when (gtk-user-quit-p) (signal 'gtk-user-signals-quit)) + (process-wait-with-timeout .01 "GTK event loop waiting")) + (gtk-continuable-error (err) + (show-message (format nil "Cells-GTK Error: ~a" err) + :message-type :error :title "Cells-GTK Error") + (throw 'try-again nil)) ; This doesn't really work. u-p cleanup forms invoked. + (gtk-user-signals-quit (c) + (declare (ignore c)) + (return-from start-app nil)))) + (not-to-be app) + (gtk-main-quit) + (do-gtk))))))) + (defvar *gtk-global-callbacks* nil) (defvar *gtk-loaded* #+clisp t #-clisp nil) ;; kt: looks like CLisp does this on its own @@ -128,7 +140,7 @@ (gtk-reset) #-cmu (unless *gtk-loaded* - (loop for lib in '(:gthread :glib :gobject :gdk :gtk) + (loop for lib in '(:gthread :glib :gobject :gdk :gtk #+libcellsgtk :cgtk) for libname = (gtk-ffi::libname lib) with libpath = (cond ((directory "/usr/lib/libgtk*") "/usr/lib/") ((directory "/opt/gnome/lib/libgtk*") "/opt/gnome/lib/") @@ -136,11 +148,20 @@ (t (error "Cannot find a path containing libgtk"))) do #-mswindows ;; probably have to refine this for diff implementations (setq libname (uffi:find-foreign-library (gtk-ffi::libname lib) libpath)) - (assert (uffi:load-foreign-library libname - :force-load #+lispworks t #-lispworks nil - :module (string lib))) - finally (setf *gtk-loaded* t)))) + (assert (or (uffi:load-foreign-library libname + :force-load #+lispworks t #-lispworks nil + :module (string lib)) + (eql lib :cgtk))) + finally (setf *gtk-loaded* t)) + #-libcellsgtk(warn "libcellsgtk.so not found. Just a few capabilities will be unavailable."))) + +;;; Implements quits other than through destroy. +(let (quit) + (defun gtk-user-quit-p () quit) + (defun (setf gtk-user-quit-p) (val) + (setf quit val)) +) (eval-when (compile load eval) (export '(gtk-app gtk-reset cells-gtk-init title icon tooltips tooltips-enable tooltips-delay - start-app gtk-global-callback-register gtk-global-callback-funcall))) \ No newline at end of file + start-app gtk-global-callback-register gtk-global-callback-funcall gtk-user-quit-p))) \ No newline at end of file From pdenno at common-lisp.net Sat Feb 26 22:28:09 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:28:09 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/menus.lisp Message-ID: <20050226222809.1740D88672@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv7527/cells-gtk Modified Files: menus.lisp Log Message: Stuff to clean up menus that occur as the menu-items supplied by populate-popup signals. Also new owner slot on menu-item. Date: Sat Feb 26 23:28:08 2005 Author: pdenno Index: root/cells-gtk/menus.lisp diff -u root/cells-gtk/menus.lisp:1.8 root/cells-gtk/menus.lisp:1.9 --- root/cells-gtk/menus.lisp:1.8 Wed Feb 16 23:22:01 2005 +++ root/cells-gtk/menus.lisp Sat Feb 26 23:28:08 2005 @@ -149,7 +149,9 @@ (label-widget :accessor label-widget :initarg :label-widget :initform nil) (accel-label-widget :accessor accel-label-widget :initform (c? (and (label self) (to-be (mk-accel-label :text (label self)))))) - (accel :accessor accel :initarg :accel :initform (c-in nil))) + (accel :accessor accel :initarg :accel :initform (c-in nil)) + (owner :initarg :owner :accessor owner :initform (c-in nil)) + (submenu :cell nil :accessor submenu :initform nil)) ; gtk-menu-item-get-submenu not doing it. POD (right-justified) (activate)) @@ -184,11 +186,11 @@ (gtk-container-add (id self) (id new-value)))) (def-c-output .kids ((self menu-item)) - (when old-value + (when old-value ; pod never occurs ? (gtk-menu-item-remove-submenu (id self))) (when new-value (gtk-menu-item-set-submenu (id self) - (id (make-be 'menu :kids new-value))))) + (id (setf (submenu self) (make-be 'menu :kids new-value)))))) (def-widget check-menu-item (menu-item) ((init :accessor init :initarg :init :initform nil)) From pdenno at common-lisp.net Sat Feb 26 22:29:24 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:29:24 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/textview.lisp Message-ID: <20050226222924.2B50288672@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv7557/cells-gtk Modified Files: textview.lisp Log Message: Implementation of populate-popup signal handling. Date: Sat Feb 26 23:29:23 2005 Author: pdenno Index: root/cells-gtk/textview.lisp diff -u root/cells-gtk/textview.lisp:1.2 root/cells-gtk/textview.lisp:1.3 --- root/cells-gtk/textview.lisp:1.2 Sun Dec 5 07:33:23 2004 +++ root/cells-gtk/textview.lisp Sat Feb 26 23:29:23 2005 @@ -30,7 +30,10 @@ -1)) (def-widget text-view () - ((buffer :accessor buffer :initarg :buffer :initform (mk-text-buffer))) + ((buffer :accessor buffer :initarg :buffer :initform (mk-text-buffer)) + (populate-popup :accessor populate-popup :initarg :populate-popup :initform (c-in nil)) + (depopulate-popup :accessor depopulate-popup :initarg :depopulate-popup :initform (c-in nil)) + (old-popups :cell nil :accessor old-popups :initform nil)) () () :kids (c? (when (buffer self) (list (buffer self)))) @@ -40,3 +43,64 @@ (def-c-output buffer ((self text-view)) (when new-value (gtk-text-view-set-buffer (id self) (id (buffer self))))) + +;;; --------Populate-add ------------------------------------------------- +;;; Menu-items that are appended to the existing textview popup menu on +;;; the populate-popup signal. They are made fresh from populate-adds. + +(defclass populate-adds () + ((label :initarg :label :initform nil) + (on-activate :initarg :on-activate :initform nil) + (owner :initarg :owner :initform nil) + (kids :initarg :kids :initform nil))) + +;;; Returns a list of populate-adds objects. These contain the :on-activate closures, +;;; but do not create the menu-item, which must be made each time they are needed, +;;; in the handler. +(defmacro def-populate-adds (&body menu-items) + `(list + ,@(loop for (type . args) in menu-items + when (eql type :menu-item) + collect `(funcall #'make-instance 'populate-adds , at args)))) + +(ff-defun-callable :cdecl :void text-view-populate-popup-handler + ((widget :pointer-void) (signal :pointer-void) (data :pointer-void)) + (declare (ignorable signal data)) + (let ((popup-menu (gtk-adds-text-view-popup-menu widget))) + (bwhen (text-view (gtk-object-find widget)) + (bwhen (cb (callback-recover text-view :populate-popup)) + (funcall cb popup-menu)))) + 1) + +(def-c-output populate-popup ((self text-view)) + (when new-value + (callback-register self :populate-popup (populate-popup-closure (reverse new-value) self)) + (gtk-signal-connect (id self) "populate-popup" + (ffx:ff-register-callable 'text-view-populate-popup-handler)))) + +(defun populate-popup-closure (p-adds text-view) + (let (accum) + (labels ((do-padds (p-add) + (let ((item (with-slots (label on-activate owner kids) p-add + (mk-menu-item :label label :owner owner :on-activate on-activate + :kids (mapcar #'do-padds kids))))) + (push item accum) + item))) + #'(lambda (popup-menu) + (loop for old in (old-popups text-view) do + (bwhen (sub (submenu old)) + (gtk-object-forget (id sub) sub)) + (gtk-object-forget (id old) old)) + (let ((tops (mapcar #'do-padds p-adds))) + (setf (old-popups text-view) accum) + (mapc #'(lambda (i) (to-be i) (gtk-menu-shell-prepend popup-menu (id i))) tops)))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(def-populate-adds populate-adds))) + + + + + + + From pdenno at common-lisp.net Sat Feb 26 22:30:41 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:30:41 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/tree-view.lisp Message-ID: <20050226223041.5C25C8866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv8137/cells-gtk Modified Files: tree-view.lisp Log Message: Return integer values from handlers. Date: Sat Feb 26 23:30:40 2005 Author: pdenno Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.9 root/cells-gtk/tree-view.lisp:1.10 --- root/cells-gtk/tree-view.lisp:1.9 Sat Feb 12 15:56:11 2005 +++ root/cells-gtk/tree-view.lisp Sat Feb 26 23:30:39 2005 @@ -46,9 +46,9 @@ (columns :accessor columns :initform (c? (mapcar #'(lambda (col-init) (apply #'make-be 'tree-view-column - :container self - col-init)) - (column-inits self)))) + :container self + col-init)) + (column-inits self)))) (select-if :unchanged-if #'fail :accessor select-if :initarg :select-if :initform (c-in nil)) (roots :accessor roots :initarg :roots :initform nil) @@ -82,7 +82,8 @@ (roots tree) (read-from-string (gtk-tree-model-get-cell model iter (length (column-types tree)) :string))) - (selected-items-cache tree)))) + (selected-items-cache tree))) + 0) (defmethod get-selection ((self tree-view)) (let ((selection (gtk-tree-view-get-selection (id self))) @@ -108,12 +109,13 @@ (bif (tree-view (gtk-object-find column-widget)) (let ((cb (callback-recover tree-view :on-select))) (funcall cb tree-view column-widget event data)) - (trc "dude, clean up old widgets after runs" column-widget))) + (trc "dude, clean up old widgets after runs" column-widget)) + 0) ;;; The check that previously was performed here (for a clos object) caused the handler ;;; not to be registered (a problem of execution ordering?). Anyway, do we need such a check? (def-c-output on-select ((self tree-view)) - (when new-value + (when new-value (let ((selected-widget (gtk-tree-view-get-selection (id self)))) (gtk-object-store selected-widget self) ;; tie column widget to clos tree-view (callback-register self :on-select new-value) @@ -176,9 +178,9 @@ (when old-value (gtk-tree-store-clear (id (tree-model self)))) (when new-value - (loop for sub-tree in new-value + (loop for root in new-value for index from 0 do - (gtk-tree-store-set-kids (id (tree-model self)) sub-tree c-null index + (gtk-tree-store-set-kids (id (tree-model self)) root c-null index (append (column-types self) (list :string)) (print-fn self) (children-fn self))))) @@ -212,7 +214,7 @@ nil nil) (gtk-tree-view-column-set-sort-column-id (id col) pos) (gtk-tree-view-insert-column (id self) (id col) pos)))) - + (def-object tree-view-column () ((title :accessor title :initarg :title :initform nil) (visible :accessor visible :initarg :visible :initform t)) From pdenno at common-lisp.net Sat Feb 26 22:31:42 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:31:42 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/widgets.lisp Message-ID: <20050226223142.497C88866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv8345/cells-gtk Modified Files: widgets.lisp Log Message: Make gtk-object-forget recursive. Date: Sat Feb 26 23:31:41 2005 Author: pdenno Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.10 root/cells-gtk/widgets.lisp:1.11 --- root/cells-gtk/widgets.lisp:1.10 Wed Feb 16 23:24:07 2005 +++ root/cells-gtk/widgets.lisp Sat Feb 26 23:31:41 2005 @@ -65,18 +65,11 @@ "gtk-object-store id ~a already known as ~a, not ~a" hash-id known gtk-object))))) -(defun gtk-object-forget (gtk-id gtk-object &aux (hash-id (pointer-address gtk-id))) - (assert *gtk-objects*) - (let ((known (gethash hash-id *gtk-objects*))) - (cond - ((not known)) - ((eql known gtk-object) - (setf (gethash hash-id *gtk-objects*) nil)) - (t - (gtk-report-error gtk-object-id-error - "gtk-object-store id ~a known as ~a, not forgettable ~a" - hash-id known gtk-object))))) - +(defun gtk-object-forget (gtk-id gtk-object) + (when gtk-id + (assert *gtk-objects*) + (remhash (pointer-address gtk-id) *gtk-objects*) + (mapc #'(lambda (k) (gtk-object-forget (id k) k)) (kids gtk-object)))) (defun gtk-object-find (gtk-id &optional must-find-p &aux (hash-id (pointer-address gtk-id))) (when *gtk-objects* @@ -117,7 +110,7 @@ (intern (format nil "GTK-~a~{-~a~}" class slot-access) :gtk-ffi)))) ;;; --- widget -------------------- - +;;; Define handlers that recover the the callback defined on the widget (defmacro def-gtk-event-handler (event) `(ff-defun-callable :cdecl :int ,(intern (string-upcase (format nil "~a-handler" event))) ((widget :pointer-void) (event :pointer-void) (data :pointer-void)) @@ -381,6 +374,7 @@ (def-c-output .kids ((self window)) (assert-bin self) (dolist (kid new-value) + (when *gtk-debug* (format t "~% window ~A has kid ~A" self kid)) (when *gtk-debug* (trc nil "WINDOW ADD KID" (md-name self) (md-name kid)) (force-output)) (gtk-container-add (id self) (id kid))) #+clisp (call-next-method)) From pdenno at common-lisp.net Sat Feb 26 22:37:41 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:37:41 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.lisp Message-ID: <20050226223741.6682D8866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv8389/gtk-ffi Modified Files: gtk-ffi.lisp Log Message: provisions to load libcellsgtk, definition of gtk-event-key foreign structure. Date: Sat Feb 26 23:37:40 2005 Author: pdenno Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.9 root/gtk-ffi/gtk-ffi.lisp:1.10 --- root/gtk-ffi/gtk-ffi.lisp:1.9 Sat Feb 12 16:07:58 2005 +++ root/gtk-ffi/gtk-ffi.lisp Sat Feb 26 23:37:40 2005 @@ -45,11 +45,12 @@ '(:array :int) index) new-value)) + (eval-when (:compile-toplevel :load-toplevel :execute) (export '(c-null c-null-int int-slot-indexed)) (defun gtk-function-name (lisp-name) (substitute #\_ #\- lisp-name)) - + (defun libname (lib) #+(or win32 mswindows) (concatenate 'string @@ -59,7 +60,7 @@ (:glib "libglib-2.0-0.dll") (:gthread "libgthread-2.0-0.dll") (:gdk "libgdk-win32-2.0-0.dll") - (:gtk "libgtk-win32-2.0-0.dll"))) + (:cgtk "libcellsgtk"))) #+macosx (concatenate 'string "/sw/lib/" @@ -68,25 +69,32 @@ (:glib "libglib-2.0.0.dylib") (:gthread "libgthread-2.0.0.dylib") (:gdk "libgdk-x11-2.0.0.dylib") - (:gtk "libgtk-x11-2.0.0.dylib"))) + (:gtk "libgtk-x11-2.0.0.dylib") + (:cgtk "libcellsgtk.dylib"))) #-(or macosx win32 mswindows) (ecase lib (:gobject "libgobject-2.0") (:glib "libglib-2.0") (:gthread "libgthread-2.0") (:gdk "libgdk-x11-2.0") - (:gtk "libgtk-x11-2.0"))) + (:gtk "libgtk-x11-2.0") + (:cgtk "libcellsgtk"))) + + + #+cmu - (loop for lib in '(:gthread :glib :gobject :gdk :gtk) + (loop for lib in '(:gthread :glib :gobject :gdk :gtk #+libcellsgtk :cgtk) with libpath = (cond ((directory "/usr/lib/libgtk*") "/usr/lib/") ((directory "/opt/gnome/lib/libgtk*") "/opt/gnome/lib/") ((find :mswindows *features*) nil) (t (error "Cannot find a path containing libgtk"))) do (assert (uffi:load-foreign-library ;;simon - (hic:find-foreign-library (gtk-ffi::libname lib) libpath) - :force-load nil - :module (string lib))) - ) + (hic:find-foreign-library (gtk-ffi::libname lib) libpath) + :force-load nil + :module (string lib)))) + + #-libcellsgtk + (warn "libcellsgtk.so not found. Just a few capabilities will be unavailable.") (defun ffi-to-uffi-type (clisp-type) #+clisp clisp-type @@ -103,6 +111,7 @@ (sint32 :int) (uint32 :unsigned-int) (uint8 :unsigned-byte) + (uint16 :short) ; no signed/unsigned types? (boolean :unsigned-int) (ulong :unsigned-long) (int :int) @@ -252,6 +261,18 @@ (x_root double-float) (y_root double-float)) +(def-c-struct gdk-event-key + (type int) + (window c-pointer) + (send-event uint8) + (time uint32) + (state uint) + (keyval uint) + (length int) + (string c-pointer) + (hardware-keycode uint16) + (group uint8)) + (defun event-type (event) (ecase event (-1 :nothing) @@ -347,7 +368,6 @@ (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data2) c-null) (setf (get-slot-value ,iter-var 'gtk-tree-iter 'user-data3) c-null) , at body)) - (eval-when (:compile-toplevel :load-toplevel :execute) (defun as-gtk-type-name (type) From pdenno at common-lisp.net Sat Feb 26 22:38:50 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:38:50 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-list-tree.lisp Message-ID: <20050226223850.CBFF58866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv8415/gtk-ffi Modified Files: gtk-list-tree.lisp Log Message: Declaration of foreign functions for tree store path manipulation. Date: Sat Feb 26 23:38:50 2005 Author: pdenno Index: root/gtk-ffi/gtk-list-tree.lisp diff -u root/gtk-ffi/gtk-list-tree.lisp:1.1 root/gtk-ffi/gtk-list-tree.lisp:1.2 --- root/gtk-ffi/gtk-list-tree.lisp:1.1 Mon Dec 6 21:03:00 2004 +++ root/gtk-ffi/gtk-list-tree.lisp Sat Feb 26 23:38:50 2005 @@ -61,6 +61,24 @@ int) (gtk-tree-view-get-selection ((tree-view c-pointer)) c-pointer) + (gtk-tree-view-get-path-at-pos ((tree-view c-pointer) + (x int) + (y int) + (path c-pointer) + (column c-pointer) + (cell-x c-pointer) + (cell-y c-pointer)) + boolean) + (gtk-tree-view-widget-to-tree-coords ((tree-view c-pointer) + (wx int) + (wy int) + (tx c-pointer) + (ty c-pointer))) + (gtk-tree-view-tree-to-widget-coords ((tree-view c-pointer) + (wx int) + (wy int) + (tx c-pointer) + (ty c-pointer))) ;;tree-model (gtk-tree-model-get ((tree-model c-pointer) @@ -76,6 +94,8 @@ ;;tree-path (gtk-tree-path-new-from-string ((path c-string)) c-pointer) + (gtk-tree-path-to-string ((path c-pointer)) + c-string) (gtk-tree-path-free ((path c-pointer))) ;;tree-selection @@ -146,4 +166,7 @@ (gtk-cell-renderer-toggle-new () c-pointer) (gtk-cell-renderer-pixbuf-new () - c-pointer)) \ No newline at end of file + c-pointer) + (gtk-cell-renderer-set-fixed-size ((cell c-pointer) + (width int) + (height int)))) From pdenno at common-lisp.net Sat Feb 26 22:40:01 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:40:01 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-menu.lisp Message-ID: <20050226224001.359378866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv8438/gtk-ffi Modified Files: gtk-menu.lisp Log Message: Declaration of foreign function gtk-menu-item-get-submenu, though I have had no luck in using it. Date: Sat Feb 26 23:40:00 2005 Author: pdenno Index: root/gtk-ffi/gtk-menu.lisp diff -u root/gtk-ffi/gtk-menu.lisp:1.2 root/gtk-ffi/gtk-menu.lisp:1.3 --- root/gtk-ffi/gtk-menu.lisp:1.2 Tue Dec 14 05:02:05 2004 +++ root/gtk-ffi/gtk-menu.lisp Sat Feb 26 23:40:00 2005 @@ -76,6 +76,8 @@ (right-justified boolean))) (gtk-menu-item-set-submenu ((menu-item c-pointer) (submenu c-pointer))) + (gtk-menu-item-get-submenu ((menu-item c-pointer)) + c-pointer) (gtk-menu-item-remove-submenu ((menu-item c-pointer))) (gtk-menu-item-set-accel-path ((menu-item c-pointer) (acell-path c-pointer))) From pdenno at common-lisp.net Sat Feb 26 22:42:30 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:42:30 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-other.lisp Message-ID: <20050226224230.2A2C88866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv8508/gtk-ffi Modified Files: gtk-other.lisp Log Message: Declaration of libcellsgtk foreign functions. Declaration of widget event mask manipulation functions, functions for checking the version of gtk. Date: Sat Feb 26 23:42:29 2005 Author: pdenno Index: root/gtk-ffi/gtk-other.lisp diff -u root/gtk-ffi/gtk-other.lisp:1.3 root/gtk-ffi/gtk-other.lisp:1.4 --- root/gtk-ffi/gtk-other.lisp:1.3 Wed Feb 16 23:30:03 2005 +++ root/gtk-ffi/gtk-other.lisp Sat Feb 26 23:42:29 2005 @@ -149,7 +149,7 @@ (obey_child boolean)) c-pointer) - ;;separetor + ;;separator (gtk-hseparator-new () c-pointer) (gtk-vseparator-new () @@ -329,6 +329,12 @@ (mods int) (flags int))) (gtk-widget-grab-focus ((widget c-pointer))) + (gtk-widget-add-events ((widget c-pointer) + (events int))) + (gtk-widget-set-events ((widget c-pointer) + (events int))) + (gtk-widget-get-events ((widget c-pointer)) + int) ;;window (gtk-window-new ((type int)) @@ -609,6 +615,35 @@ (above boolean))) (gtk-event-box-set-visible-window ((event-box c-pointer) (visible-window boolean)) - nil nil nil)) + nil nil nil) + + ;; miscellaneous + (gtk-check-version ((required-major uint) + (required-minor uint) + (required-micro uint)) + c-string)) + +#+libcellsgtk +(def-gtk-lib-functions :cgtk + (gtk-adds-dialog-vbox + ((dialog c-pointer)) + c-pointer) + (gtk-adds-text-view-popup-menu + ((treeview c-pointer)) + c-pointer)) + +(defmacro you-need-libcellsgtk (&body names) + `(progn + ,@(loop for name in names + collect `(defun ,name (&rest ignore) + (declare (ignore ignore)) + (error "You need libcellsgtk.so to use function ~A." ',name))))) + +#-libcellsgtk +(you-need-libcellsgtk + gtk-adds-dialog-box + gtk-adds-text-view-popup-menu) + + \ No newline at end of file From pdenno at common-lisp.net Sat Feb 26 22:44:52 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:44:52 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-utilities.lisp Message-ID: <20050226224452.711988866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv8536/gtk-ffi Modified Files: gtk-utilities.lisp Log Message: Use of event button-release-event for popups, because I have failed to get tree-views to send button-press-event. Date: Sat Feb 26 23:44:49 2005 Author: pdenno Index: root/gtk-ffi/gtk-utilities.lisp diff -u root/gtk-ffi/gtk-utilities.lisp:1.12 root/gtk-ffi/gtk-utilities.lisp:1.13 --- root/gtk-ffi/gtk-utilities.lisp:1.12 Wed Feb 16 23:31:53 2005 +++ root/gtk-ffi/gtk-utilities.lisp Sat Feb 26 23:44:48 2005 @@ -85,18 +85,20 @@ ((widget :pointer-void) (signal (* gdk-event-button)) (data :pointer-void)) (declare (ignorable data)) (let ((event (gdk-event-button-type signal))) - (when (eql (event-type event) :button_press) + (when (or (eql (event-type event) :button_press) + (eql (event-type event) :button_release)) (when (= (gdk-event-button-button signal) 3) (gtk-menu-popup widget nil nil nil nil 3 (gdk-event-button-time signal))))) - 1) + 0) (defun gtk-widget-set-popup (widget menu) (gtk-signal-connect-swap widget "button-press-event" - (let ((cbl (ffx:ff-register-callable 'button-press-event-handler))) - #+shhtk (print (list "gtk-widget-set-popup connecting callable" widget cbl)) - cbl) - :data menu)) + (ffx:ff-register-callable 'button-press-event-handler) + :data menu) + (gtk-signal-connect-swap widget "button-release-event" + (ffx:ff-register-callable 'button-press-event-handler) + :data menu)) (defun gtk-list-store-new (col-types) (let ((c-types (ffx:fgn-alloc :int (length col-types)))) @@ -196,8 +198,8 @@ (t (cast item (as-gtk-type-name cell-type)))) #+lispworks (case cell-type - (:string (fli:convert-from-foreign-string (fli:dereference item))) - (t (fli:dereference item))) + (:string (fli:convert-from-foreign-string (deref-pointer item))) + (t (deref-pointer item))) #+cmu (case cell-type (:string (alien:cast (alien:deref item) c-call:c-string)) From pdenno at common-lisp.net Sat Feb 26 22:46:43 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sat, 26 Feb 2005 23:46:43 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/load.lisp Message-ID: <20050226224643.2380B8866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root In directory common-lisp.net:/tmp/cvs-serv9136 Modified Files: load.lisp Log Message: Push :libcellsgtk onto *features* when it can be found. Date: Sat Feb 26 23:46:42 2005 Author: pdenno Index: root/load.lisp diff -u root/load.lisp:1.5 root/load.lisp:1.6 --- root/load.lisp:1.5 Tue Jan 25 16:57:31 2005 +++ root/load.lisp Sat Feb 26 23:46:40 2005 @@ -1,6 +1,6 @@ (in-package :cl-user) -#| Step One: Get ASDF into the game. +#| Step 1: Get ASDF into the game. Obviously not necessary if you always have that loaded. Note that you will have to adjust the pathname to point to where you @@ -21,11 +21,26 @@ (make-pathname :name "config" :type "lisp") *load-pathname*)) -;;;; Step 3: Compile and load via ASDF +;;; Step 3: (completely optional) build libcellsgtk.so (see Makefile) and +;;; place it where the other gtk libraries will be found. + +#+mswindows +(warn "MSWindows users: If you want to use libcellsgtk.so see gtk-ffi/Makefile.") + +#-mswindows +(let ((libpath (cond ((directory "/usr/lib/libgtk*") "/usr/lib/") + ((directory "/opt/gnome/lib/libgtk*") "/opt/gnome/lib/")))) + (if libpath + (if (probe-file (concatenate 'string libpath "libcellsgtk.so")) + (pushnew :libcellsgtk *features*) + (warn "libcellsgtk.so not found. Just a few capabilities will be unavailable.")) + (error "Cannot find a path containing libgtk"))) + +;;;; Step 4: Compile and load via ASDF ; these are handy when one is first working up to getting things to build at all ; but the "test-gtk" ASDF has dependencies which will load everything else, so ; you can just execute that. -; + ;(Asdf:operate 'asdf:load-op :utils-kt :force nil) ;(Asdf:operate 'asdf:load-op :cells :force nil) ;(Asdf:operate 'asdf:load-op :hello-c :force nil) @@ -34,7 +49,6 @@ (Asdf:operate 'asdf:load-op :test-gtk :force nil) -#+Step-4 - +#+Step-5 (test-gtk::gtk-demo) From pdenno at common-lisp.net Sun Feb 27 03:17:31 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sun, 27 Feb 2005 04:17:31 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-dialogs.lisp Message-ID: <20050227031731.CFE7A8866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv24142/cells-gtk/test-gtk Modified Files: test-dialogs.lisp Log Message: Demonstrate dialog with text entry area Date: Sun Feb 27 04:17:29 2005 Author: pdenno Index: root/cells-gtk/test-gtk/test-dialogs.lisp diff -u root/cells-gtk/test-gtk/test-dialogs.lisp:1.1 root/cells-gtk/test-gtk/test-dialogs.lisp:1.2 --- root/cells-gtk/test-gtk/test-dialogs.lisp:1.1 Fri Nov 19 00:40:14 2004 +++ root/cells-gtk/test-gtk/test-dialogs.lisp Sun Feb 27 04:17:28 2005 @@ -26,9 +26,27 @@ (:default-initargs :kids (list (mk-hbox - :kids (loop for message-type in '(:info :warning :question :error) collect - (make-instance 'test-message :message-type message-type))) - (mk-label :md-name :message-response) + :kids + (append + #-libcellsgtk nil + #+libcellsgtk + (list + (mk-button :label "Query for text" + :on-clicked + (callback (w e d) + (let ((dialog + (to-be + (mk-message-dialog + :md-name :rule-name-dialog + :message "Type something:" + :title "My Title" + :message-type :question + :buttons-type :ok-cancel + :content-area (mk-entry :auto-aupdate t))))) + (setf (text (fm^ :message-response)) (md-value dialog)))))) + (loop for message-type in '(:info :warning :question :error) collect + (make-instance 'test-message :message-type message-type)))) + (mk-label :md-name :message-response) (mk-hbox :kids (cons (mk-check-button :md-name :select-multiple-files From pdenno at common-lisp.net Sun Feb 27 03:21:21 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sun, 27 Feb 2005 04:21:21 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-display.lisp Message-ID: <20050227032121.B8A018866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv24412/cells-gtk/test-gtk Modified Files: test-display.lisp Log Message: Remove incorrect package specifier to correspond to Juergen Gmeiner's patch, which moves specials referencing pathnames used in test-gtk out of config.lisp and into test-gtk.lisp Date: Sun Feb 27 04:21:20 2005 Author: pdenno Index: root/cells-gtk/test-gtk/test-display.lisp diff -u root/cells-gtk/test-gtk/test-display.lisp:1.5 root/cells-gtk/test-gtk/test-display.lisp:1.6 --- root/cells-gtk/test-gtk/test-display.lisp:1.5 Wed Feb 16 23:35:57 2005 +++ root/cells-gtk/test-gtk/test-display.lisp Sun Feb 27 04:21:20 2005 @@ -20,7 +20,7 @@ :ratio 1 :kids (list (mk-image :width 200 :height 250 - :filename (namestring cl-user::*tst-image*)))) + :filename (namestring *tst-image*)))) (mk-hseparator) (mk-hbox :kids (list From pdenno at common-lisp.net Sun Feb 27 03:22:28 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sun, 27 Feb 2005 04:22:28 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-gtk.lisp Message-ID: <20050227032228.E982F8866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk In directory common-lisp.net:/tmp/cvs-serv24439/cells-gtk/test-gtk Modified Files: test-gtk.lisp Log Message: Juergen Gmeiner's patch: moves specials referencing pathnames used in test-gtk out of config.lisp and into test-gtk.lisp Date: Sun Feb 27 04:22:28 2005 Author: pdenno Index: root/cells-gtk/test-gtk/test-gtk.lisp diff -u root/cells-gtk/test-gtk/test-gtk.lisp:1.10 root/cells-gtk/test-gtk/test-gtk.lisp:1.11 --- root/cells-gtk/test-gtk/test-gtk.lisp:1.10 Wed Feb 16 23:36:45 2005 +++ root/cells-gtk/test-gtk/test-gtk.lisp Sun Feb 27 04:22:27 2005 @@ -3,16 +3,37 @@ (in-package :test-gtk) +(defvar *test-img-dir* + (make-pathname :name nil :type nil :version nil + :defaults (merge-pathnames + (make-pathname :directory '(:relative :back :back "test-images")) + (parse-namestring *load-truename*)))) +(defvar *splash-image* + (make-pathname :name "splash" :type "png" + :defaults *test-img-dir*)) + +(defvar *small-image* + (make-pathname :name "small" :type "png" + :defaults *test-img-dir*)) + +(defvar *stock-icon-image* + (make-pathname :name "my-g" :type "png" + :defaults *test-img-dir*)) + +(defvar *tst-image* + (make-pathname :name "tst" :type "gif" + :defaults *test-img-dir*)) + (defmodel test-gtk (gtk-app) () (:default-initargs :title "GTK Testing" ;;:tooltips nil ;;dkwt ;;:tooltips-enable nil ;;dkwt - :icon (namestring cl-user::*small-image*) - :stock-icons (list (list :my-g (namestring cl-user::*stock-icon-image*))) + :icon (namestring *small-image*) + :stock-icons (list (list :my-g (namestring *stock-icon-image*))) :position :center - :splash-screen-image (namestring cl-user::*splash-image*) + :splash-screen-image (namestring *splash-image*) :width 550 :height 550 :kids (let ((tabs '("Buttons" "Display" "Layout" From pdenno at common-lisp.net Sun Feb 27 03:23:20 2005 From: pdenno at common-lisp.net (Peter Denno) Date: Sun, 27 Feb 2005 04:23:20 +0100 (CET) Subject: [cells-gtk-cvs] CVS update: root/config.lisp Message-ID: <20050227032320.145E08866C@common-lisp.net> Update of /project/cells-gtk/cvsroot/root In directory common-lisp.net:/tmp/cvs-serv24461 Modified Files: config.lisp Log Message: Juergen Gmeiner's patch: moves specials referencing pathnames used in test-gtk out of config.lisp and into test-gtk.lisp Date: Sun Feb 27 04:23:19 2005 Author: pdenno Index: root/config.lisp diff -u root/config.lisp:1.2 root/config.lisp:1.3 --- root/config.lisp:1.2 Wed Feb 16 23:34:43 2005 +++ root/config.lisp Sun Feb 27 04:23:19 2005 @@ -6,7 +6,8 @@ #| - Tell ASDF where to find everything + Tell ASDF where to find everything. + This isn't used if you are loading a snapshot tarball. |# @@ -39,27 +40,3 @@ *load-pathname*) asdf:*central-registry*) -(defparameter *splash-image* - (merge-pathnames - (make-pathname :directory '(:relative "test-images") - :name "splash" - :type "png") - *load-pathname*)) - -(defparameter *small-image* - (merge-pathnames - (make-pathname :directory '(:relative "test-images") - :name "small" :type "png") - *load-pathname*)) - -(defparameter *tst-image* - (merge-pathnames - (make-pathname :directory '(:relative "test-images") - :name "tst" :type "gif") - *load-pathname*)) - -(defparameter *stock-icon-image* - (merge-pathnames - (make-pathname :directory '(:relative "test-images") - :name "my-g" :type "png") - *load-pathname*)) \ No newline at end of file