[gtk-cffi-cvs] CVS gtk-cffi/gtk
CVS User rklochkov
rklochkov at common-lisp.net
Sun Jul 29 15:13:59 UTC 2012
Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk
In directory tiger.common-lisp.net:/tmp/cvs-serv5173/gtk
Modified Files:
box.lisp cell-layout.lisp container.lisp dialog.lisp
enums.lisp gtk-cffi.asd image.lisp list-store.lisp misc.lisp
package.lisp progress-bar.lisp statusbar.lisp tree-model.lisp
tree-view.lisp
Log Message:
Fixed memory leaks
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/box.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/box.lisp 2012/07/29 15:13:59 1.2
@@ -1,26 +1,53 @@
(in-package :gtk-cffi)
-(defclass box (container)
+(defclass box (container orientable)
((expand :initform t :initarg :expand)
(fill :initform t :initarg :fill)
(padding :initform 0 :initarg :padding)
(cur-param :initform nil :allocation :class)))
-(defcfun "gtk_box_pack_start" :void (box pobject) (widget pobject)
+(defcfun gtk-box-pack-start :void (box pobject) (widget pobject)
(expand :boolean) (fill :boolean) (padding :int))
-(defcfun "gtk_box_pack_end" :void (box pobject) (widget pobject)
+(defcfun gtk-box-pack-end :void (box pobject) (widget pobject)
(expand :boolean) (fill :boolean) (padding :int))
+(defslots box
+ homogeneous :boolean
+ spacing :int)
+
+(deffuns box
+ (reorder-child :void (child pobject) (position :int)))
+
+(defcfun gtk-box-query-child-packing :void
+ (box pobject) (child pobject) (expand :pointer) (fill :pointer)
+ (padding :pointer) (pack-type :pointer))
+
+(defcfun gtk-box-set-child-packing :void
+ (box pobject) (child pobject) (expand :boolean) (fill :boolean)
+ (padding :uint) (pack-type pack-type))
+
+(defgeneric child-packing (box child)
+ (:method ((box box) (child widget))
+ (with-foreign-outs-list ((expand :boolean) (fill :boolean)
+ (padding :uint) (pack-type 'pack-type)) :ignore
+ (gtk-box-query-child-packing box child expand fill padding pack-type))))
+
+(defgeneric (setf child-packing) (value box child)
+ (:method (value (box box) (child widget))
+ (destructuring-bind (expand fill padding pack-type) value
+ (gtk-box-set-child-packing box child expand fill padding pack-type))))
+
+
(defmethod pack ((box box) (widget widget)
&key end
(expand :default) (fill :default) (padding :default))
(macrolet ((default (field)
`(if (eq ,field :default) (slot-value box ',field) ,field)))
- (debug-out "~a~%" (list box widget
- expand (default expand)
- fill (default fill)
- padding (default padding)))
+; (debug-out "~a~%" (list box widget
+; expand (default expand)
+; fill (default fill)
+; padding (default padding)))
(funcall (if end #'gtk-box-pack-end
#'gtk-box-pack-start)
box widget
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-layout.lisp 2012/05/08 09:38:07 1.4
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-layout.lisp 2012/07/29 15:13:59 1.5
@@ -5,12 +5,11 @@
(defcfun "gtk_cell_layout_add_attribute" :void
- (layout pobject) (cell pobject) (attr :string) (column :int))
+ (layout pobject) (cell pobject) (attr cffi-keyword) (column :int))
(defmethod add-attribute ((cell-layout cell-layout)
(cell-renderer cell-renderer) attr column)
- (gtk-cell-layout-add-attribute cell-layout cell-renderer
- (string-downcase attr) column))
+ (gtk-cell-layout-add-attribute cell-layout cell-renderer attr column))
(defcfun "gtk_cell_layout_pack_start" :void
(cell-layout pobject) (renderer pobject) (expand :boolean))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2012/05/07 09:32:47 1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2012/07/29 15:13:59 1.4
@@ -52,38 +52,37 @@
(setf (slot-value ,container param) ,token)))))
(defcfun gtk-container-child-get-property :void
- (container pobject) (widget pobject) (name :string) (value pobject))
+ (container pobject) (widget pobject) (name cffi-keyword) (value pobject))
(defcfun gtk-container-child-set-property :void
- (container pobject) (widget pobject) (name :string) (value pobject))
+ (container pobject) (widget pobject) (name cffi-keyword) (value pobject))
(defgeneric child-property-type (container key))
(defmethod child-property-type ((container container) (key symbol))
(child-property-type container (string-downcase key)))
-(defmethod child-property-type ((container container) (key string))
+(defmethod child-property-type ((container container) key)
"Should return GType of property KEY."
- (or (cdr (assoc key (%child-properties container)))
- (let* ((gclass (make-instance 'g-object-cffi:g-object-class
- :object container))
- (prop (find-child-property gclass key)))
- (when prop
- (let ((g-type (g-type prop)))
- (setf (%child-properties container)
- (acons key g-type (%child-properties container)))
- g-type)))
- (error "Incorrect child property name ~a" key)))
+ (let ((skey (string-downcase key)))
+ (or (cdr (assoc skey (%child-properties container) :test #'string=))
+ (let* ((gclass (make-instance 'g-object-cffi:g-object-class
+ :object container))
+ (prop (find-child-property gclass skey)))
+ (when prop
+ (let ((g-type (g-type prop)))
+ (setf (%child-properties container)
+ (acons skey g-type (%child-properties container)))
+ g-type)))
+ (error "Incorrect child property name ~a" key))))
(defmethod child-property ((widget widget) (parent container) &rest keys)
(funcall (lambda (x) (if (cdr x) x (car x)))
(mapcar (lambda (key)
- (let* ((skey (string-downcase key))
- (g-type (child-property-type parent skey)))
- (with-g-value
- (:g-type g-type)
- (gtk-container-child-get-property
- parent widget skey *g-value*))))
+ (with-g-value
+ (:g-type (child-property-type parent skey))
+ (gtk-container-child-get-property
+ parent widget key *g-value*)))
keys)))
(defmethod child-property ((widget widget) (parent null) &rest keys)
@@ -97,11 +96,10 @@
(list value1 value2))"
(mapc (lambda (key value)
(declare (type (or symbol string) key))
- (let ((skey (string-downcase key)))
- (with-g-value (:value value
- :g-type (child-property-type parent skey))
- (gtk-container-child-set-property parent widget
- skey *g-value*))))
+ (with-g-value (:value value
+ :g-type (child-property-type parent skey))
+ (gtk-container-child-set-property parent widget
+ key *g-value*)))
keys (if (listp values) values (list values))))
(defmethod (setf child-property) (values (widget widget) (parent null)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/dialog.lisp 2012/03/08 09:58:12 1.6
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/dialog.lisp 2012/07/29 15:13:59 1.7
@@ -25,39 +25,35 @@
(defcfun gtk-dialog-new :pointer)
(defmethod gconstructor ((dialog dialog)
- &key title parent (flags 0) &allow-other-keys)
- (if title
- (gtk-dialog-new-with-buttons title parent flags (null-pointer))
- (gtk-dialog-new)))
+ &key title parent (flags 0) with-buttons
+ &allow-other-keys)
+ (prog1
+ (if title
+ (gtk-dialog-new-with-buttons title parent flags (null-pointer))
+ (gtk-dialog-new))
+ (dolist (button-description with-buttons)
+ (destructuring-bind (str resp) button-description
+ (add-button dialog str resp)))))
-(defmethod initialize-instance
- :after ((dialog dialog)
- &key with-buttons &allow-other-keys)
- (mapcar
- (lambda (x)
- (destructuring-bind (str resp) x
- (add-button dialog str resp)))
- with-buttons))
-
-
(defcfun gtk-dialog-run dialog-response (dialog pobject))
(defgeneric run (dialog &key)
- (:method ((dialog dialog) &key (keep-alive t))
+ (:method ((dialog dialog) &key cleanup)
(prog1 (gtk-dialog-run dialog)
- (unless keep-alive
+ (when cleanup
(destroy dialog)))))
-(defcfun gtk-dialog-add-button pobject (dialog pobject)
- (str :string) (resp dialog-response))
+;(defcfun gtk-dialog-add-button pobject (dialog pobject)
+; (str :string) (resp dialog-response))
-(defgeneric add-button (dialog string response)
- (:method ((dialog dialog) str response)
- (gtk-dialog-add-button dialog (if (keywordp str) (string-downcase str) str)
- response)))
+;(defgeneric add-button (dialog string response)
+; (:method ((dialog dialog) str response)
+; (gtk-dialog-add-button dialog (if (keywordp str) (string-downcase str) str)
+; response)))
(deffuns dialog
(response :void (resp dialog-response))
+ (add-button pobject (name cffi-keyword) (response dialog-response))
(add-action-widget :void (child pobject) &key (response dialog-response))
(:set default-response dialog-response)
(:set-last response-sensitive :boolean (response dialog-response))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2011/09/16 17:58:33 1.4
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2012/07/29 15:13:59 1.5
@@ -27,4 +27,6 @@
:top-left :bottom-left :top-right :bottom-right)
(defcenum justification
- :left :right :center :fill)
\ No newline at end of file
+ :left :right :center :fill)
+
+(defcenum pack-type :start :end)
\ No newline at end of file
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/05/08 09:38:07 1.19
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/07/29 15:13:59 1.20
@@ -44,7 +44,7 @@
(defsystem gtk-cffi-misc
:description "Interface to GTK/Glib via CFFI"
:author "Roman Klochkov <kalimehtar at mail.ru>"
- :version "0.1"
+ :version "0.99"
:license "LLGPL"
:depends-on (gtk-cffi-widget)
:components
@@ -53,7 +53,7 @@
(defsystem gtk-cffi-label
:description "Interface to GTK/Glib via CFFI"
:author "Roman Klochkov <kalimehtar at mail.ru>"
- :version "0.1"
+ :version "0.99"
:license "LLGPL"
:depends-on (gtk-cffi-misc)
:components
@@ -122,7 +122,7 @@
(defsystem gtk-cffi-box
:description "Interface to GTK/Glib via CFFI"
:author "Roman Klochkov <kalimehtar at mail.ru>"
- :version "0.1"
+ :version "0.99"
:license "LLGPL"
:depends-on (gtk-cffi-container)
:components
@@ -131,7 +131,7 @@
(defsystem gtk-cffi-hbox
:description "Interface to GTK/Glib via CFFI"
:author "Roman Klochkov <kalimehtar at mail.ru>"
- :version "0.1"
+ :version "0.99"
:license "LLGPL"
:depends-on (gtk-cffi-box)
:components
@@ -140,7 +140,7 @@
(defsystem gtk-cffi-vbox
:description "Interface to GTK/Glib via CFFI"
:author "Roman Klochkov <kalimehtar at mail.ru>"
- :version "0.1"
+ :version "0.99"
:license "LLGPL"
:depends-on (gtk-cffi-box)
:components
@@ -348,6 +348,15 @@
:components
((:file message-dialog)))
+(defsystem gtk-cffi-info-bar
+ :description "Interface to GTK/Glib via CFFI"
+ :author "Roman Klochkov <kalimehtar at mail.ru>"
+ :version "0.99"
+ :license "LLGPL"
+ :depends-on (gtk-cffi-message-dialog gtk-cffi-box)
+ :components
+ ((:file info-bar)))
+
(defsystem gtk-cffi-file-chooser
:description "Interface to GTK/Glib via CFFI"
:author "Roman Klochkov <kalimehtar at mail.ru>"
@@ -379,7 +388,7 @@
(defsystem gtk-cffi-progress-bar
:description "Interface to GTK/Glib via CFFI"
:author "Roman Klochkov <kalimehtar at mail.ru>"
- :version "0.1"
+ :version "0.99"
:license "LLGPL"
:depends-on (gtk-cffi-widget)
:components
@@ -451,7 +460,7 @@
(defsystem gtk-cffi-statusbar
:description "Interface to GTK/Glib via CFFI"
:author "Roman Klochkov <kalimehtar at mail.ru>"
- :version "0.1"
+ :version "0.99"
:license "LLGPL"
:depends-on (gtk-cffi-hbox)
:components
@@ -460,7 +469,7 @@
(defsystem gtk-cffi-image
:description "Interface to GTK/Glib via CFFI"
:author "Roman Klochkov <kalimehtar at mail.ru>"
- :version "0.1"
+ :version "0.99"
:license "LLGPL"
:depends-on (gtk-cffi-misc)
:components
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/image.lisp 2012/05/07 09:02:04 1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/image.lisp 2012/07/29 15:13:59 1.4
@@ -50,7 +50,7 @@
(image pobject) (stock-id :string) (size icon-size))
(defcfun gtk-image-set-from-gicon :pointer
(image pobject) (gicon pobject) (icon-size icon-size))
-(defcfun gtk-image-clear :void (image pobject))
+;(defcfun gtk-image-clear :void (image pobject))
(defmethod reinitialize-instance ((image image) &key file pixbuf stock-id gicon
@@ -63,7 +63,7 @@
(icon-name (gtk-image-set-from-icon-name image icon-name icon-size))
(animation (gtk-image-set-from-animation image animation))
(gicon (gtk-image-set-from-gicon image gicon icon-size))
- (t (gtk-image-clear image))))
+ (t (clear image))))
(defcenum image-type
:empty :pixbuf :stock :icon-set :animation :icon-name :gicon)
@@ -71,7 +71,8 @@
(deffuns image
(:get pixbuf pobject)
(:get animation pobject)
- (:get storage-type image-type))
+ (:get storage-type image-type)
+ (clear :void))
(defcfun gtk-image-get-icon-set :void (image pobject) (icon-set :pointer)
(icon-size :pointer))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/list-store.lisp 2012/03/08 09:58:12 1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/list-store.lisp 2012/07/29 15:13:59 1.4
@@ -30,18 +30,26 @@
(mapc (lambda (row) (append-values list-store row)) values)))
-(defcfun "gtk_list_store_append" :void (store pobject) (iter pobject))
+(defcfun "gtk_list_store_append" :void
+ (store pobject) (iter (struct tree-iter :out t)))
+
+(defun show-iter (prefix tree-iter)
+ (format t "~a: ~a ~a ~a~%" prefix tree-iter (pointer tree-iter)
+ (when (slot-boundp tree-iter 'cffi-objects::value)
+ (slot-value tree-iter 'cffi-objects::value))))
+
(defmethod append-iter ((list-store list-store) &optional
(tree-iter (tree-iter list-store)))
- (gtk-list-store-append list-store tree-iter))
+ (gtk-list-store-append list-store tree-iter)
+ (show-iter "appended" tree-iter))
-(defcfun "gtk_list_store_set_value" :void (store pobject) (iter pobject)
- (column :int) (g-value pobject))
+(defcfun "gtk_list_store_set_value" :void (store pobject)
+ (iter (struct tree-iter)) (column :int) (g-value pobject))
(defmethod (setf model-values)
(values (list-store list-store)
- &key (iter (tree-iter list-store)) col (columns (when col (list col))))
+ &key (tree-iter (tree-iter list-store)) col (columns (when col (list col))))
"Example: (setf (model-values list-store :col 1) \"val1\")"
(declare (type list columns values))
(let ((%cols (append columns (loop :for i
@@ -51,8 +59,9 @@
(mapcar
(lambda (col val)
(with-g-value (:value val :g-type (column-type list-store col))
+ (show-iter "set" tree-iter)
(gtk-list-store-set-value list-store
- iter col *g-value*)))
+ tree-iter col *g-value*)))
%cols values)))
(defcfun "gtk_list_store_clear" :void (store pobject))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/misc.lisp 2012/05/07 09:02:04 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/misc.lisp 2012/07/29 15:13:59 1.3
@@ -15,20 +15,23 @@
(defcfun gtk-misc-get-alignment :void (misc pobject)
(x :pointer) (y :pointer))
-(defmethod alignment ((misc misc))
- (with-foreign-outs-list ((x :float) (y :float)) :ignore
- (gtk-misc-get-alignment misc x y)))
+(defgeneric alignment (misc)
+ (:method ((misc misc))
+ (with-foreign-outs-list ((x :float) (y :float)) :ignore
+ (gtk-misc-get-alignment misc x y))))
(defcfun gtk-misc-set-padding :void (misc pobject) (x :int) (y :int))
-(defmethod (setf padding) (coords (misc misc))
- (gtk-misc-set-padding misc
- (first coords)
- (second coords)))
+(defgeneric (setf padding) (coords misc)
+ (:method (coords (misc misc))
+ (gtk-misc-set-padding misc
+ (first coords)
+ (second coords))))
(save-setter misc padding)
(defcfun gtk-misc-get-padding :void (misc pobject) (x :pointer) (y :pointer))
-(defmethod padding ((misc misc))
- (with-foreign-outs-list ((x :int) (y :int)) :ignore
- (gtk-misc-get-padding misc x y)))
+(defgeneric padding (misc)
+ (:method ((misc misc))
+ (with-foreign-outs-list ((x :int) (y :int)) :ignore
+ (gtk-misc-get-padding misc x y))))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/07/21 19:26:39 1.21
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/07/29 15:13:59 1.22
@@ -351,9 +351,14 @@
#:button
#:box
+ ;; box slots
+ #:spacing
+ #:homogeneous
;; box methods
#:pack
#:pack*
+ #:reorder-child
+ #:child-packing
#:v-box
@@ -808,6 +813,8 @@
#:show-text
#:ellipsize
#:pulse-step
+ ;; methods
+ #:pulse
#:table
;; table methods
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/progress-bar.lisp 2012/05/07 09:02:04 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/progress-bar.lisp 2012/07/29 15:13:59 1.3
@@ -23,6 +23,7 @@
(deffuns progress-bar
(:get text :string &key)
- (:set text :string &key))
+ (:set text :string &key)
+ (pulse :void))
(init-slots progress-bar)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/statusbar.lisp 2012/05/13 16:20:07 1.6
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/statusbar.lisp 2012/07/29 15:13:59 1.7
@@ -1,6 +1,6 @@
(in-package :gtk-cffi)
-(defclass statusbar (h-box)
+(defclass statusbar (box)
())
(defcfun "gtk_statusbar_new" :pointer)
@@ -8,7 +8,7 @@
(defmethod gconstructor ((statusbar statusbar) &key &allow-other-keys)
(gtk-statusbar-new))
-(defgtkfuns statusbar
+(deffuns statusbar
((statusbar-push . push) :uint (context-id :uint) (text :string))
((statusbar-pop . pop) :void (context-id :uint))
(:get context-id :uint (context pstring))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/07/21 19:26:39 1.10
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/07/29 15:13:59 1.11
@@ -92,11 +92,11 @@
(defcfun "gtk_tree_iter_free" :void (iter pobject))
-(defmethod free-struct ((class (eql 'tree-iter)) value)
- (gtk-tree-iter-free value))
+;(defmethod free-struct ((class (eql 'tree-iter)) value)
+; (gtk-tree-iter-free value))
-(defmethod free :before ((tree-iter tree-iter))
- (gtk-tree-iter-free tree-iter))
+;(defmethod free :before ((tree-iter tree-iter))
+; (gtk-tree-iter-free tree-iter))
(defclass tree-model (object)
((columns :accessor columns :initarg :columns)
@@ -172,7 +172,7 @@
(defcfun gtk-tree-model-get-iter :boolean
(model pobject) (iter (struct tree-iter :out t)) (path tree-path))
-(defmethod path->iter ((tree-model tree-model) (tree-path tree-path)
+(defmethod path->iter ((tree-model tree-model) tree-path
&optional (tree-iter (tree-iter tree-model)))
(gtk-tree-model-get-iter tree-model tree-iter tree-path)
tree-iter)
@@ -180,7 +180,7 @@
(defcfun "gtk_tree_model_get_iter_from_string" :boolean
(model pobject) (iter (struct tree-iter :out t)) (path :string))
-(defmethod path->iter ((tree-model tree-model) tree-path-string
+(defmethod path->iter ((tree-model tree-model) (tree-path-string string)
&optional (tree-iter (tree-iter tree-model)))
(gtk-tree-model-get-iter-from-string tree-model tree-iter tree-path-string)
tree-iter)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view.lisp 2012/07/21 19:26:39 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view.lisp 2012/07/29 15:13:59 1.3
@@ -28,7 +28,13 @@
(when (cdr selected)
(apply on-select selected)))))))
+(deffuns tree-view
+ (remove-column :int (column pobject)))
+
+
(defmethod (setf columns) (columns (tree-view tree-view))
+ (dolist (column (columns tree-view))
+ (remove-column tree-view column))
(labels
((mk-column (column colnum)
(cond
More information about the gtk-cffi-cvs
mailing list