February 2005 - cells-gtk-cvs@common-lisp.net

[cells-gtk-cvs] CVS update: root/cells-gtk/widgets.lisp
by pdenno＠common-lisp.net 26 Feb '05

26 Feb '05

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))

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/tree-view.lisp
by pdenno＠common-lisp.net 26 Feb '05

26 Feb '05

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))

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/textview.lisp
by pdenno＠common-lisp.net 26 Feb '05

26 Feb '05

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 ,@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))) + + + + + + +

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/menus.lisp
by pdenno＠common-lisp.net 26 Feb '05

26 Feb '05

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))

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp
by pdenno＠common-lisp.net 26 Feb '05

26 Feb '05

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

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/dialogs.lisp
by pdenno＠common-lisp.net 26 Feb '05

26 Feb '05

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)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/conditions.lisp
by pdenno＠common-lisp.net 26 Feb '05

26 Feb '05

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 ,@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) ())

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/cells-gtk.lisp
by pdenno＠common-lisp.net 26 Feb '05

26 Feb '05

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)))))

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-textview.lisp
by pdenno＠common-lisp.net 26 Feb '05

26 Feb '05

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))))))))))))) +

1 0

[cells-gtk-cvs] CVS update: root/FAQ.txt
by pdenno＠common-lisp.net 26 Feb '05

26 Feb '05

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

1 0