Update of /project/cells/cvsroot/cells-gtk In directory clnet:/tmp/cvs-serv5749

Modified Files: dialogs.lisp gtk-app.lisp menus.lisp tree-view.lisp widgets.lisp Log Message: fixed submenus

--- /project/cells/cvsroot/cells-gtk/dialogs.lisp 2008/01/30 14:21:01 1.2 +++ /project/cells/cvsroot/cells-gtk/dialogs.lisp 2008/01/30 21:13:44 1.3 @@ -23,27 +23,27 @@ ((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))) + :yes-no + :close))) (content-area :owning t :accessor content-area :initarg :content-area :initform nil)) (markup) () :position :mouse :new-args (c_1 (list +c-null+ - 2 - (ecase (message-type self) - (:info 0) - (:warning 1) - (:question 2) - (:error 3)) - (ecase (buttons-type self) - (:none 0) - (:ok 1) - (:close 2) - (:cancel 3) - (:yes-no 4) - (:ok-cancel 5)) - (message self)))) + 2 + (ecase (message-type self) + (:info 0) + (:warning 1) + (:question 2) + (:error 3)) + (ecase (buttons-type self) + (:none 0) + (:ok 1) + (:close 2) + (:cancel 3) + (:yes-no 4) + (:ok-cancel 5)) + (message self))))

(defmethod md-awaken :after ((self message-dialog)) (print 'md-awaken-after) @@ -55,6 +55,7 @@ (-7 :close) (-8 :yes) (-9 :no)))) + (with-slots (content-area) self (when content-area (setf (value self) (value content-area)) @@ -146,6 +147,8 @@ (if (select-multiple self) (setf (value self) (gtk-file-chooser-get-filenames-strs (id self))) (setf (value self) (gtk-file-chooser-get-filename (id self))))) + (trc "destroying file-chooser-dialog" (id self) self) + (break "ok?") (gtk-widget-destroy (id self)) (gtk-object-forget (id self) self)))

--- /project/cells/cvsroot/cells-gtk/gtk-app.lisp 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/gtk-app.lisp 2008/01/30 21:13:44 1.2 @@ -83,39 +83,47 @@ (to-be splash) (setf (visible splash) t) (loop while (gtk-events-pending) do - (gtk-main-iteration))) - + (gtk-main-iteration))) + (to-be app) - + (when splash (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)) - (unwind-protect - (loop - (restart-case - (handler-bind - ((gtk-user-signals-quit #'give-up-cleanly) - (gtk-continuable-error #'continue-from-error) - (error #'report-error-and-give-up)) - #-lispworks - (gtk-main) - #+lispworks ; give slime a chance. - (loop ; just running your app in a process is not enough. - (loop while (gtk-events-pending) do - (gtk-main-iteration-do nil)) - (process-wait-with-timeout .01 "GTK event loop waiting"))) - ;; Restart cases - (continue-from-error (c) - (show-message (format nil "Cells-GTK Error: ~a" (text c)) - :message-type :error :title "Cells-GTK Error")) - (give-up-cleanly () (return-from start-app)) - (report-error-and-give-up (c) (error c)))) - ;; clean-up forms (takes down application). - (not-to-be app) ; while (> (gtk-main-level) 0) do (gtk-main-quit) NG. Why? - (loop for i from 0 to 30 do (gtk-main-quit)) - (loop while (gtk-events-pending) do (gtk-main-iteration-do nil))))))) + (unwind-protect + (gtk-main) + #+chill + (loop + (restart-case + (handler-bind + ((gtk-user-signals-quit #'give-up-cleanly) + (gtk-continuable-error #'continue-from-error) + (error #'report-error-and-give-up)) + #-lispworks + (gtk-main) + #+lispworks ; give slime a chance. + (loop ; just running your app in a process is not enough. + (loop while (gtk-events-pending) do + (gtk-main-iteration-do nil)) + (process-wait-with-timeout .01 "GTK event loop waiting"))) + ;; Restart cases + (continue-from-error (c) + (format t "~&Cells-GTK Error: ~a" (text c)) + (show-message (format nil "Cells-GTK Error: ~a" (text c)) + :message-type :error :title "Cells-GTK Error")) + (give-up-cleanly () (return-from start-app)) + (report-error-and-give-up (c) (error c)))) + ;; clean-up forms (takes down application). + (trcx not-to-be-app 42) + (not-to-be app) ; while (> (gtk-main-level) 0) do (gtk-main-quit) NG. Why? + (trcx gtk-main-quits 42) + (loop for i from 0 to 30 do (gtk-main-quit)) + (trcx mopping-events 42) + (loop while (gtk-events-pending) do + (trcx gtk-main-iter-do 42) + (gtk-main-iteration-do nil)))))))

;;; Restarts (defun continue-from-error (c) --- /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/28 23:59:22 1.1 +++ /project/cells/cvsroot/cells-gtk/menus.lisp 2008/01/30 21:13:44 1.2 @@ -184,11 +184,7 @@ () () () :padding 0)

-(defobserver .kids ((self menu-shell)) - (when new-value - (dolist (kid new-value) - (gtk-menu-shell-append (id self) (id kid)))) - #+clisp (call-next-method)) +

(def-widget menu-bar (menu-shell) () () ()) @@ -207,10 +203,35 @@ (mk-accel-label :text (label self)))))) (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 + (submenu :initarg :submenu :cell nil :accessor submenu :initform nil) ; gtk-menu-item-get-submenu not doing it. POD + (appended? :initarg :appended? :cell nil :accessor appended? :initform nil)) (right-justified) (activate))

+(defobserver .kids ((self menu-shell)) + (when new-value + (dolist (kid new-value) + + (if (appended? kid) + (break "ducking duplicate append of kid ~a to (~a ~a) already in ~a" kid (id self) self (appended? kid)) + (progn + (trc nil "mshell" (id self) self :kid kid :kidid (id kid) :kidpar (fm-parent kid)) + (gtk-menu-shell-append (id self) (id kid)) + (setf (appended? kid) (cons (id self) self)))))) + #+clisp (call-next-method)) + +(defobserver .kids ((self menu-item)) + (when old-value ; pod never occurs ? + (gtk-menu-item-remove-submenu (id self))) + (when new-value + (with-integrity (:change 'set-sub-menu-actually) + (unless (submenu self) + (let ((subid (id (setf (submenu self) + (make-instance 'menu + :md-name (gensym "SUBMENU-MENU") + :kids new-value))))) ;; <=== was mak + (gtk-menu-item-set-submenu (id self) subid)))))) + (defun accel-key-mods (accel) (destructuring-bind (key &rest mods-lst) accel (let ((mods 0)) @@ -237,13 +258,10 @@ (gtk-accel-label-set-accel-widget (id new-value) (id self)) (gtk-container-add (id self) (id new-value))))

-(defobserver .kids ((self menu-item)) - (when old-value ; pod never occurs ? - (gtk-menu-item-remove-submenu (id self))) - (when new-value - (with-integrity (:change 'set-sub-menu-actually) - (gtk-menu-item-set-submenu (id self) - (id (setf (submenu self) (make-be 'menu :kids new-value))))))) + + +;;;if the make-be is a make-instance we do not crash, but we get an empty submenu (or +;;;is it just disabled?).

(def-widget check-menu-item (menu-item) ((init :accessor init :initarg :init :initform nil)) --- /project/cells/cvsroot/cells-gtk/tree-view.lisp 2008/01/28 23:59:24 1.1 +++ /project/cells/cvsroot/cells-gtk/tree-view.lisp 2008/01/30 21:13:44 1.2 @@ -35,7 +35,7 @@ () :new-args (c_1 (list (item-types self))))

-(defun fail (&rest args) (declare (ignore args))) +(defun tv-fail (&rest args) (declare (ignore args)))

(def-widget tree-view () ((columns-def :accessor columns-def :initarg :columns :initform nil) @@ -52,7 +52,7 @@ :container self col-init)) (column-inits self)))) - (select-if :unchanged-if #'fail + (select-if :unchanged-if #'tv-fail :accessor select-if :initarg :select-if :initform (c-in nil)) (roots :accessor roots :initarg :roots :initform nil) (print-fn :accessor print-fn :initarg :print-fn :initform #'identity) --- /project/cells/cvsroot/cells-gtk/widgets.lisp 2008/01/30 14:21:01 1.2 +++ /project/cells/cvsroot/cells-gtk/widgets.lisp 2008/01/30 21:13:44 1.3 @@ -310,7 +310,8 @@

(defmethod not-to-be :after ((self widget)) (when t ; *gtk-debug* - (trc "WIDGET DESTROY" (md-name self) self) (force-output)) + (trc nil "WIDGET DESTROY" (md-name self) (type-of self) self) + (force-output)) (gtk-object-forget (slot-value self 'id) self) (gtk-widget-destroy (slot-value self 'id)))