From rklochkov at common-lisp.net Sun Oct 7 12:02:11 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 07 Oct 2012 05:02:11 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/examples Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/examples In directory tiger.common-lisp.net:/tmp/cvs-serv28209/examples Modified Files: ex1.lisp ex3-flash-button.lisp ex4.lisp ex5.lisp ex7.lisp ex9.lisp Log Message: Fixed examples. Changed cell properties for tree-column to be set as :attributes Fixed double init in g-value. --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex1.lisp 2011/08/26 17:16:13 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex1.lisp 2012/10/07 12:02:10 1.3 @@ -31,15 +31,15 @@ (setf (gsignal window :destroy) :gtk-main-quit) -(setf (border-width window) 25) +;(setf (border-width window) 25) -(setf (default-size window) '(400 100)) +;(setf (default-size window) '(400 100)) ;(setf button (make-instance 'button :label "gtk-ok" :type :stock)) (setf button (make-instance 'button :pointer (gtk-cffi::gtk-button-new-from-stock "gtk-ok"))) -;(setf (color button :type :bg) "red") +(setf (color button :type :bg) "red") (setf (color button) "#0000ff") (setf (font button) "Times New Roman Italic 24") --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex3-flash-button.lisp 2011/08/26 17:16:13 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex3-flash-button.lisp 2012/10/07 12:02:10 1.3 @@ -31,7 +31,7 @@ (setf button (make-instance 'button :label "Click Me!")) (setf (size-request button) '(80 32) - (color button :background t) "#FFCC66") + (color button :type :bg) "#FFCC66") (defvar *TIMEOUT*) @@ -46,11 +46,11 @@ (realize window) -(defparameter *ORG-BG* (color window :background t)) +(defparameter *ORG-BG* (color window :type :bg)) (let (i) (defun flash (button bgcolor) - (setf (color button :background t) (if i *ORG-BG* bgcolor)) + (setf (color button :type :bg) (if i *ORG-BG* bgcolor)) (setf i (not i)) t)) (setf *TIMEOUT* (timeout-add 200 #'flash :data (list button "#FFCC66"))) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex4.lisp 2012/05/07 09:02:03 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex4.lisp 2012/10/07 12:02:11 1.4 @@ -91,7 +91,7 @@ (add scrolled-win *view*)) (let ((field-header '("Row #" "Description" "Qty" "Price")) - (field-justification '(0 0 .5 1))) + (field-justification '(0.0 0.0 .5 1.0))) (loop :for col :from 0 :below (length field-header) :do (let ((cell-renderer (make-instance 'cell-renderer-text))) (setf (property cell-renderer :xalign) @@ -99,8 +99,10 @@ (let ((column (make-instance 'tree-view-column :title (nth col field-header) :cell cell-renderer - :text (if (= col 3) 7 col)))) -; :cell-background 6))) + :attributes + (list + "text" (if (= col 3) 7 col) + :cell-background 6)))) (setf (alignment column) (nth col field-justification)) (setf (sort-column-id column) col) @@ -126,9 +128,9 @@ "#dddddd" "#ffffff") (format nil "$~,2f" (fourth values))))) (append-values *model* values))) - - (let ((selection (get-selection *view*))) - (setf (mode selection) :multiple) + (format t "Num rows: ~a~%" (iter-n-children *model* nil)) + (let ((selection (selection *view*))) + ;(setf (mode selection) :multiple) (format t "mode: ~a~%" (mode selection)) ;(format t "read mode: ~a~%" (gtk-cffi::gtk-tree-selection-get-mode selection)) (setf (gsignal selection :changed) (cffi:callback on-selection)) @@ -159,39 +161,40 @@ event-box))) (cffi:defcallback format-col - :void ((column pobject) (cell pobject) - (model pobject) (iter-ptr :pointer) - (col-num pdata)) - ;(declare (optimize speed)) - ;(format t - ; "~A ~A ~A ~A ~A~%" column cell model iter col-num) - (let* ((iter (make-instance 'tree-iter :pointer iter-ptr)) - ;; (row-num (cffi:mem-aref -;; (gtk-cffi::gtk-tree-path-get-indices -;; (gtk-cffi::gtk-tree-model-get-path -;; model iter)) :int 0))) + :void ((column pobject) (cell pobject) + (model pobject) (iter-ptr :pointer) + (col-num pdata)) + (declare (ignore column)) + ;;(declare (optimize speed)) + ;;(format t + ;; "~A ~A ~A ~A ~A~%" column cell model iter col-num) + (let* ((iter (make-instance 'tree-iter :pointer iter-ptr)) + ;; (row-num (cffi:mem-aref + ;; (gtk-cffi::gtk-tree-path-get-indices + ;; (gtk-cffi::gtk-tree-model-get-path + ;; model iter)) :int 0))) - ;(row-num (parse-integer (gtk-cffi::iter-string model iter)))) - (row-num (get-index (iter->path model iter)))) -; (format t "~a ~a ~a~%" row-num col-num cell-ptr) + ;;(row-num (parse-integer (gtk-cffi::iter-string model iter)))) + (row-num (aref (iter->path model iter) 0))) + ;; (format t "~a ~a ~a~%" row-num col-num cell-ptr) - ;(format t "~a ~a ~a ~a ~a~%" column cell model iter col-num) -; (let ((vals (get-values model iter -; 3 :double -; 2 :long))) - ; (format t "~a ~a ~a~%" cell col-num vals) - (if (= col-num 3) - (setf (property cell :text) - (format nil "$~,2f" - (car (model-values model - :iter iter - :col 3))))) -; (if (and (= col-num 2) (> (cadr vals) 10)) -; (p-set cell :visible nil) -; (p-set cell :visible t))) - (setf (property cell :cell-background) - (if (= (mod row-num 2) 1) "#dddddd" "#ffffff")) - (setf (property cell :alignment) :left))) + ;;(format t "~a ~a ~a ~a ~a~%" column cell model iter col-num) + ;; (let ((vals (get-values model iter + ;; 3 :double + ;; 2 :long))) + ;; (format t "~a ~a ~a~%" cell col-num vals) + (if (= col-num 3) + (setf (property cell :text) + (format nil "$~,2f" + (car (model-values model + :tree-iter iter + :column 3))))) + ;; (if (and (= col-num 2) (> (cadr vals) 10)) + ;; (p-set cell :visible nil) + ;; (p-set cell :visible t))) + (setf (property cell :cell-background) + (if (= (mod row-num 2) 1) "#dddddd" "#ffffff")) + (setf (property cell :alignment) :left))) ;; (defun reformat-rows (model) @@ -208,13 +211,14 @@ ;; (when p (set-color m p iter data)))))))) (defun reformat-rows (model) - (gtk-cffi::foreach - model - (lambda (model path iter data) - (let ((row-num (get-index path))) - (setf (model-values model :iter iter :col 6) - (list (if (= (mod row-num 2) 1) - "#dddddd" "#ffffff"))))))) + (foreach + model + (lambda (model path iter data) + (declare (ignore data)) + (let ((row-num (aref path 0))) + (setf (model-values model :tree-iter iter :column 6) + (list (if (= (mod row-num 2) 1) + "#dddddd" "#ffffff"))))))) (cffi:defcallback reorder :void ((model-ptr pobject)) @@ -224,11 +228,12 @@ :boolean ((widget :pointer) (event :pointer) (str pdata)) - (let* ((model (cond - ((string= str "Show All") *model*) - ((string= str "Qty > 10") *modelfilter1*) - ((string= str "Price < $10") - *modelfilter2*)))) + (declare (ignore widget event)) + (let ((model (cond + ((string= str "Show All") *model*) + ((string= str "Qty > 10") *modelfilter1*) + ((string= str "Price < $10") + *modelfilter2*)))) (format t "link clicked: ~a~%" str) (when model (setf (model *view*) model) @@ -238,14 +243,15 @@ (cffi:defcallback on-selection - :void ((selection-ptr pobject) + :void ((selection pobject) (data-ptr :pointer)) - (with-selection selected selection-ptr - (when selected + (declare (ignore data-ptr)) + (multiple-value-bind (tree-iter model) (selected selection) + (when tree-iter (format t "You have selected ~a~%" - (model-values (first selected) - :iter (second selected) + (model-values model + :tree-iter tree-iter :columns '(1 2 7)))))) (main) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex5.lisp 2011/08/26 17:16:13 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex5.lisp 2012/10/07 12:02:11 1.4 @@ -12,7 +12,7 @@ (size-request window) '(400 150)) - (setf (bg-pixmap window) "/usr/share/pixmaps/gnome-color-browser.png") + (setf (bg-pixmap window) "/usr/share/pixmaps/gnome-about-logo.png") (show window)) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex7.lisp 2012/07/29 15:13:59 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex7.lisp 2012/10/07 12:02:11 1.8 @@ -48,7 +48,7 @@ (column (make-instance 'tree-view-column :title (nth col field-header);"" :cell cell-renderer - :text col))) + :attributes `(:text ,col)))) (let ((label (make-instance 'label :text (nth col field-header)))) (setf (font label) "Arial") @@ -69,7 +69,7 @@ (declare (ignore cell)) (format t "path: ~a new-text:~a~%" path new-text) (path->iter model path) - (setf (model-values model :col %col) + (setf (model-values model :column %col) (list new-text))))) (append-column view column)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex9.lisp 2012/05/07 09:02:03 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex9.lisp 2012/10/07 12:02:11 1.5 @@ -1,5 +1,5 @@ (asdf:oos 'asdf:load-op :gtk-cffi-ext) -;(declaim (optimize speed)) +(declaim (optimize speed)) (defpackage #:test9 (:use #:common-lisp #:iter #:gtk-cffi #:gtk-cffi-ext #:g-object-cffi)) (in-package #:test9) @@ -22,7 +22,7 @@ (append-values *model0* '(3)) (let ((arr (make-array 0 :adjustable t :fill-pointer 0))) - (iter (for i from 1 to 100000) + (iter (for i from 1 to 100000) ;; benchmark (vector-push-extend (list (format nil "str ~a" i) i) arr)) (setf (larray (implementation *model*)) arr)) @@ -34,7 +34,7 @@ ('scrolled-window ('tree-view :model *model* :columns '("Test str" "Test int"))))); "Test int")))) -;(show *window*) -(show #(1 2 3 4 5)) +(show *window*) +;(show #(1 2 3 4 5)) (gtk-main) From rklochkov at common-lisp.net Sun Oct 7 12:02:11 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 07 Oct 2012 05:02:11 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/ext Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/ext In directory tiger.common-lisp.net:/tmp/cvs-serv28209/ext Modified Files: lisp-model.lisp package.lisp Log Message: Fixed examples. Changed cell properties for tree-column to be set as :attributes Fixed double init in g-value. --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/lisp-model.lisp 2012/08/12 17:42:29 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/lisp-model.lisp 2012/10/07 12:02:11 1.7 @@ -258,7 +258,9 @@ (defcallback ,(symbolicate '#:cb-init- interface) :void ((class ,interface)) ,@(loop :for (callback args) :on callbacks :by #'cddr - :collecting `(setf (foreign-slot-value class ',interface ',callback) + :collecting `(setf (foreign-slot-value class + '(:struct ,interface) + ',callback) (callback ,(symbolicate '#:cb- callback))))))) (init-interface @@ -267,8 +269,8 @@ get-n-columns (:int) get-column-type (:int (index :int)) get-iter (:boolean (iter (object tree-iter)) - (path (tree-path :free-from-foreign nil))) - get-path ((tree-path :free-to-foreign nil) (iter (object tree-iter))) + (path cb-tree-path)) + get-path (cb-tree-path (iter (object tree-iter))) get-value (:void (iter (object tree-iter)) (n :int) (value :pointer)) iter-next (:boolean (iter (object tree-iter))) --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/package.lisp 2012/05/08 09:38:07 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/package.lisp 2012/10/07 12:02:11 1.5 @@ -4,14 +4,14 @@ (:use #:common-lisp #:cffi #:alexandria #:iterate #:cffi-objects #:g-object-cffi #:g-lib-cffi #:gdk-cffi #:gtk-cffi-utils #:gtk-cffi) - (:shadowing-import-from #:gtk-cffi #:image #:window) + (:shadowing-import-from #:gtk-cffi #:image #:window #:switch) (:import-from #:gtk-cffi #:tree-iter #:u1 #:stamp #:tree-model-iface #:get-n-columns #:get-column-type #:get-iter #:get-path #:get-value #:iter-next #:iter-previous #:iter-children #:iter-has-child #:iter-n-children #:get-flags #:iter-nth-child #:iter-parent #:ref-node #:unref-node - #:tree-path) + #:tree-path #:cb-tree-path) (:export #:lisp-model #:implementation From rklochkov at common-lisp.net Sun Oct 7 12:02:11 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 07 Oct 2012 05:02:11 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/g-lib Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-lib In directory tiger.common-lisp.net:/tmp/cvs-serv28209/g-lib Modified Files: error.lisp Log Message: Fixed examples. Changed cell properties for tree-column to be set as :attributes Fixed double init in g-value. --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/error.lisp 2012/08/19 16:22:29 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/error.lisp 2012/10/07 12:02:11 1.7 @@ -15,12 +15,10 @@ &key &allow-other-keys) (foreign-alloc :pointer :initial-element (null-pointer))) -(defcfun "g_clear_error" :void (gerror object)) +(defcfun g-clear-error :void (gerror object)) (defmethod free :before ((g-error g-error)) - (let ((p (pointer g-error))) - (g-clear-error p) - (foreign-free p))) + (g-clear-error g-error)) (defcstruct g-error "GError struct" From rklochkov at common-lisp.net Sun Oct 7 12:02:11 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 07 Oct 2012 05:02:11 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/g-object Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object In directory tiger.common-lisp.net:/tmp/cvs-serv28209/g-object Modified Files: defslots.lisp g-value.lisp package.lisp Log Message: Fixed examples. Changed cell properties for tree-column to be set as :attributes Fixed double init in g-value. --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/08/19 16:22:30 1.14 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/10/07 12:02:11 1.15 @@ -160,14 +160,15 @@ (,gtk-name ,class (callback ,cb-name) data)) (,gtk-name ,class func data)))))) -(defmacro set-callback (object setter cb-standard func data destroy-notify) +(defmacro set-callback (object setter cb-standard func data destroy-notify + &rest add-params) `(let ((func ,func) (data ,data)) (if (functionp func) - (,setter ,object + (,setter ,object , at add-params (callback ,cb-standard) func (callback free-storage)) - (,setter ,object func data + (,setter ,object , at add-params func data (or ,destroy-notify (if (or (null data) (pointerp data) (typep data 'g-object)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2012/08/24 19:27:54 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2012/10/07 12:02:11 1.8 @@ -5,6 +5,7 @@ ;;; ;;; Copyright (C) 2007, Roman Klochkov ;;; +(declaim (optimize debug)) (in-package :g-object-cffi) @@ -60,8 +61,9 @@ (defcfun g-value-unset :void (g-value pobject)) (defmethod unset ((g-value g-value)) - (when (/= (g-type g-value) 0) - (g-value-unset g-value))) + ;(when (/= (g-type g-value) 0) + (format t "Unset value ~a~%" g-value) + (g-value-unset g-value)) (defun init-g-value (ptr type value value-p) (macrolet ((gtypecase (x &rest body) @@ -87,6 +89,7 @@ (g-value-set ptr value %type)))))) (defmethod init ((g-value g-value) &key (value nil value-p) g-type) + (format t "init ~a~%" g-value) (init-g-value (pointer g-value) g-type value value-p)) @@ -172,8 +175,9 @@ (#.(keyword->g-type :interface) (g-value-get-object value)) (t - (funcall (select-accessor - fundamental-type :g-value-get-) value))))) + (when (/= fundamental-type 0) + (funcall (select-accessor + fundamental-type :g-value-get-) value)))))) ;(format t "g-val value:~a~%" res) res))))) @@ -185,18 +189,23 @@ ;(format t "g-val2: ~a~%" l) l)) -(defmethod free ((g-value g-value)) - (g-value-unset g-value) - (foreign-free (pointer g-value))) +(defmethod free :before ((g-value g-value)) + (g-value-unset g-value)) (defvar *g-value* (make-instance 'g-value)) (defmacro with-g-value (val &body body) + "This macro allows recursive *g-value* binding" `(progn - (init *g-value* , at val) - (unwind-protect - (progn - , at body - (value *g-value*)) - (unset *g-value*)))) + (let* ((changed? (/= 0 (g-type *g-value*))) + (*g-value* (if changed? (make-instance 'g-value) *g-value*))) + (init *g-value* , at val) + (unwind-protect + (progn + , at body + (value *g-value*)) + (if changed? + (free *g-value*) + (unset *g-value*)))))) + --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2012/07/29 15:13:59 1.11 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2012/10/07 12:02:11 1.12 @@ -26,6 +26,9 @@ #:storage ;; slot #:data + + ;; callback + #:free-storage ;; macro #:with-object From rklochkov at common-lisp.net Sun Oct 7 12:02:11 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 07 Oct 2012 05:02:11 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gdk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gdk In directory tiger.common-lisp.net:/tmp/cvs-serv28209/gdk Modified Files: event.lisp Log Message: Fixed examples. Changed cell properties for tree-column to be set as :attributes Fixed double init in g-value. --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/event.lisp 2012/08/24 19:27:54 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/event.lisp 2012/10/07 12:02:11 1.5 @@ -2,7 +2,7 @@ (defctype device :pointer) -(defctype window :pointer) +(defctype window pobject) (defctype axes :pointer) ;; array of double @@ -125,7 +125,7 @@ (type event-type) (window window) (send-event :int8) - (area rectangle) + (area (:struct rectangle)) (region region) (count :int)) @@ -237,7 +237,7 @@ (send-event :int8) (message-tyoe gdk-atom) (data-format :ushort) - (data client-data-union)) + (data (:union client-data-union))) (defcstruct event-no-expose "" @@ -292,26 +292,26 @@ (defcunion event (type event-type) - (any event-any) - (expose event-expose) - (no-expose event-no-expose) - (visibility event-visibility) - (motion event-motion) - (button event-button) - (scroll event-scroll) - (key event-key) - (crossing event-crossing) - (focus-change event-focus) - (configure event-configure) - (property event-property) - (selection event-selection) - (owner-change event-owner-change) - (proximity event-proximity) - (client event-client) - (dnd event-dnd) - (window-state event-window-state) - (setting event-setting) - (grab-broken event-grab-broken)) + (any (:struct event-any)) + (expose (:struct event-expose)) + (no-expose (:struct event-no-expose)) + (visibility (:struct event-visibility)) + (motion (:struct event-motion)) + (button (:struct event-button)) + (scroll (:struct event-scroll)) + (key (:struct event-key)) + (crossing (:struct event-crossing)) + (focus-change (:struct event-focus)) + (configure (:struct event-configure)) + (property (:struct event-property)) + (selection (:struct event-selection)) + (owner-change (:struct event-owner-change)) + (proximity (:struct event-proximity)) + (client (:struct event-client)) + (dnd (:struct event-dnd)) + (window-state (:struct event-window-state)) + (setting (:struct event-setting)) + (grab-broken (:struct event-grab-broken))) (defclass event (object) ((event-type :accessor event-type))) @@ -320,7 +320,7 @@ :after ((event event) &key pointer &allow-other-keys) (setf (event-type event) - (case (foreign-slot-value pointer 'event 'type) + (case (foreign-slot-value pointer '(:union event) 'type) ((:nothing :delete :destroy :map :unmap) 'event-any) (:expose 'event-expose) (:motion-notify 'event-motion) From rklochkov at common-lisp.net Sun Oct 7 12:02:11 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 07 Oct 2012 05:02:11 -0700 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gtk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk In directory tiger.common-lisp.net:/tmp/cvs-serv28209/gtk Modified Files: assistant.lisp cell-layout.lisp combo-box.lisp container.lisp entry.lisp enums.lisp generics.lisp gtk-cffi.asd label.lisp list-store.lisp package.lisp tree-model-filter.lisp tree-model.lisp tree-selection.lisp tree-view-column.lisp tree-view.lisp widget.lisp Log Message: Fixed examples. Changed cell properties for tree-column to be set as :attributes Fixed double init in g-value. --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/assistant.lisp 2012/05/07 09:02:04 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/assistant.lisp 2012/10/07 12:02:11 1.4 @@ -44,7 +44,7 @@ (funcall data cur-page)) (defcfun gtk-assistant-set-forward-page-func :void - (assistant pobject) (func pfunction) (data pdata) (notify :pointer)) + (assistant pobject) (func pfunction) (data pdata) (notify pfunction)) (defmethod (setf forward-page-func) (func (assistant assistant) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-layout.lisp 2012/07/29 15:13:59 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-layout.lisp 2012/10/07 12:02:11 1.6 @@ -3,18 +3,10 @@ (defclass cell-layout (g-object) ()) - -(defcfun "gtk_cell_layout_add_attribute" :void - (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 attr column)) - -(defcfun "gtk_cell_layout_pack_start" :void +(defcfun gtk-cell-layout-pack-start :void (cell-layout pobject) (renderer pobject) (expand :boolean)) -(defcfun "gtk_cell_layout_pack_end" :void +(defcfun gtk-cell-layout-pack-end :void (cell-layout pobject) (renderer pobject) (expand :boolean)) (defmethod pack ((cell-layout cell-layout) @@ -22,57 +14,33 @@ &key end expand) (funcall (if end #'gtk-cell-layout-pack-end - #'gtk-cell-layout-pack-start) + #'gtk-cell-layout-pack-start) cell-layout cell-renderer expand) (iter (for (attr column) in (attributes cell-renderer)) - (add-attribute cell-layout cell-renderer - attr column))) - + (add-attribute cell-layout cell-renderer attr column))) -(defcfun "gtk_cell_layout_get_cells" g-list-object (cell-layout pobject)) - -(defmethod cell-renderers ((cell-layout cell-layout)) - (gtk-cell-layout-get-cells cell-layout)) +(deffuns cell-layout + (add-attribute :void (cell pobject) (attr cffi-keyword) (column :int)) + (:get cells g-list-object) + (:get area pobject) + (reorder :void (cell pobject) (poisition :int)) + (clear-attributes :void (cell-renderer pobject)) + (clear :void)) (defcallback cb-cell-data-func :void ((cell-layout pobject) (cell-renderer pobject) - (model pobject) (iter :pointer) (data pdata)) - (funcall data cell-layout cell-renderer model - (make-instance 'tree-iter :pointer iter))) + (model pobject) (tree-iter (struct tree-iter)) (data pdata)) + (funcall data cell-layout cell-renderer model tree-iter)) -(defcfun "gtk_cell_layout_set_cell_data_func" :void +(defcfun gtk-cell-layout-set-cell-data-func :void (cell-layout pobject) (renderer pobject) (func pfunction) (data pdata) (notify :pointer)) -(defmethod (setf cell-data-func) (c-handler +(defmethod (setf cell-data-func) (func (cell-layout cell-layout) (cell-renderer cell-renderer) &key data destroy-notify) - - (if (functionp c-handler) - (gtk-cell-layout-set-cell-data-func - cell-layout cell-renderer - (callback cb-cell-data-func) - (pointer (make-instance 'storage :data c-handler)) - (callback free-storage)) - (gtk-cell-layout-set-cell-data-func - cell-layout cell-renderer - c-handler - data - ;; destroy-notify - (or destroy-notify - (if (or (null data) (pointerp data) (typep data 'g-object)) - (null-pointer) (callback free-storage)))))) - -(defcfun "gtk_cell_layout_clear_attributes" :void - (cell-layout pobject) (cell-renderer pobject)) - -(defmethod clear-attributes ((cell-layout cell-layout) - (cell-renderer cell-renderer)) - (gtk-cell-layout-clear-attributes cell-layout cell-renderer)) - -(defcfun "gtk_cell_layout_clear" :void (cell-layout pobject)) + (set-callback cell-layout gtk-cell-layout-set-cell-data-func + cb-cell-data-func func data destroy-notify cell-renderer)) -(defmethod clear ((cell-layout cell-layout)) - (gtk-cell-layout-clear cell-layout)) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/combo-box.lisp 2012/08/12 17:42:30 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/combo-box.lisp 2012/10/07 12:02:11 1.6 @@ -61,7 +61,7 @@ (funcall data model iter)) (defcfun gtk-combo-box-set-row-separator-func :void - (combo-box pobject) (func pfunction) (data pdata) (notify :pointer)) + (combo-box pobject) (func pfunction) (data pdata) (notify pfunction)) (defgeneric (setf row-separator-func) (func combo-box &key data destroy-notify) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2012/08/12 17:42:30 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2012/10/07 12:02:11 1.6 @@ -19,9 +19,10 @@ (defmethod add ((container container) (widget widget)) (gtk-container-add container widget)) -(defmethod pack ((container container) (widget widget) &rest rest) - (declare (ignore rest)) - (add container widget)) +(defgeneric pack (container widget &rest rest) + (:method ((container container) (widget widget) &rest rest) + (declare (ignore rest)) + (add container widget))) (defmacro pack* (box &rest widgets) `(progn @@ -76,43 +77,44 @@ 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) - (with-g-value - (:g-type (child-property-type parent key)) - (gtk-container-child-get-property - parent widget key *g-value*))) - keys))) - -(defmethod child-property ((widget widget) (parent null) &rest keys) - (apply #'child-property `(,widget ,(parent widget) , at keys))) - -(defmethod (setf child-property) (values (widget widget) (parent container) - &rest keys) - " +(defgeneric child-property (widget parent &key keys) + (:method ((widget widget) (parent container) &rest keys) + (funcall (lambda (x) (if (cdr x) x (car x))) + (mapcar (lambda (key) + (with-g-value + (:g-type (child-property-type parent key)) + (gtk-container-child-get-property + parent widget key *g-value*))) + keys))) + + (:method ((widget widget) (parent null) &rest keys) + (apply #'child-property `(,widget ,(parent widget) , at keys)))) + +(defgeneric (setf child-property) (values widget parent &key keys) + (:documentation " Usage: (setf (child-property object parent :property) value) (setf (child-property object parent :prop1 :prop2) - (list value1 value2))" - (mapc (lambda (key value) - (declare (type (or symbol string) key)) - (with-g-value (:value value - :g-type (child-property-type parent key)) - (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) - &rest keys) - (apply #'(setf child-property) `(,values ,widget ,(parent widget) , at keys))) + (list value1 value2))") + (:method (values (widget widget) (parent container) &rest keys) + (mapc (lambda (key value) + (declare (type (or symbol string) key)) + (with-g-value (:value value + :g-type (child-property-type parent key)) + (gtk-container-child-set-property parent widget + key *g-value*))) + keys (if (listp values) values (list values)))) + + (:method (values (widget widget) (parent null) &rest keys) + (apply #'(setf child-property) `(,values ,widget ,(parent widget) , at keys)))) (defcfun "gtk_container_class_find_child_property" :pointer (obj-class pobject) (key :string)) -(defmethod find-child-property ((container container) key) - (let ((ptr (gtk-container-class-find-child-property container key))) - (unless (null-pointer-p ptr) - (make-instance 'g-object-cffi:g-param-spec :pointer ptr)))) +(defgeneric find-child-property (container key) + (:method ((container container) key) + (let ((ptr (gtk-container-class-find-child-property container key))) + (unless (null-pointer-p ptr) + (make-instance 'g-object-cffi:g-param-spec :pointer ptr))))) (defcfun gtk-container-remove :void (container pobject) (widget pobject)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/entry.lisp 2012/08/21 19:48:02 1.8 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/entry.lisp 2012/10/07 12:02:11 1.9 @@ -108,7 +108,7 @@ (delete-action :void (index :int))) (defcfun gtk-entry-completion-set-match-func :void - (entry-completion pobject) (func pfunction) (data pdata) (notify :pointer)) + (entry-completion pobject) (func pfunction) (data pdata) (notify pfunction)) (defcallback cb-match-func :boolean ((entry-completion pobject) (key :string) (tree-iter (object tree-iter)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2012/07/31 17:57:12 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2012/10/07 12:02:11 1.7 @@ -33,4 +33,6 @@ (defcenum relief-style :normal :half :none) -(defcenum position-type :left :right :top :bottom) \ No newline at end of file +(defcenum position-type :left :right :top :bottom) + +(defcenum sort-type :ascending :descending) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/generics.lisp 2012/03/08 09:58:12 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/generics.lisp 2012/10/07 12:02:11 1.5 @@ -3,5 +3,6 @@ (defgeneric selection-bounds (widget &key)) ;; text-buffer, label (defgeneric text (widget &key)) ;; entry, label, text-buffer (defgeneric (setf text) (value widget &key)) +(defgeneric layout-offsets (object)) ;; entry, label, scale --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/08/24 19:27:54 1.28 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/10/07 12:02:11 1.29 @@ -273,7 +273,7 @@ (defsystem gtk-cffi-tree-selection :description "Interface to GTK/Glib via CFFI" :author "Roman Klochkov " - :version "0.1" + :version "0.99" :license "LLGPL" :depends-on (gtk-cffi-tree-model) :components @@ -282,7 +282,7 @@ (defsystem gtk-cffi-tree-view-column :description "Interface to GTK/Glib via CFFI" :author "Roman Klochkov " - :version "0.1" + :version "0.99" :license "LLGPL" :depends-on (gtk-cffi-cell-layout gtk-cffi-cell-renderer gtk-cffi-widget) :components --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/label.lisp 2012/03/08 09:58:12 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/label.lisp 2012/10/07 12:02:11 1.5 @@ -75,10 +75,9 @@ (defcfun gtk-label-get-layout-offsets :void (label pobject) (x :pointer) (y :pointer)) -(defgeneric layout-offsets (label) - (:method ((label label)) - (with-foreign-outs-list ((x :int) (y :int)) :ignore - (gtk-label-get-layout-offsets label x y)))) +(defmethod layout-offsets ((label label)) + (with-foreign-outs-list ((x :int) (y :int)) :ignore + (gtk-label-get-layout-offsets label x y))) (defcfun gtk-label-get-selection-bounds :void (label pobject) (start :pointer) (end :pointer)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/list-store.lisp 2012/07/29 15:13:59 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/list-store.lisp 2012/10/07 12:02:11 1.5 @@ -5,7 +5,7 @@ ;;; ;;; Copyright (C) 2007, Roman Klochkov ;;; - +(declaim (optimize debug)) (in-package :gtk-cffi) (defclass list-store (g-object tree-model) @@ -41,15 +41,16 @@ (defmethod append-iter ((list-store list-store) &optional (tree-iter (tree-iter list-store))) - (gtk-list-store-append list-store tree-iter) - (show-iter "appended" 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 (struct tree-iter)) (column :int) (g-value pobject)) (defmethod (setf model-values) (values (list-store list-store) - &key (tree-iter (tree-iter list-store)) col (columns (when col (list col)))) + &key (tree-iter (tree-iter list-store)) column + (columns (when column (list column)))) "Example: (setf (model-values list-store :col 1) \"val1\")" (declare (type list columns values)) (let ((%cols (append columns (loop :for i @@ -59,9 +60,12 @@ (mapcar (lambda (col val) (with-g-value (:value val :g-type (column-type list-store col)) - (show-iter "set" tree-iter) + ;(show-iter "set" tree-iter) +; (format t "set val: ~a type: ~a~%" val (column-type list-store col)) + (assert (/= (g-type *g-value*) 0)) (gtk-list-store-set-value list-store - tree-iter col *g-value*))) + tree-iter col *g-value*) + (unless (/= (g-type *g-value*) 0) (cerror "Bad g-val" *g-value*)))) %cols values))) (defcfun "gtk_list_store_clear" :void (store pobject)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/09/21 19:00:33 1.29 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/10/07 12:02:11 1.30 @@ -20,6 +20,8 @@ #:gtk-model #:defmodel ; recommended way + #:foreach + ;; reexport #:object-by-id #:gsignal @@ -496,6 +498,8 @@ #:cell-renderer-pixbuf #:cell-layout + #:reorder + #:area #:cell-editable @@ -596,8 +600,18 @@ ;; tree-view slots #:model #:search-column + #:level-indentation + #:selection + #:hover-expand + #:rubber-banding + #:headers-clickable + #:show-expanders + #:rules-hint + #:headers-visible + #:hover-selection ;; tree-view methods #:append-column + #:insert-column #:get-selection #:path-at-pos #:with-path-at-pos @@ -608,15 +622,29 @@ #:remove-column #:tree-view-column - ;; tree-view-column slots + ;; slots #:sort-column-id #:alignment #:reorderable - ;; tree-view-column methods + #:fixed-width + #:max-width + #:min-width + #:expand + #:sort-indicator + #:sizing + #:sort-order + #:clickable + ;; methods + #:add-attribute #:cell-data-func #:cell-get-position - #:cell-renderers + #:cells #:get-cell-at + #:clear-attributes + #:x-offset + #:cell-is-visible + #:focus-cell + #:cell-set-cell-data #:scrollable #:hscroll-policy @@ -638,11 +666,21 @@ #:tree-selection ;; slots #:user-data - ;; methods #:mode #:select-function - #:with-selection - #:get-selected + ;; methods + #:select-path + #:unselect-path + #:select-iter + #:unselect-iter + #:select-all + #:path-is-selected + #:iter-is-selected + #:unselect-range + #:unselect-all + #:count-selected-rows + #:selected + #:selected-rows #:text-mark ;; slots --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model-filter.lisp 2011/08/26 17:16:14 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model-filter.lisp 2012/10/07 12:02:11 1.3 @@ -35,8 +35,9 @@ (progn , at body) (when ,path (free ,path))))) -(defcfun "gtk_tree_model_filter_convert_iter_to_child_iter" :void - (model pobject) (child-iter pobject) (iter pobject)) +(defcfun gtk-tree-model-filter-convert-iter-to-child-iter :void + (model pobject) (child-iter (struct tree-iter :out t)) + (iter (struct tree-iter))) (defmethod iter-to-child ((tree-model-filter tree-model-filter) (tree-iter tree-iter)) @@ -45,8 +46,8 @@ tree-model-filter child-iter tree-iter) child-iter)) -(defmacro with-child-iter (child-iter parent iter &body body) - `(let ((,child-iter (iter-to-child ,parent ,iter))) +(defmacro with-child-iter (child-iter parent tree-iter &body body) + `(let ((,child-iter (iter-to-child ,parent ,tree-iter))) (unwind-protect (progn , at body) (when ,child-iter (free ,child-iter))))) @@ -55,11 +56,11 @@ (defmethod (setf model-values) (values (tree-model-filter tree-model-filter) - &key (iter (iter tree-model-filter)) col - (columns (when col (list col)))) - (with-child-iter child-iter tree-model-filter iter + &key (tree-iter (tree-iter tree-model-filter)) column + (columns (when column (list column)))) + (with-child-iter child-iter tree-model-filter tree-iter (setf (model-values (model tree-model-filter) - :iter child-iter :columns columns) values))) + :tree-iter child-iter :columns columns) values))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/09/21 19:00:33 1.15 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/10/07 12:02:11 1.16 @@ -48,6 +48,14 @@ (defmethod free-ptr ((tree-path (eql 'tree-path)) ptr) (gtk-tree-path-free ptr)) +(define-foreign-type cb-tree-path (tree-path) + ((free-from-foreign :initform nil)) + (:documentation "Tree path for callbacks") + (:simple-parser cb-tree-path) + (:actual-type :pointer)) + +(defmethod free-ptr ((tree-path (eql 'cb-tree-path)) ptr) + (gtk-tree-path-free ptr)) (defclass tree-row-reference (object) ()) @@ -118,21 +126,23 @@ (make-foreach tree-model (model pobject) - (path tree-path) + (path cb-tree-path) (tree-iter (object tree-iter)) (data pdata)) (defcfun gtk-tree-model-get-path tree-path (model pobject) (tree-iter (struct tree-iter))) -(defmethod iter->path ((tree-model tree-model) (tree-iter tree-iter)) - (gtk-tree-model-get-path tree-model tree-iter)) +(defgeneric iter->path (tree-model tree-iter) + (:method ((tree-model tree-model) (tree-iter tree-iter)) + (gtk-tree-model-get-path tree-model tree-iter))) (defcfun gtk-tree-model-get-string-from-iter :string (model pobject) (tree-iter (struct tree-iter))) -(defmethod iter->string ((tree-model tree-model) (tree-iter tree-iter)) - (gtk-tree-model-get-string-from-iter tree-model tree-iter)) +(defgeneric iter->string (tree-model tree-iter) + (:method ((tree-model tree-model) (tree-iter tree-iter)) + (gtk-tree-model-get-string-from-iter tree-model tree-iter))) (defcfun gtk-tree-model-get-value :void (model pobject) (iter pobject) (column :int) (g-value pobject)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-selection.lisp 2012/07/21 19:26:39 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-selection.lisp 2012/10/07 12:02:11 1.4 @@ -10,16 +10,28 @@ (deffuns tree-selection (:get select-function :pointer) - (:get user-data :pointer) - (:get tree-view pobject)) + (:get user-data pdata) + (:get tree-view pobject) + (count-selected-rows :int) + (select-path :void (path tree-path)) + (unselect-path :void (path tree-path)) + (path-is-selected :boolean (path tree-path)) + (select-iter :void (tree-iter (struct tree-iter))) + (unselect-iter :void (tree-iter (struct tree-iter))) + (iter-is-selected :boolean (tree-iter (struct tree-iter))) + (select-all :void) + (unselect-all :void) + (select-range :void (start-path tree-path) (end-path tree-path)) + (unselect-range :void (start-path tree-path) (end-path tree-path))) + (defcallback cb-tree-selection-func :boolean - ((selection pobject) (model pobject) (path (object tree-path)) + ((selection pobject) (model pobject) (path cb-tree-path) (path-currently-selected :boolean) (data pdata)) (funcall data selection model path path-currently-selected)) (defcfun gtk-tree-selection-set-select-function :void - (selection :pointer) (func :pointer) (data :pointer) (destroy :pointer)) + (selection pobject) (func pfunction) (data pdata) (destroy pfunction)) (defgeneric (setf select-function) (tree-selection func &key data destroy-notify) @@ -28,65 +40,46 @@ cb-tree-selection-func func data destroy-notify))) (defcfun gtk-tree-selection-get-selected :boolean - (selection pobject) (model pobject) (iter pobject)) + (selection pobject) (model :pointer) (tree-iter (struct tree-iter :out t))) + +(defgeneric selected (tree-selection) + (:method ((tree-selection tree-selection)) + (let ((tree-iter (make-instance 'tree-iter))) + (with-foreign-object (p :pointer) + (when (gtk-tree-selection-get-selected tree-selection p tree-iter) + (values tree-iter (convert-from-foreign (mem-ref p :pointer) + 'pobject))))))) + +(defcfun gtk-tree-selection-get-selected-rows (g-list :elt tree-path) + (selection pobject) (model :pointer)) + +(defgeneric selected-rows (tree-selection) + (:method ((tree-selection tree-selection)) + (with-foreign-object (p :pointer) + (values (gtk-tree-selection-get-selected-rows tree-selection p) + (mem-ref p 'pobject))))) + (defcfun gtk-tree-selection-selected-foreach :void - (selection pobject) (func :pointer) (data :pointer)) + (selection pobject) (func pfunction) (data pdata)) (defvar *tree-selection-foreach* nil) (defcallback cb-tree-selection-foreach :boolean - ((model :pointer) (path :pointer) (iter :pointer) (data :pointer)) + ((model pobject) (path tree-path :free-from-foreign nil) + (tree-iter (struct tree-iter)) (data pdata)) (when *tree-selection-foreach* - (funcall *tree-selection-foreach* - (find-object model) - (make-instance 'tree-path :pointer path) - (make-instance 'tree-iter :pointer iter) - (find-object data)))) + (funcall *tree-selection-foreach* model path tree-iter data))) -(defmethod tree-selection-foreach ((tree-selection tree-selection) +(defmethod foreach ((tree-selection tree-selection) func &optional (data (null-pointer))) - (let ((*tree-selection-foreach* func)) - (gtk-tree-selection-selected-foreach (pointer tree-selection) - (callback cb-tree-selection-foreach) data))) - -(defvar *selected* nil) - -(defmethod get-selected ((tree-selection tree-selection)) - "Returns list (model iter &optional iter2 iter3 ...)" - (if (eq (mode tree-selection) :multiple) - (progn - (let ((*selected* nil)) - (tree-selection-foreach tree-selection - (lambda (model path iter data) - (declare (ignore data path)) - (unless *selected* - (push model *selected*)) - (push (copy iter) *selected*))) - (when *selected* - (debug-out "selected: ~a~%" *selected*) - (nreverse *selected*)))) - - (let ((iter (make-instance 'tree-iter))) - (with-foreign-object (model-ptr :pointer) - (when (gtk-tree-selection-get-selected - tree-selection model-ptr iter) - (list (find-object (mem-ref model-ptr :pointer)) - iter)))))) - -(defmacro with-selection (selection tree-selection &body body) - `(let ((,selection (get-selected ,tree-selection))) - (unwind-protect - (progn , at body) - (mapc #'free (cdr ,selection))))) - -(defmethod initialize-instance - :after ((tree-selection tree-selection) - &key (mode :single) &allow-other-keys) -; (when pointer -; (setf (pointer tree-selection) pointer)) ;; to save in *objects* - (unless (eq mode :single) - (setf (mode tree-selection) mode))) + (when func + (let ((*tree-selection-foreach* func)) + (gtk-tree-selection-selected-foreach + tree-selection (if (functionp func) + (callback cb-tree-selection-foreach) func) + data)))) + --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view-column.lisp 2012/03/06 01:25:26 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view-column.lisp 2012/10/07 12:02:11 1.4 @@ -3,110 +3,114 @@ (defclass tree-view-column (cell-layout) ()) -(defcfun "gtk_tree_view_column_new" :pointer) +(defcfun gtk-tree-view-column-new :pointer) +(defcfun gtk-tree-view-column-new-with-area :pointer (area pobject)) (defmethod gconstructor ((tree-view-column tree-view-column) - &key &allow-other-keys) - (gtk-tree-view-column-new)) + &key area + &allow-other-keys) + (initialize tree-view-column '(area)) + (if area + (gtk-tree-view-column-new-with-area area) + (gtk-tree-view-column-new))) -(defmethod initialize-instance - :after ((tree-view-column tree-view-column) - &rest initargs &key title cell &allow-other-keys) - "other attributes = (:text 2 :color 3)" - (setf-init tree-view-column title) - (when cell - (pack tree-view-column cell) - (labels ((process (x) - (when x - (let ((key (first x)) - (val (second x))) - (when (and (keywordp key) - (not (member key '(:title :cell)))) - (add-attribute tree-view-column cell key val))) - (process (cddr x))))) - (process initargs)))) - -(defcfun "gtk_tree_view_column_set_title" :void - (column pobject) (title :string)) - -(defcfun "gtk_tree_view_column_get_title" :string (column pobject)) +(defcenum tree-view-column-sizing :grow-only :autosize :fixed) -(defmethod (setf title) (value (tree-view-column tree-view-column)) - (gtk-tree-view-column-set-title tree-view-column value)) - -(defmethod title ((tree-view-column tree-view-column)) - (gtk-tree-view-column-get-title tree-view-column)) - -(defcfun "gtk_tree_view_column_set_sort_column_id" :void - (column :pointer) (id :int)) - -(defmethod (setf sort-column-id) (id (tree-view-column tree-view-column)) - (gtk-tree-view-column-set-sort-column-id (pointer tree-view-column) id)) - -(defcfun "gtk_tree_view_column_set_alignment" :void - (column :pointer) (xalign :float)) - -(defmethod (setf alignment) (xalign (tree-view-column tree-view-column)) - (gtk-tree-view-column-set-alignment (pointer tree-view-column) - (float xalign))) -(defcfun "gtk_tree_view_column_set_reorderable" :void - (column :pointer) (reorderable :boolean)) +(defslots tree-view-column + title :string + spacing :int + visible :boolean + resizable :boolean + sizing tree-view-column-sizing + fixed-width :int + min-width :int + max-width :int + expand :boolean + clickable :boolean + widget pobject + alignment :float + reorderable :boolean + sort-column-id :int + sort-indicator :boolean + sort-order sort-type) + +(defcfun gtk-tree-view-column-pack-start :void + (tree-view-column pobject) (renderer pobject) (expand :boolean)) + +(defcfun gtk-tree-view-column-pack-end :void + (tree-view-column pobject) (renderer pobject) (expand :boolean)) + +(defmethod pack ((tree-view-column tree-view-column) + (cell-renderer cell-renderer) + &key end expand) + (funcall (if end + #'gtk-tree-view-column-pack-end + #'gtk-tree-view-column-pack-start) + tree-view-column cell-renderer expand) + (iter + (for (attr column) in (attributes cell-renderer)) + (add-attribute tree-view-column cell-renderer attr column))) + +(deffuns tree-view-column + (add-attribute :void (cell pobject) (attr cffi-keyword) (column :int)) + (clear-attributes :void (cell-renderer pobject)) + (clear :void) + (clicked :void) + (cell-is-visible :boolean) + (queue-resize :void &key) + (:get tree-view pobject) + (:get x-offset :int) + (focus-cell :void (cell-renderer pobject)) + (cell-set-cell-data :void (model pobject) (iter (struct tree-iter)) + (is-expander :boolean) (is-expanded :boolean))) -(defmethod (setf reorderable) (reorderable (tree-view-column tree-view-column)) - (gtk-tree-view-column-set-reorderable (pointer tree-view-column) - reorderable)) - -(defcfun "gtk_tree_view_column_get_reorderable" :boolean - (column :pointer)) - -(defmethod reorderable ((tree-view-column tree-view-column)) - (gtk-tree-view-column-get-reorderable (pointer tree-view-column))) - -(defcfun "gtk_tree_view_column_set_cell_data_func" :void - (column pobject) (renderer pobject) (func :pointer) +(defcfun gtk-tree-view-column-set-cell-data-func :void + (tree-view-column pobject) (renderer pobject) (func pfunction) (data pdata) (notify :pointer)) -(defmethod (setf cell-data-func) (c-handler (tree-view-column tree-view-column) - (cell-renderer cell-renderer) - &key - (data (null-pointer)) - (destroy-notify (null-pointer))) - (gtk-tree-view-column-set-cell-data-func tree-view-column cell-renderer - c-handler data destroy-notify)) - -(defcfun "gtk_tree_view_column_set_widget" :void - (column pobject) (widget pobject)) +(defmethod (setf cell-data-func) (func + (tree-view-column tree-view-column) + (cell-renderer cell-renderer) + &key data destroy-notify) + (set-callback tree-view-column gtk-tree-view-column-set-cell-data-func + cb-cell-data-func func data destroy-notify cell-renderer)) -(defmethod (setf widget) ((widget widget) - (tree-view-column tree-view-column)) - (gtk-tree-view-column-set-widget tree-view-column widget)) -(defcfun "gtk_tree_view_column_get_widget" pobject - (column pobject)) -(defmethod widget ((tree-view-column tree-view-column)) - (gtk-tree-view-column-get-widget tree-view-column)) +(defcfun gtk-tree-view-column-cell-get-size :void + (column pobject) (cell-renderer pobject) (area (struct rectangle)) + (x-offset :pointer) (y-offset :pointer) (width :pointer) (height :pointer)) + +(defmethod cell-get-size ((tree-view-column tree-view-column) + (cell-renderer cell-renderer) area) + (with-foreign-outs-list + ((x-offset :int) (y-offset :int) (width :int) (height :int)) :ignore + (gtk-tree-view-column-cell-get-size tree-view-column cell-renderer area + x-offset y-offset width height))) - - -(defcfun "gtk_tree_view_column_cell_get_position" :boolean +(defcfun gtk-tree-view-column-cell-get-position :boolean (column pobject) (cell-renderer pobject) (start-pos :pointer) (width :pointer)) (defmethod cell-get-position ((tree-view-column tree-view-column) (cell-renderer cell-renderer)) - (with-foreign-objects - ((start-pos :int) - (width :int)) - (gtk-tree-view-column-cell-get-position tree-view-column - cell-renderer start-pos width) - (list (mem-ref start-pos :int) (mem-ref width :int)))) + (with-foreign-outs-list + ((start-pos :int) (width :int)) :if-success + (gtk-tree-view-column-cell-get-position tree-view-column + cell-renderer start-pos width))) (defmethod get-cell-at ((tree-view-column tree-view-column) x) - (loop :for cell in (cell-renderers tree-view-column) + (loop :for cell in (cells tree-view-column) :when (destructuring-bind (start-pos width) (cell-get-position tree-view-column cell) (and (>= x start-pos) (>= (+ start-pos width) x))) :return cell)) + +(init-slots tree-view-column (cell attributes) + (when cell + (pack tree-view-column cell) + (iter + (for (key value) on attributes by #'cddr) + (add-attribute tree-view-column cell key value)))) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view.lisp 2012/07/29 15:13:59 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view.lisp 2012/10/07 12:02:11 1.4 @@ -6,9 +6,8 @@ (defcenum tree-view-grid-lines :none :horizontal :vertical :both) -(defcfun "gtk_tree_view_new" :pointer) - -(defcfun "gtk_tree_view_new_with_model" :pointer (model pobject)) +(defcfun gtk-tree-view-new :pointer) +(defcfun gtk-tree-view-new-with-model :pointer (model pobject)) (defmethod gconstructor ((tree-view tree-view) &key model &allow-other-keys) @@ -16,128 +15,80 @@ (gtk-tree-view-new-with-model model) (gtk-tree-view-new))) - -(defmethod initialize-instance - :after ((tree-view tree-view) - &key columns on-select &allow-other-keys) - (setf-init tree-view columns) - (when on-select - (setf (gsignal (get-selection tree-view) :changed) - (lambda (selection) - (let ((selected (get-selected selection))) - (when (cdr selected) - (apply on-select selected))))))) +(defslots tree-view + level-indentation :int + show-expanders :boolean + model pobject + hadjustment pobject + vadjustment pobject + headers-visible :boolean + headers-clickable :boolean + rules-hint :boolean + hover-selection :boolean + hover-expand :boolean + rubber-banding :boolean + search-column :int) (deffuns tree-view - (remove-column :int (column pobject))) + (remove-column :int (column pobject)) + (append-column :int (column pobject)) + (insert-column :int (column pobject) (position :int) &key) + (:get selection pobject) + (:get columns g-list-object) + (:get column pobject (n :int))) (defmethod (setf columns) (columns (tree-view tree-view)) (dolist (column (columns tree-view)) (remove-column tree-view column)) (labels - ((mk-column (column colnum) - (cond - ((stringp column) - (mk-column (list :title column - :cell (make-instance 'cell-renderer-text) - :text colnum) colnum)) - ((consp column) (apply #'make-instance - (cons 'tree-view-column column))) - (t column))) - - (process (columns colnum) - (let* ((col (car columns)) - (col-obj (mk-column col colnum))) - (append-column tree-view col-obj)) - (when (cdr columns) - (process (cdr columns) (1+ colnum))))) - - (process columns 0))) - + ((mk-column (column num) + (typecase column + (string (make-instance 'tree-view-column + :title column + :cell (make-instance 'cell-renderer-text) + :attributes `(:text ,num))) + (cons (apply #'make-instance + 'tree-view-column column)) + (t column)))) + (reduce (lambda (num column) + (append-column tree-view (mk-column column num))) + columns :initial-value 0))) +(save-setter tree-view columns) -(defcfun "gtk_tree_view_append_column" :int - (view pobject) (column pobject)) - -(defmethod append-column ((tree-view tree-view) - (tree-view-column tree-view-column)) - (gtk-tree-view-append-column tree-view tree-view-column)) - -(defcfun "gtk_tree_view_set_model" :void - (view pobject) (model pobject)) - -(defmethod (setf model) ((tree-model tree-model) - (tree-view tree-view)) - (gtk-tree-view-set-model tree-view tree-model)) - -(defmethod (setf model) ((tree-model null) - (tree-view tree-view)) - (gtk-tree-view-set-model tree-view tree-model)) - - -(defcfun "gtk_tree_view_get_model" pobject - (view pobject)) - -(defmethod model ((tree-view tree-view)) - (gtk-tree-view-get-model tree-view)) - -(defcfun "gtk_tree_view_get_selection" :pointer (view pobject)) - -(defmethod get-selection ((tree-view tree-view)) - (make-instance 'tree-selection :pointer - (gtk-tree-view-get-selection tree-view))) - -(defcfun "gtk_tree_view_get_path_at_pos" :boolean (view pobject) +(defcfun gtk-tree-view-get-path-at-pos :boolean (view pobject) (x :int) (y :int) (path :pointer) (column :pointer) (cell-x :pointer) (cell-y :pointer)) (defmethod path-at-pos ((tree-view tree-view) x y) - (with-foreign-objects - ((path :pointer) - (column :pointer) - (cell-x :pointer) - (cell-y :pointer)) - (when - (gtk-tree-view-get-path-at-pos tree-view x y path column cell-x cell-y) - (list - (mem-ref path 'tree-path) - (mem-ref column 'pobject) - (mem-ref cell-x :int) (mem-ref cell-y :int))))) - -;(defmacro with-path-at-pos (tree-view x y &rest body) -; `(with-object (%path (first %path)) (path-at-pos ,tree-view ,x ,y) , at body)) + (with-foreign-outs-list + ((path 'tree-path) (column 'pobject) + (cell-x :int) (cell-y :int)) :if-success + (gtk-tree-view-get-path-at-pos tree-view x y path column cell-x cell-y))) -(defcfun "gtk_tree_view_get_cursor" :void (view pobject) +(defcfun gtk-tree-view-get-cursor :void (view pobject) (path :pointer) (column :pointer)) (defmethod get-cursor ((tree-view tree-view)) - (with-foreign-objects - ((path :pointer) - (column :pointer)) - (gtk-tree-view-get-cursor tree-view path column) - (list (mem-ref path 'tree-path) - (mem-ref column 'pobject)))) - -;(defmacro with-get-cursor-path (tree-view &rest body) -; `(with-object (%path (first %path)) (get-cursor ,tree-view) , at body)) - -(defcfun "gtk_tree_view_get_columns" g-list-object (tree-view pobject)) - -(defmethod columns ((tree-view tree-view)) - (gtk-tree-view-get-columns tree-view)) + (with-foreign-outs-list ((path 'tree-path) (column 'pobject)) :ignore + (gtk-tree-view-get-cursor tree-view path column))) -(defcfun "gtk_tree_view_get_column" pobject (tree-view pobject) (n :int)) +(defcfun gtk-tree-view-insert-column-with-data-func :int + (tree-view pobject) (postion :int) (title :string) (cell pobject) + (data-func pfunction) (data pdata) (destroy pfunction)) + +(defmethod insert-column ((tree-view tree-view) (cell cell-renderer) position + &key title func data destroy-notify) + (set-callback tree-view gtk-tree-view-insert-column-with-data-func + cb-cell-data-func func data destroy-notify + position title cell)) + -(defmethod column ((tree-view tree-view) n) - (gtk-tree-view-get-column tree-view n)) - -(defcfun "gtk_tree_view_set_search_column" :void (tree-view pobject) (n :int)) - -(defmethod (setf search-column) (n (tree-view tree-view)) - (gtk-tree-view-set-search-column tree-view n)) - -(defcfun "gtk_tree_view_get_search_column" :int (tree-view pobject)) - -(defmethod search-column ((tree-view tree-view)) - (gtk-tree-view-get-search-column tree-view)) \ No newline at end of file +(init-slots tree-view (on-select) + (when on-select + (setf (gsignal (selection tree-view) :changed) + (lambda (selection) + (destructuring-bind (rows model) (selected-rows selection) + (when rows + (apply on-select model rows))))))) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/08/12 17:42:30 1.16 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/10/07 12:02:11 1.17 @@ -44,61 +44,61 @@ (defcfun gtk-widget-show-now :boolean (widget pobject)) (defgeneric show (widget &key all now) - (:documentation "gtk_widget_show[_now|_all] ALL and NOW are booleans")) -(defmethod show ((widget widget) &key (all t) now) - (funcall (cond - (now #'gtk-widget-show-now) - (all #'gtk-widget-show-all) - (t #'gtk-widget-show)) widget)) + (:documentation "gtk_widget_show[_now|_all] ALL and NOW are booleans") + (:method ((widget widget) &key (all t) now) + (funcall (cond + (now #'gtk-widget-show-now) + (all #'gtk-widget-show-all) + (t #'gtk-widget-show)) widget))) (defcfun gtk-widget-draw :void (widget pobject) (context :pointer)) (defgeneric draw (widget &optional context) - (:documentation "context is cl-cairo2 context")) -(defmethod draw ((widget widget) &optional (context cl-cairo2:*context*)) + (:documentation "context is cl-cairo2 context") + (:method ((widget widget) &optional (context cl-cairo2:*context*)) (cl-cairo2::with-context-pointer (context cntx-pointer) - (gtk-widget-draw widget cntx-pointer))) + (gtk-widget-draw widget cntx-pointer)))) (defcfun gtk-widget-queue-draw-area :void (widget pobject) (x :int) (y :int) (width :int) (height :int)) (defcfun gtk-widget-queue-draw-region :void (widget pobject) (region pobject)) (defcfun gtk-widget-queue-draw :void (widget pobject)) -(defgeneric queue-draw (widget &key area region)) -(defmethod queue-draw ((widget widget) &key area region) - (cond - (area (apply #'gtk-widget-queue-draw-area widget area)) - (region (gtk-widget-queue-draw-region widget region)) - (t (gtk-widget-queue-draw widget)))) +(defgeneric queue-draw (widget &key area region) + (:method ((widget widget) &key area region) + (cond + (area (apply #'gtk-widget-queue-draw-area widget area)) + (region (gtk-widget-queue-draw-region widget region)) + (t (gtk-widget-queue-draw widget))))) (defcfun gtk-widget-queue-resize :void (widget pobject)) (defcfun gtk-widget-queue-resize-no-redraw :void (widget pobject)) -(defgeneric queue-resize (widget &key no-redraw)) -(defmethod queue-resize ((widget widget) &key no-redraw) - (if no-redraw - (gtk-widget-queue-resize-no-redraw widget) - (gtk-widget-queue-resize widget))) +(defgeneric queue-resize (widget &key no-redraw) + (:method ((widget widget) &key no-redraw) + (if no-redraw + (gtk-widget-queue-resize-no-redraw widget) + (gtk-widget-queue-resize widget)))) -(defcfun "gtk_widget_get_size_request" :void +(defcfun gtk-widget-get-size-request :void (widget pobject) (width :pointer) (height :pointer)) -(defgeneric size-request (widget)) -(defmethod size-request ((widget widget)) - "returns (width height)" - (with-foreign-outs-list ((width :int) (height :int)) :ignore - (gtk-widget-get-size-request widget width height))) +(defgeneric size-request (widget) + (:method ((widget widget)) + "returns (width height)" + (with-foreign-outs-list ((width :int) (height :int)) :ignore + (gtk-widget-get-size-request widget width height)))) -(defcfun "gtk_widget_set_size_request" +(defcfun gtk-widget-set-size-request :void (widget pobject) (w :int) (h :int)) -(defgeneric (setf size-request) (coords widget)) -(defmethod (setf size-request) (coords (widget widget)) - "coords = (width height)" - (gtk-widget-set-size-request widget - (first coords) - (second coords))) +(defgeneric (setf size-request) (coords widget) + (:method (coords (widget widget)) + "coords = (width height)" + (gtk-widget-set-size-request widget + (first coords) + (second coords)))) (save-setter widget size-request) (defcfun gtk-widget-intersect :boolean