[cells-cvs] CVS cells-gtk
ktilton
ktilton at common-lisp.net
Wed Jan 30 21:13:44 UTC 2008
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)))
More information about the Cells-cvs
mailing list