From rklochkov at common-lisp.net Mon May 7 09:02:04 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 07 May 2012 02:02:04 -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-serv22276/examples Modified Files: ex2.lisp ex4.lisp ex6.lisp ex7.lisp ex8.lisp ex9.lisp Log Message: Added with-progress in extensions Added GtkOrientable, GtkRange, GtkBuildable, & Cairo support in gdk (see examples/ex6) Fixed all examples. --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex2.lisp 2011/12/31 17:20:56 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex2.lisp 2012/05/07 09:02:03 1.6 @@ -1,7 +1,7 @@ (asdf:oos 'asdf:load-op :gtk-cffi) (defpackage :test-ex2 - (:use #:common-lisp #:gtk-cffi #:cffi-object #:g-object-cffi)) + (:use #:common-lisp #:gtk-cffi #:cffi-objects #:g-object-cffi)) (in-package :test-ex2) @@ -16,7 +16,7 @@ ("finance" (480 360)))) (cffi:defcallback clicked - :void ((widget :pointer) (activated-module gtk-string)) + :void ((widget :pointer) (activated-module :string)) (declare (ignore widget)) (declare (ignorable widget)) (format t "button_clicked: ~a~%" activated-module) @@ -30,7 +30,7 @@ (cffi:defcallback on-delete :boolean ((widget :pointer) (event :pointer) - (module gtk-string)) + (module :string)) (declare (ignore widget event)) (unless (string= module "main") (hide (gethash module *apps*)) @@ -39,7 +39,7 @@ (cffi:defcallback on-key :boolean ((widget :pointer) (event :pointer) - (module gtk-string)) + (module :string)) (declare (ignore widget)) (when (eq (gdk-cffi:parse-event event :keyval) (gdk-cffi:key :f12)) (format t "~a~%" module) @@ -70,7 +70,7 @@ (pack h-box (make-instance 'label) :fill t :expand t) (setf (gsignal button :clicked :data (cffi:convert-to-foreign - (car module) 'gtk-string)) + (car module) :string)) (cffi:callback clicked)))) *mods*))) @@ -78,7 +78,7 @@ (defun setup-app (module) (let ((dialog (make-instance 'dialog :title (car module) :flags :modal))) - (setf (window-position dialog) :center-always) + (setf (position-type dialog) :center-always) (setf (size-request dialog) (second module)) ;(setf (property dialog :content-area-border) 10) (let ((top-area (content-area dialog))) @@ -99,10 +99,10 @@ (show-buttons top-area (car module))) ;(setf (has-separator dialog) nil) (setf (gsignal dialog :delete-event - :data (cffi:convert-to-foreign (car module) 'gtk-string)) + :data (cffi:convert-to-foreign (car module) :string)) (cffi:callback on-delete) (gsignal dialog :key-press-event - :data (cffi:convert-to-foreign (car module) 'gtk-string)) + :data (cffi:convert-to-foreign (car module) :string)) (cffi:callback on-key)) dialog)) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex4.lisp 2011/08/26 17:16:13 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex4.lisp 2012/05/07 09:02:03 1.3 @@ -8,24 +8,24 @@ (gtk-init) (let ((window (make-instance 'window :width 400 :height 280)) (hpane (make-instance 'h-paned))) - + (setf (gsignal window :destroy) :gtk-main-quit) - + (let ((v-box (make-instance 'v-box))) (add window v-box) - + (let ((title (make-instance 'label :text "Use of GtkHPaned"))) (setf (font title) "Times New Roman Italic 10" (color title) "#0000ff") (setf (size-request title) '(-1 40)) (pack v-box title :expand nil)) - + (pack v-box (make-instance - 'label :text "Click on the options on the left pane.") + 'label :text "Click on the options on the left pane.") :expand nil) (pack v-box (make-instance 'label) :expand nil) (pack v-box hpane :fill t :expand t)) - + (let ((left-pane (make-instance 'frame)) (v-box (make-instance 'v-box))) (setf (shadow-type left-pane) :in) @@ -35,7 +35,8 @@ (pack v-box (create-link "Qty > 10")) (pack v-box (create-link "Price < $10")) (pack hpane left-pane)) - + + (let ((right-pane (make-instance 'frame)) (data '(("row 0" "item 42" 2 3.1) ("row 1" "item 36" 20 6.21) @@ -44,17 +45,17 @@ ("row 4" "item 7" 5 15.5) ("row 5" "item 4" 17 18.6) ("row 6" "item 3" 20 21.73)))) - + (setf data (append data data)) (setf data (append data data)) (setf data (append data data)) - + (setf (shadow-type right-pane) :in) (pack hpane right-pane :pane-type 2 :resize t) (format t "parent of ~a is ~a~%" right-pane (property right-pane :parent)) (display-table right-pane data)) - + (show window :all t) (gtk-main))) @@ -110,7 +111,7 @@ (setf (widget column) label) (show label)) (if (/= col 0) (setf (reorderable column) t)) - (setf (cell-data-func column cell-renderer col) + (setf (cell-data-func column cell-renderer :data col) (cffi:callback format-col)) (append-column *view* column))))) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex6.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex6.lisp 2012/05/07 09:02:03 1.3 @@ -33,18 +33,23 @@ ((setf hbox (make-instance 'h-box :homogeneous t)) :expand t :fill t))) -(defun expose-event (widget event &optional (img "none")) - (format t "~a ~a ~a~%" widget event img) +(defun expose-event (widget context &optional (img "none")) + (format t "~a ~a ~a~%" widget context img) (let* ((pixbuf (make-instance 'pixbuf :file img)) (w (width pixbuf)) - ;(h (height pixbuf)) - (dest-x (- (allocation-width (allocation widget)) w)) + (dest-x (- (width (allocation widget)) w)) (dest-y 0)) - (draw-pixbuf (gdk-window widget) - (style-field widget :bg-gc) pixbuf 0 0 dest-x dest-y) - (let ((ch (child widget))) - (when ch - (propagate-expose widget ch event))) + (format t "~a~%" pixbuf) + (unless (cffi:null-pointer-p (cffi-objects:pointer pixbuf)) + (cl-cairo2:with-context ((make-instance 'cl-cairo2:context + :pointer context)) + (cairo-set-source-pixbuf pixbuf dest-x dest-y) + (cl-cairo2:paint))) +; (draw-pixbuf (gdk-window widget) +; (style-field widget :bg-gc) pixbuf 0 0 dest-x dest-y) + ;(let ((ch (child widget))) + ; (when ch + ; (propagate- widget ch event))) t)) @@ -57,7 +62,7 @@ ((make-instance 'label :text "The green ball is the bg image.")) ((make-instance 'label :text "Note that this eventbox")) ((make-instance 'label :text "uses the default gray backgd color."))) - (setf (gsignal eventbox-left :expose-event :data "ball_green3.png") + (setf (gsignal eventbox-left :draw :data "ball_green3.png") #'expose-event)) (let ((eventbox-right (make-instance 'event-box))) @@ -68,8 +73,8 @@ ((make-instance 'label :text "The blue ball is the bg image.")) ((make-instance 'label :text "Note that you can also set")) ((make-instance 'label :text "backgd color for the eventbox!"))) - (setf (color eventbox-right :bg) "#BAFFB3") - (setf (gsignal eventbox-right :expose-event :data "ball_blue3.png") + (setf (color eventbox-right :type :bg) "#BAFFB3") + (setf (gsignal eventbox-right :draw :data "ball_blue3.png") #'expose-event)) (show window :all t) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex7.lisp 2011/08/26 17:16:13 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex7.lisp 2012/05/07 09:02:03 1.4 @@ -107,29 +107,30 @@ (setf (search-column view) i))))) (defun on-click (view path-list) - (destructuring-bind (path column x y) path-list - (declare (ignore y)) - (let ((cell (get-cell-at column x))) - (format t "cell: ~A~%" cell) - (when (equal cell *cell-pix*) - (let ((dialog (make-instance 'dialog :title "Edit text" - :parent *window* - :buttons '((:gtk-ok :ok) - (:gtk-cancel :cancel))))) - (let ((text-view (make-instance 'text-view)) - (iter (path->iter (model view) path))) - (setf (text (buffer text-view)) - (car (model-values (model view) :columns '(1) :iter iter))) - (let ((top-area (content-area dialog))) - (pack top-area text-view :pack-fill t :expand t) - (show text-view)) - (setf (window-position dialog) :center-on-parent) - - ;(pack top-area text-view :fill t :expand t)) - (run dialog) - (setf (model-values (model view) :columns '(1) :iter iter) - (list (text (buffer text-view)))) - (destroy dialog))))))) + (when path-list + (destructuring-bind (path column x y) path-list + (declare (ignore y)) + (let ((cell (get-cell-at column x))) + (format t "cell: ~A~%" cell) + (when (equal cell *cell-pix*) + (let ((dialog (make-instance 'dialog :title "Edit text" + :parent *window* + :buttons '((:gtk-ok :ok) + (:gtk-cancel :cancel))))) + (let ((text-view (make-instance 'text-view)) + (iter (path->iter (model view) path))) + (setf (text (buffer text-view)) + (car (model-values (model view) :columns '(1) :iter iter))) + (let ((top-area (content-area dialog))) + (pack top-area text-view :pack-fill t :expand t) + (show text-view)) + (setf (window-position dialog) :center-on-parent) + + ;(pack top-area text-view :fill t :expand t)) + (run dialog) + (setf (model-values (model view) :columns '(1) :iter iter) + (list (text (buffer text-view)))) + (destroy dialog)))))))) (main) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex8.lisp 2011/08/08 15:02:01 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex8.lisp 2012/05/07 09:02:03 1.3 @@ -3,9 +3,9 @@ (asdf:oos 'asdf:load-op :gtk-cffi) (asdf:oos 'asdf:load-op :closer-mop) -(defpackage #:test +(defpackage #:test8 (:use #:common-lisp #:gtk-cffi #:g-object-cffi)) -(in-package #:test) +(in-package #:test8) (defun main () (gtk-init) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex9.lisp 2012/01/21 18:35:00 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex9.lisp 2012/05/07 09:02:03 1.4 @@ -1,8 +1,8 @@ (asdf:oos 'asdf:load-op :gtk-cffi-ext) ;(declaim (optimize speed)) -(defpackage #:test +(defpackage #:test9 (:use #:common-lisp #:iter #:gtk-cffi #:gtk-cffi-ext #:g-object-cffi)) -(in-package #:test) +(in-package #:test9) (gtk-init) (defparameter *model* From rklochkov at common-lisp.net Mon May 7 09:02:04 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 07 May 2012 02:02:04 -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-serv22276/ext Modified Files: gtk-cffi-ext.asd package.lisp Added Files: progress.lisp Log Message: Added with-progress in extensions Added GtkOrientable, GtkRange, GtkBuildable, & Cairo support in gdk (see examples/ex6) Fixed all examples. --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/gtk-cffi-ext.asd 2012/01/21 18:37:52 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/gtk-cffi-ext.asd 2012/05/07 09:02:04 1.2 @@ -13,5 +13,6 @@ :components ((:file package) (:file lisp-model :depends-on (package)) - (:file addons :depends-on (package)))) + (:file addons :depends-on (package)) + (:file progress :depends-on (package)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/package.lisp 2012/02/12 17:29:41 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/package.lisp 2012/05/07 09:02:04 1.3 @@ -17,5 +17,7 @@ #:implementation #:lisp-model-array #:lisp-model-tree-array - #:larray)) + #:larray + #:with-progress + #:set-progress)) --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/progress.lisp 2012/05/07 09:02:04 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/progress.lisp 2012/05/07 09:02:04 1.1 (in-package :gtk-cffi-ext) (defmacro with-progress ((&key parent (title "") (width 400)) &body body) (let ((widget-var (gensym)) (progress-var (gensym))) `(let* ((,progress-var (make-instance 'progress-bar)) (,widget-var (gtk-model 'window :title ,title :transient-for ,parent :position-type :center-on-parent :width ,width :kid ,progress-var))) (flet ((set-progress (frac) (setf (fraction ,progress-var) frac) (draw ,progress-var))) (show ,widget-var) , at body (destroy ,widget-var))))) From rklochkov at common-lisp.net Mon May 7 09:02:04 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 07 May 2012 02:02:04 -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-serv22276/g-lib Modified Files: error.lisp mainloop.lisp package.lisp Log Message: Added with-progress in extensions Added GtkOrientable, GtkRange, GtkBuildable, & Cairo support in gdk (see examples/ex6) Fixed all examples. --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/error.lisp 2012/03/06 01:25:26 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/error.lisp 2012/05/07 09:02:04 1.5 @@ -35,11 +35,11 @@ ((domain errno message) p g-error) `(:domain ,domain :errno ,errno :message ,message))))) -(defmethod print-object ((g-error g-error) stream) - (let ((err (get-error g-error))) - (format stream "GError ~A (~A): ~A" - (g-quark-to-string (getf err :domain)) - (getf err :errno) (getf err :message)))) +;(defmethod print-object ((g-error g-error) stream) +; (let ((err (get-error g-error))) +; (format stream "GError ~A (~A): ~A" +; (g-quark-to-string (getf err :domain)) +; (getf err :errno) (getf err :message)))) (defun throw-g-error (g-error) (let ((err (get-error g-error))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/mainloop.lisp 2011/04/25 19:16:07 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/mainloop.lisp 2012/05/07 09:02:04 1.2 @@ -103,3 +103,8 @@ (defun yield () (do () ((not (g-main-context-pending (null-pointer)))) (g-main-context-iteration (null-pointer) nil))) + + +(defun yield1 () + (when (g-main-context-pending (null-pointer)) + (g-main-context-iteration (null-pointer) nil))) \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/package.lisp 2012/03/06 01:25:26 1.8 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/package.lisp 2012/05/07 09:02:04 1.9 @@ -33,6 +33,7 @@ #:timeout-add #:timeout-remove #:yield + #:yield1 #:g-intern-static-string #:g-free From rklochkov at common-lisp.net Mon May 7 09:02:04 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 07 May 2012 02:02:04 -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-serv22276/g-object Modified Files: defslots.lisp g-object-class.lisp g-object.lisp g-type.lisp g-value.lisp pobject.lisp Log Message: Added with-progress in extensions Added GtkOrientable, GtkRange, GtkBuildable, & Cairo support in gdk (see examples/ex6) Fixed all examples. --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/03/06 01:25:26 1.11 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/05/07 09:02:04 1.12 @@ -148,7 +148,7 @@ (cb-name (gensym))) `(progn (defcfun ,gtk-name :void - (,class pobject) (func pfunction) (data (pdata :free t))) + (,class pobject) (func pfunction) (data (pdata :free :all))) (defcallback ,cb-name :void ,params ;((tag pobject) (data pdata)) (funcall *callback* ,@(mapcar #'car params))) (defmethod foreach ((,class ,class) func &optional data) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp 2012/02/12 17:29:41 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp 2012/05/07 09:02:04 1.6 @@ -8,7 +8,7 @@ (in-package #:g-object-cffi) (defclass g-object-class (object) - ()) + ((free-after :initform nil))) (defcstruct g-object-class (type-class g-type-class) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2012/02/20 16:51:37 1.9 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2012/05/07 09:02:04 1.10 @@ -168,8 +168,8 @@ (defmethod connect ((g-object g-object) c-handler &key signal data after swapped) (let* ((str-signal (string-downcase signal)) - (c-handler (if (and (symbolp c-handler) (fboundp c-handler)) - (symbol-function c-handler) c-handler)) + (c-handler (if (and (symbolp c-handler) (fboundp c-handler)) + (symbol-function c-handler) c-handler)) (handler-id (typecase c-handler (function (g-signal-connect-closure --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2012/03/06 01:25:26 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2012/05/07 09:02:04 1.7 @@ -31,7 +31,7 @@ (defcstruct g-type-instance "GTypeInstance" - (g-class g-type-class)) + (g-class (:pointer g-type-class))) (defun g-type-from-instance (ptr) (foreign-slot-value @@ -95,22 +95,22 @@ (mapc #'princ (list "-" c)) (princ (char-upcase c)))))))) (with-hash *types* g-type - (let ((typename (g-type-name g-type))) - (when typename - (or (cdr (assoc typename *typenames* :test 'string=)) - (let* ((pr-pos - (loop - :for c :across (subseq typename 1) - :for i :from 1 - :when (upper-case-p c) :return i)) - (prefix (subseq typename 0 pr-pos)) - (package - (cdr (assoc prefix *gtk-packages* - :test 'string=)))) - (when package - (intern (case-to-lisp - (subseq typename pr-pos)) - package))))))))) + (let ((typename (g-type-name g-type))) + (when typename + (or (cdr (assoc typename *typenames* :test 'string=)) + (let* ((pr-pos + (loop + :for c :across (subseq typename 1) + :for i :from 1 + :when (upper-case-p c) :return i)) + (prefix (subseq typename 0 pr-pos)) + (package + (cdr (assoc prefix *gtk-packages* + :test 'string=)))) + (when package + (intern (case-to-lisp + (subseq typename pr-pos)) + package))))))))) (defcfun g-type-children (garray g-type) (type g-type) (n-children :pointer)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2012/02/20 16:51:37 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2012/05/07 09:02:04 1.5 @@ -157,6 +157,8 @@ (unless (null-pointer-p value) (let* ((g-type (type-g-value value)) (fundamental-type (g-type-fundamental g-type))) + ;(format t "g-val:~a ~a ~a~%" g-type fundamental-type + ; (g-type->lisp g-type)) (case fundamental-type (#.(keyword->g-type :boxed) (find-object (g-value-get-boxed value) @@ -174,7 +176,10 @@ fundamental-type :g-value-get-) value))))))) (defmethod value ((g-value g-value)) - (g-value-get (pointer g-value))) + (let ((l + (g-value-get (pointer g-value)))) + ;(format t "g-val2: ~a~%" l) + l)) (defmethod free ((g-value g-value)) (g-value-unset g-value) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2012/02/20 16:51:37 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp 2012/05/07 09:02:04 1.7 @@ -19,8 +19,11 @@ make up lisp object" (declare (type foreign-pointer ptr)) (unless (null-pointer-p ptr) +; (format t "pobject: ~a~%" ptr) (let ((class (or (object-class cffi-pobject) (g-type->lisp (g-type-from-instance ptr))))) + ; (format t "gtype: ~a :: ~a~%" (g-type-from-instance ptr) class) + (find-object ptr class)))) ;; register as object type for g-list @@ -50,7 +53,7 @@ (define-foreign-type cffi-pdata (cffi-pobject freeable-base) - () + ((free :initform :none)) (:actual-type :pointer) (:simple-parser pdata) (:documentation "PDATA lets send any data via a c-pointer. C-pointer used as From rklochkov at common-lisp.net Mon May 7 09:02:04 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 07 May 2012 02:02:04 -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-serv22276/gdk Modified Files: gdk-cffi.asd package.lisp Added Files: cairo.lisp Log Message: Added with-progress in extensions Added GtkOrientable, GtkRange, GtkBuildable, & Cairo support in gdk (see examples/ex6) Fixed all examples. --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/gdk-cffi.asd 2011/09/15 10:28:20 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/gdk-cffi.asd 2012/05/07 09:02:04 1.7 @@ -31,4 +31,5 @@ (:file visual :depends-on (loadlib generics)) (:file image :depends-on (visual)) (:file atom :depends-on (loadlib)) - (:file pixbuf :depends-on (image gc)))) + (:file pixbuf :depends-on (image gc)) + (:file cairo :depends-on (pixbuf)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/package.lisp 2012/03/06 01:25:26 1.10 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/package.lisp 2012/05/07 09:02:04 1.11 @@ -72,8 +72,12 @@ #:keyval-to-lower #:gatom + + #:cairo-create + #:cairo-set-source-pixbuf )) (in-package #:gdk-cffi) (register-package "Gdk" *package*) (register-prefix *package* 'gdk) +;(register-package "Cairo" (find-package "CL-CAIRO2")) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/cairo.lisp 2012/05/07 09:02:04 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/cairo.lisp 2012/05/07 09:02:04 1.1 (in-package :gdk-cffi) (defcfun gdk-cairo-create :pointer (window pobject)) (defun cairo-create (window) (let* ((p (gdk-cairo-create window)) (context (make-instance 'cl-cairo2:context :pointer p))) (tg:finalize context #'(lambda () (cl-cairo2::cairo_destroy p))) context)) (defcfun gdk-cairo-set-source-pixbuf :void (context :pointer) (pixbuf pobject) (x :double) (y :double)) (defun cairo-set-source-pixbuf (pixbuf x y &optional (context cl-cairo2:*context*)) (gdk-cairo-set-source-pixbuf (cl-cairo2::get-pointer context) pixbuf x y)) From rklochkov at common-lisp.net Mon May 7 09:02:05 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 07 May 2012 02:02:05 -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-serv22276/gtk Modified Files: assistant.lisp builder.lisp combo-box.lisp file-chooser-dialog.lisp file-chooser.lisp gtk-cffi.asd icon.lisp image.lisp misc.lisp package.lisp progress-bar.lisp table.lisp tree-model.lisp widget.lisp Added Files: buildable.lisp file-filter.lisp orientable.lisp range.lisp Log Message: Added with-progress in extensions Added GtkOrientable, GtkRange, GtkBuildable, & Cairo support in gdk (see examples/ex6) Fixed all examples. --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/assistant.lisp 2012/03/08 09:58:12 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/assistant.lisp 2012/05/07 09:02:04 1.3 @@ -34,7 +34,7 @@ (:get page-complete :boolean (page pobject)) (add-action-widget :void (child pobject) &key) (remove-action-widget :void (child pobject)) - (update-button-state :void) + (update-buttons-state :void) (commit :void) (next-page :void) (previous-page :void)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/builder.lisp 2012/03/08 09:58:12 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/builder.lisp 2012/05/07 09:02:04 1.3 @@ -27,21 +27,23 @@ (builder pobject) (string :string) (length gsize) (object-ids string-list) (g-error g-error)) -(defmethod add-from ((builder builder) &key filename string objects) - (with-g-error g-error - (when - (= 0 - (if filename - (if objects - (gtk-builder-add-objects-from-file builder filename - objects g-error) - (gtk-builder-add-from-file builder filename g-error)) - (if objects - (gtk-builder-add-objects-from-string - builder string (length string) objects g-error) - (gtk-builder-add-from-string builder - string (length string) g-error)))) - (throw-g-error g-error)))) +(defgeneric add-from (builder &key filename string objects) + (:method + ((builder builder) &key filename string objects) + (with-g-error g-error + (when + (= 0 + (if filename + (if objects + (gtk-builder-add-objects-from-file builder filename + objects g-error) + (gtk-builder-add-from-file builder filename g-error)) + (if objects + (gtk-builder-add-objects-from-string + builder string (length string) objects g-error) + (gtk-builder-add-from-string + builder string (length string) g-error)))) + (throw-g-error g-error))))) (defcfun gtk-builder-connect-signals-full :void (builder pobject) (func pfunction) (user-data :pointer)) @@ -56,10 +58,11 @@ :after (not (null (find :after flags))) :swapped (not (null (find :swapped flags))))) -(defmethod connect-signals ((builder builder) &key func) - (gtk-builder-connect-signals-full builder - (or func (callback cb-find-defun)) - (null-pointer))) +(defgeneric connect-signals (builder &key func) + (:method ((builder builder) &key func) + (gtk-builder-connect-signals-full builder + (or func (callback cb-find-defun)) + (null-pointer)))) (deffuns builder @@ -78,16 +81,17 @@ (builder pobject) (g-type g-type) (string :string) (value pobject) (g-error g-error)) -(defmethod value-from-string ((builder builder) &key g-type param-spec string) - (let ((value (make-instance 'g-value))) - (with-g-error g-error - (unless (if param-spec - (gtk-builder-value-from-string builder param-spec string - value g-error) - (gtk-builder-value-from-string-type builder g-type string - value g-error)) - (throw-g-error g-error))) - value)) +(defgeneric value-from-string (builder &key g-type param-spec string) + (:method ((builder builder) &key g-type param-spec string) + (let ((value (make-instance 'g-value))) + (with-g-error g-error + (unless (if param-spec + (gtk-builder-value-from-string builder param-spec string + value g-error) + (gtk-builder-value-from-string-type builder g-type string + value g-error)) + (throw-g-error g-error))) + value))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/combo-box.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/combo-box.lisp 2012/05/07 09:02:04 1.2 @@ -1,58 +1,82 @@ (in-package :gtk-cffi) (defclass combo-box (bin) - ((model :accessor model :initarg :model))) + ()) -(defcfun "gtk_combo_box_new_with_model" :pointer (model pobject)) +(defcfun gtk-combo-box-new :pointer) +(defcfun gtk-combo-box-new-with-entry :pointer) +(defcfun gtk-combo-box-new-with-model :pointer (model pobject)) +(defcfun gtk-combo-box-new-with-model-and-entry :pointer (model pobject)) +(defcfun gtk-combo-box-new-with-area :pointer (area pobject)) +(defcfun gtk-combo-box-new-with-area-and-entry :pointer (area pobject)) + +(defmethod gconstructor ((combo-box combo-box) + &key model area entry &allow-other-keys) + (cond + (model + (if entry + (gtk-combo-box-new-with-model-and-entry model) + (gtk-combo-box-new-with-model model))) + (area + (if entry + (gtk-combo-box-new-with-area-and-entry area) + (gtk-combo-box-new-with-area area))) + (t + (if entry + (gtk-combo-box-new-with-entry) + (gtk-combo-box-new))))) -(defcfun "gtk_combo_box_new" :pointer) -(defcfun "gtk_combo_box_new_text" :pointer) - -(defmethod initialize-instance - :after ((combo-box combo-box) - &key model text-only &allow-other-keys) - (setf (pointer combo-box) - (cond - (model (gtk-combo-box-new-with-model model)) - (text-only (gtk-combo-box-new-text)) - (t (gtk-combo-box-new))))) - - -(defcfun "gtk_combo_box_set_model" :void (combo-box pobject) (model pobject)) - -(defmethod (setf model) :after ((tree-model tree-model) (combo-box combo-box)) +(defcfun gtk-combo-box-set-model :void (combo-box pobject) (model pobject)) +(defmethod (setf model) (tree-model (combo-box combo-box)) (gtk-combo-box-set-model combo-box tree-model)) -(defmethod (setf model) :after (badval (combo-box combo-box)) - (error "Should be tree-model in setf model ")) - -(defcfun "gtk_combo_box_append_text" :void - (combo-box pobject) (text gtk-string)) - -(defmethod append-text ((combo-box combo-box) text) - (gtk-combo-box-append-text combo-box text)) - -(defcfun "gtk_combo_box_prepend_text" :void - (combo-box pobject) (text gtk-string)) +(defslots combo-box + wrap-width :int + row-span-column :int + column-span-column :int + active :int + active-iter pobject + id-column :int + add-tearoffs :boolean + title :string + focus-on-click :boolean + button-sensitivity sensitivity-type + entry-text-column :int + popup-fixed-width :boolean) + +(deffuns combo-box + (:get model pobject) + (:get active-id :string) + (popup-for-device :void (device pobject)) + (popup :void) + (popdown :void) + (:get row-separator-func :pointer) + (:get has-entry :boolean)) + + +(defcallback cb-row-separator-func + :boolean ((model pobject) (iter pobject) (data pdata)) + (funcall data model iter)) + +(defcfun gtk-combo-box-set-row-separator-func :void + (combo-box pobject) (func pfunction) (data pdata) (notify :pointer)) + + +(defmethod (setf row-separator-func) (func (combo-box combo-box) + &key data destroy-notify) + (set-callback combo-box gtk-combo-box-set-row-separator-func + cb-row-separator-func func data destroy-notify)) -(defmethod prepend-text ((combo-box combo-box) text) - (gtk-combo-box-prepend-text combo-box text)) -(defcfun "gtk_combo_box_insert_text" :void - (combo-box pobject) (text gtk-string)) -(defmethod insert-text ((combo-box combo-box) text) - (gtk-combo-box-insert-text combo-box text)) +(defcfun gtk-combo-box-set-active-id :boolean + (combo-box pobject) (active-id :string)) +(defmethod (setf active-id) (active-id (combo-box combo-box)) + (values active-id + (gtk-combo-box-set-active-id combo-box active-id))) -(defcfun "gtk_combo_box_remove_text" :void - (combo-box pobject) (pos :int)) -(defmethod remove-text ((combo-box combo-box) pos) - (gtk-combo-box-remove-text combo-box pos)) -(defcfun "gtk_combo_box_get_active_text" gtk-string (combo-box pobject)) -(defmethod active-text ((combo-box combo-box)) - (gtk-combo-box-get-active-text combo-box)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser-dialog.lisp 2012/02/12 17:29:42 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser-dialog.lisp 2012/05/07 09:02:04 1.4 @@ -9,18 +9,10 @@ (but2-text :string) (but2-response dialog-response) (null :pointer)) -;; (defcfun "gtk_file_chooser_dialog_new_with_backend" :pointer -;; (title :string) (parent pobject) (action file-chooser-action) -;; (backend :string) -;; (but1-text :string) (but1-response dialog-response) -;; (but2-text :string) (but2-response dialog-response) -;; (null :pointer)) - - (defmethod gconstructor ((file-chooser-dialog file-chooser-dialog) - &key title parent action &allow-other-keys) + &key (title "") dialog-parent action &allow-other-keys) (gtk-file-chooser-dialog-new - title parent action + title dialog-parent action "gtk-cancel" :cancel (case action ((:open :select-folder) "gtk-open") --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser.lisp 2012/02/12 17:29:42 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser.lisp 2012/05/07 09:02:04 1.3 @@ -6,13 +6,18 @@ (defcenum file-chooser-action :open :save :select-folder :create-folder) -(defcfun "gtk_file_chooser_set_filename" :boolean - (chooser pobject) (filename :string)) - -(defmethod (setf filename) (filename (file-chooser file-chooser)) - (gtk-file-chooser-set-filename file-chooser filename)) - -(defcfun "gtk_file_chooser_get_filename" :string (chooser pobject)) - -(defmethod filename ((file-chooser file-chooser)) - (gtk-file-chooser-get-filename file-chooser)) \ No newline at end of file +(defslots file-chooser + filename :string + action file-chooser-action + local-only :boolean + select-multiple :boolean + show-hidden :boolean + do-overwrite-confirmation :boolean + create-folders :boolean + current-folder-uri :string + preview-widget pobject + preview-widget-active :boolean + use-preview-label :boolean + extra-widget pobject + filter pobject) + \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/03/08 09:58:12 1.17 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/05/07 09:02:04 1.18 @@ -27,6 +27,8 @@ (:file css-provider :depends-on (style-provider)) (:file icon :depends-on (loadlib enums)) (:file window-group :depends-on (loadlib)) + (:file orientable :depends-on (loadlib)) + (:file buildable :depends-on (loadlib)) (:file builder :depends-on (loadlib)))) (defsystem gtk-cffi-widget @@ -318,14 +320,23 @@ ((:file text-mark) (:file text-view))) +(defsystem gtk-cffi-range + :description "Interface to GTK/Glib via CFFI" + :author "Roman Klochkov " + :version "0.99" + :license "LLGPL" + :depends-on (gtk-cffi-bin gtk-cffi-tree-model) + :components + ((:file range))) + (defsystem gtk-cffi-combo-box :description "Interface to GTK/Glib via CFFI" :author "Roman Klochkov " - :version "0.1" + :version "0.99" :license "LLGPL" - :depends-on (gtk-cffi-bin) + :depends-on (gtk-cffi-bin gtk-cffi-range) :components - ((:file :combo-box))) + ((:file combo-box))) (defsystem gtk-cffi-message-dialog :description "Interface to GTK/Glib via CFFI" @@ -334,25 +345,26 @@ :license "LLGPL" :depends-on (gtk-cffi-dialog) :components - ((:file :message-dialog))) + ((:file message-dialog))) (defsystem gtk-cffi-file-chooser :description "Interface to GTK/Glib via CFFI" :author "Roman Klochkov " - :version "0.1" + :version "0.8" :license "LLGPL" :depends-on (gtk-cffi-core) :components - ((:file :file-chooser))) + ((:file file-chooser) + (:file file-filter))) (defsystem gtk-cffi-file-chooser-dialog :description "Interface to GTK/Glib via CFFI" :author "Roman Klochkov " - :version "0.1" + :version "0.99" :license "LLGPL" :depends-on (gtk-cffi-file-chooser gtk-cffi-dialog) :components - ((:file :file-chooser-dialog))) + ((:file file-chooser-dialog))) (defsystem gtk-cffi-file-chooser-button :description "Interface to GTK/Glib via CFFI" @@ -482,5 +494,6 @@ gtk-cffi-statusbar gtk-cffi-notebook gtk-cffi-image + gtk-cffi-combo-box gtk-cffi-text-view)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/icon.lisp 2012/02/12 17:29:42 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/icon.lisp 2012/05/07 09:02:04 1.4 @@ -1,3 +1,9 @@ +;;; +;;; icon-size.lisp -- GtkIconSize +;;; +;;; Copyright (C) 2012, Roman Klochkov +;;; + (in-package :gtk-cffi) (defcenum icon-size @@ -14,10 +20,9 @@ (defclass icon-source (object) ()) -(defcfun "gtk_icon_source_new" :pointer) +(defcfun gtk-icon-source-new :pointer) -(defmethod gconstructor ((icon-source icon-source) &rest rest) - (declare (ignore icon-source rest)) +(defmethod gconstructor ((icon-source icon-source) &key) (gtk-icon-source-new)) (defgtkslots icon-source --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/image.lisp 2012/02/12 17:29:42 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/image.lisp 2012/05/07 09:02:04 1.3 @@ -1,17 +1,104 @@ +;;; +;;; image.lisp -- GtkImage +;;; +;;; Copyright (C) 2012, Roman Klochkov +;;; + (in-package :gtk-cffi) (defclass image (misc) ()) -(defcfun "gtk_image_new_from_file" :pointer (filename :string)) -;(defcenum "gtk_image_new_from_icon_set" :pointer -; (icon-set pobject) (icon-size icon-size)) -(defcfun "gtk_image_new_from_pixbuf" :pointer (pixbuf pobject)) -(defcfun "gtk_image_new_from_stock" :pointer +(defcfun gtk-image-new-from-file :pointer (filename :string)) +(defcfun gtk-image-new-from-icon-set :pointer + (icon-set pobject) (icon-size icon-size)) +(defcfun gtk-image-new-from-pixbuf :pointer (pixbuf pobject)) +(defcfun gtk-image-new-from-icon-name :pointer (icon-name :string) (icon-size icon-size)) +(defcfun gtk-image-new-from-animation :pointer (animation pobject)) +(defcfun gtk-image-new-from-stock :pointer (stock-id :string) (size icon-size)) +(defcfun gtk-image-new-from-gicon :pointer + (gicon pobject) (icon-size icon-size)) +(defcfun gtk-image-new :pointer) -(defmethod gconstructor ((image image) &key file pixbuf stock-id icon-size) +(defmethod gconstructor ((image image) + &key file pixbuf stock-id gicon + icon-size icon-name icon-set animation) (cond (file (gtk-image-new-from-file file)) (pixbuf (gtk-image-new-from-pixbuf pixbuf)) - (stock-id (gtk-image-new-from-stock stock-id icon-size)))) \ No newline at end of file + (stock-id (gtk-image-new-from-stock stock-id icon-size)) + (icon-set (gtk-image-new-from-icon-set icon-set icon-size)) + (icon-name (gtk-image-new-from-icon-name icon-name icon-size)) + (animation (gtk-image-new-from-animation animation)) + (gicon (gtk-image-new-from-gicon gicon icon-size)) + (t (gtk-image-new)))) + +(defslots image + pixel-size :int) + + +(defcfun gtk-image-set-from-file :pointer (image pobject) (filename :string)) +(defcfun gtk-image-set-from-icon-set :pointer + (image pobject) (icon-set pobject) (icon-size icon-size)) +(defcfun gtk-image-set-from-pixbuf :pointer (image pobject) (pixbuf pobject)) +(defcfun gtk-image-set-from-icon-name :pointer (image pobject) + (icon-name :string) (icon-size icon-size)) +(defcfun gtk-image-set-from-animation :pointer (image pobject) + (animation pobject)) +(defcfun gtk-image-set-from-stock :pointer + (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)) + + +(defmethod reinitialize-instance ((image image) &key file pixbuf stock-id gicon + icon-size icon-name icon-set animation) + (cond + (file (gtk-image-set-from-file image file)) + (pixbuf (gtk-image-set-from-pixbuf image pixbuf)) + (stock-id (gtk-image-set-from-stock image stock-id icon-size)) + (icon-set (gtk-image-set-from-icon-set image icon-set icon-size)) + (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)))) + +(defcenum image-type + :empty :pixbuf :stock :icon-set :animation :icon-name :gicon) + +(deffuns image + (:get pixbuf pobject) + (:get animation pobject) + (:get storage-type image-type)) + +(defcfun gtk-image-get-icon-set :void (image pobject) (icon-set :pointer) + (icon-size :pointer)) +(defgeneric icon-set (image) + (:method ((image image)) + (with-foreign-outs ((icon-set 'pobject) (icon-size 'icon-size)) :ignore + (gtk-image-get-icon-set image icon-set icon-size)))) + +(defcfun gtk-image-get-gicon :void (image pobject) (gicon :pointer) + (icon-size :pointer)) +(defgeneric gicon (image) + (:method ((image image)) + (with-foreign-outs ((gicon 'pobject) (icon-size 'icon-size)) :ignore + (gtk-image-get-gicon image gicon icon-size)))) + +(defcfun gtk-image-get-icon-name :void (image pobject) + (icon-name :pointer) (icon-size :pointer)) +(defmethod icon-name ((image image)) + (with-foreign-outs ((icon-name :string) (icon-size 'icon-size)) :ignore + (gtk-image-get-icon-set image icon-name icon-size))) + +(defcfun gtk-image-get-stock :void (image pobject) + (stock :pointer) (icon-size :pointer)) +(defgeneric stock (image) + (:method ((image image)) + (with-foreign-outs ((stock :string) (icon-size 'icon-size)) :ignore + (gtk-image-get-stock image stock icon-size)))) + + + \ No newline at end of file --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/misc.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/misc.lisp 2012/05/07 09:02:04 1.2 @@ -3,19 +3,32 @@ (defclass misc (widget) ()) -(defcfun "gtk_misc_set_alignment" :void (misc pobject) (x :float) (y :float)) +(defcfun gtk-misc-set-alignment :void (misc pobject) (x :float) (y :float)) -(defmethod (setf alignment) (coords (misc misc)) - (gtk-misc-set-alignment misc - (float (first coords)) - (float (second coords)))) +(defgeneric (setf alignment) (coords misc) + (:method (coords (misc misc)) + (gtk-misc-set-alignment misc + (float (first coords)) + (float (second coords))))) +(save-setter misc alignment) -(defcfun "gtk_misc_get_alignment" :void (misc pobject) +(defcfun gtk-misc-get-alignment :void (misc pobject) (x :pointer) (y :pointer)) (defmethod alignment ((misc misc)) - (with-foreign-objects ((x :float) (y :float)) - (gtk-misc-get-alignment misc x y) - (list (mem-ref x :float) - (mem-ref y :float)))) + (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))) +(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))) + --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/03/08 09:58:12 1.17 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/05/07 09:02:04 1.18 @@ -33,6 +33,11 @@ #:append-type #:append-for-widget #:prepend-type + + #:orientable + #:orientation + + #:buildable #:widget ;; widget slots @@ -374,6 +379,7 @@ #:misc ;; misc slots #:alignment + #:padding #:label ;; label slots @@ -693,6 +699,50 @@ #:is-text #:combo-box + ;; slots + #:wrap-width + #:row-span-column + #:column-span-column + #:active + #:active-iter + #:id-column + #:add-tearoffs + #:title + #:focus-on-click + #:button-sensitivity + #:entry-text-column + #:popup-fixed-width + ;; methods + #:model + #:active-id + #:popup-for-device + #:popup + #:popdown + #:row-separator-func + #:has-entry + #:active-id + #:row-separator-func + + #:range + ;; slots + #:fill-level + #:restrict-to-fill-level + #:show-fill-level + #:adjustment + #:inverted + #:value + #:round-digits + #:lower-stepper-sensitivity + #:upper-stepper-sensitivity + #:flippable + #:min-slider-size + #:slider-size-fixed + ;; methods + #:increments + #:range + #:slider-range + #:range-rect + #:append-text #:prepend-text #:insert-text @@ -712,6 +762,25 @@ #:file-chooser ;; file-chooser slots #:filename + #:action + #:local-only + #:select-multiple + #:show-hidden + #:do-overwrite-confirmation + #:create-folders + #:current-folder-uri + #:preview-widget + #:preview-widget-active + #:use-preview-label + #:extra-widget + #:filter + + #:file-filter + ;; file-filter methods + #:add-mime-type + #:add-pattern + #:add-pixbuf-formats + #:needed #:file-chooser-dialog @@ -720,6 +789,10 @@ #:progress-bar ;; progress-bar slots #:fraction + #:inverted + #:show-text + #:ellipsize + #:pulse-step #:table ;; table methods --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/progress-bar.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/progress-bar.lisp 2012/05/07 09:02:04 1.2 @@ -1,21 +1,28 @@ +;;; +;;; progress-bar.lisp -- GtkProgressBar +;;; +;;; Copyright (C) 2012, Roman Klochkov +;;; + (in-package :gtk-cffi) -(defclass progress-bar (widget) +(defclass progress-bar (widget orientable) ()) -(defcfun "gtk_progress_bar_new" :pointer) +(defcfun gtk-progress-bar-new :pointer) -(defmethod gconstructor ((progress-bar progress-bar) - &key &allow-other-keys) +(defmethod gconstructor ((progress-bar progress-bar) &key) (gtk-progress-bar-new)) -(defcfun "gtk_progress_bar_set_fraction" :void - (bar pobject) (fraction :double)) - -(defmethod (setf fraction) (fraction (progress-bar progress-bar)) - (gtk-progress-bar-set-fraction progress-bar (coerce fraction 'double-float))) - -(defcfun "gtk_progress_bar_get_fraction" :double (bar pobject)) +(defslots progress-bar + fraction :double + inverted :boolean + show-text :boolean + ellipsize pango-cffi:ellipsize-mode + pulse-step :double) + +(deffuns progress-bar + (:get text :string &key) + (:set text :string &key)) -(defmethod fraction ((progress-bar progress-bar)) - (gtk-progress-bar-get-fraction progress-bar)) +(init-slots progress-bar) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/table.lisp 2011/04/25 19:16:08 1.1.1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/table.lisp 2012/05/07 09:02:04 1.2 @@ -3,10 +3,8 @@ (defclass table (container) ()) -(defcfun "gtk_table_new" :pointer - (rows :uint) - (columns :uint) - (homogeneous :boolean)) +(defcfun gtk-table-new :pointer + (rows :uint) (columns :uint) (homogeneous :boolean)) (defmethod gconstructor ((table table) @@ -17,55 +15,74 @@ (defbitfield attach-options :expand :shrink :fill) -(defcfun "gtk_table_attach_defaults" :void +(defcfun gtk-table-attach-defaults :void (table pobject) (widget pobject) (left-attach :uint) (right-attach :uint) (top-attach :uint) (bottom-attach :uint)) -(defcfun "gtk_table_attach" :void +(defcfun gtk-table-attach :void (table pobject) (widget pobject) (left-attach :uint) (right-attach :uint) (top-attach :uint) (bottom-attach :uint) (xoptions attach-options) (yoptions attach-options) (xpadding :uint) (ypadding :uint)) -(defmethod attach ((table table) (widget widget) - &key (left 0) (right 1) (top 0) (bottom 1) - (xoptions :default) (yoptions :default) - (xpadding 0) (ypadding 0)) - (flet ((def (m) (if (eq m :default) '(:expand :fill) m))) - (if (and (eq xoptions :default) - (eq yoptions :default) +(defgeneric attach (table widget &key) + (:method ((table table) (widget widget) + &key (left 0) (right 1) (top 0) (bottom 1) + (xoptions '(:expand :fill) xoptions-p) + (yoptions '(:expand :fill) yoptions-p) + (xpadding 0) (ypadding 0)) + (if (and (null xoptions-p) + (null yoptions-p) (eq xpadding 0) (eq ypadding 0)) (gtk-table-attach-defaults table widget left right top bottom) (gtk-table-attach table widget left right top bottom - (def xoptions) (def yoptions) xpadding ypadding)))) + xoptions yoptions xpadding ypadding)))) -(defcfun "gtk_table_resize" :void +(defcfun gtk-table-get-size :void + (table pobject) (rows (:pointer :int)) (columns (:pointer :int))) + +(defgeneric table-size (table) + (:method ((table table)) + (with-foreign-outs-list ((rows :int) (columns :int)) :ignore + (gtk-table-get-size table rows columns)))) + +(defcfun gtk-table-resize :void (table pobject) (rows :uint) (columns :uint)) -(defmethod resize ((table table) &key (rows :default) (columns :default)) - (gtk-table-resize table - (if (eq rows :default) - (property table :n-rows) rows) - (if (eq columns :default) - (property table :n-columns) columns))) +(defgeneric (setf table-size) (new-size table) + (:method ((new-size list) (table table)) + (destructuring-bind (rows columns) new-size + (gtk-table-resize table rows columns)))) + +(defgeneric resize (table &key) + (:method ((table table) &key rows columns) + (unless (and rows columns) + (destructuring-bind (cur-rows cur-columns) (table-size table) + (unless rows (setf rows cur-rows)) + (unless columns (setf columns cur-columns)))) + (gtk-table-resize table rows columns))) (defmethod pack ((table table) (list list) &rest rest) "Table should have list of widgets to add" (declare (ignore rest)) - (let (;(cols (max (property table :n-columns) (length list))) - (rows (+ (property table :n-rows) 1))) - ;(resize table :rows rows :columns cols) - (let ((width 1)) - (loop - :for i :from 0 - :for widget :in list - :do (cond - ((numberp widget) (setf width widget) (incf i -1)) - ((not (null widget)) - (attach table widget - :left i :right (+ i width) - :top (- rows 1) :bottom rows))))))) + (let ((rows (+ (first (table-size table)) 1)) + (width 1)) + (loop + :for i :from 0 + :for widget :in list + :do (cond + ((numberp widget) (setf width widget) (incf i -1)) + ((not (null widget)) + (attach table widget + :left i :right (+ i width) + :top (- rows 1) :bottom rows)))))) + + + + + + --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/02/12 17:29:42 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/05/07 09:02:04 1.8 @@ -130,15 +130,17 @@ (defmethod free :before ((tree-model tree-model)) (free (tree-iter tree-model))) -(make-foreach tree-model +(make-foreach tree-model + (model pobject) (path (object tree-path)) - (tree-iter (object tree-iter))) + (tree-iter (object tree-iter)) + (data pdata)) (defcfun "gtk_tree_model_get_path" (object tree-path) (model pobject) (iter pobject)) (defmethod iter->path ((tree-model tree-model) (tree-iter tree-iter)) - (warn "Dangerous method: don't forget to use free") +; (warn "Dangerous method: don't forget to use free") (gtk-tree-model-get-path tree-model tree-iter)) (defcfun "gtk_tree_model_get_string_from_iter" :string --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/02/20 18:50:28 1.11 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/05/07 09:02:04 1.12 @@ -7,7 +7,7 @@ (in-package :gtk-cffi) -(defclass widget (g-object) +(defclass widget (g-object buildable) ((%style-properties :accessor %style-properties :initform nil :allocation :class))) @@ -162,7 +162,6 @@ hexpand-set :boolean vexpand :boolean vexpand-set :boolean - allocation (struct allocation) window pobject support-multidevice :boolean app-paintable :boolean) @@ -247,7 +246,16 @@ (queue-compute-expand :void) (compute-expand :boolean (orientation orientation)) (:set-last device-events event-mask (device pobject)) - (:set-last device-enabled :boolean (device pobject))) + (:set-last device-enabled :boolean (device pobject)) + (:set allocation (struct allocation))) + +(defcfun gtk-widget-get-allocation :void + (widget pobject) (allocation (struct allocation :out t))) + +(defmethod allocation ((widget widget)) + (let ((res (make-instance 'allocation))) + (gtk-widget-get-allocation widget res) + res)) (setf (documentation 'clipboard 'function) "SELECTION should be :PRIMARY or :CLIPOARD") @@ -258,21 +266,21 @@ (defcfun gtk-widget-get-pointer :void (widget pobject) (x :pointer) (y :pointer)) -(defgeneric get-pointer (widget)) -(defmethod get-pointer ((widget widget)) - (with-foreign-outs ((x :int) (y :int)) :ignore - (gtk-widget-get-pointer widget x y))) +(defgeneric get-pointer (widget) + (:method ((widget widget)) + (with-foreign-outs ((x :int) (y :int)) :ignore + (gtk-widget-get-pointer widget x y)))) (defcfun gtk-widget-translate-coordinates :boolean (src-widget pobject) (dst-widget pobject) (src-x :int) (src-y :int) (dst-x :pointer) (dst-y :pointer)) -(defmethod translate-coordinates ((src-widget widget) (dst-widget widget) - src-x src-y) - "Returns (values dst-x dst-y)" - (with-foreign-outs ((dst-x :int) (dst-y :int)) :if-success - (gtk-widget-translate-coordinates src-widget dst-widget - src-x src-y dst-x dst-y))) +(defgeneric translate-coordinates (src-widget dst-widget src-x src-y) + (:method ((src-widget widget) (dst-widget widget) src-x src-y) + "Returns (values dst-x dst-y)" + (with-foreign-outs ((dst-x :int) (dst-y :int)) :if-success + (gtk-widget-translate-coordinates src-widget dst-widget + src-x src-y dst-x dst-y)))) (defcfun gtk-cairo-should-draw-window :boolean (context :pointer) (gdk-window pobject)) @@ -291,11 +299,10 @@ (defcfun gtk-cairo-transform-to-window :void (context :pointer) (widget pobject) (gdk-window pobject)) -(defgeneric cairo-transform-to-window (widget window &optional context)) -(defmethod cairo-transform-to-window ((widget widget) window - &optional (context cl-cairo2:*context*)) - (cl-cairo2::with-context-pointer (context cntx-pointer) - (gtk-cairo-transform-to-window cntx-pointer widget window))) +(defgeneric cairo-transform-to-window (widget window &optional context) + (:method ((widget widget) window &optional (context cl-cairo2:*context*)) + (cl-cairo2::with-context-pointer (context cntx-pointer) + (gtk-cairo-transform-to-window cntx-pointer widget window)))) (defmethod cairo-transform-to-window ((widget widget) (window widget) &optional (context cl-cairo2:*context*)) @@ -351,13 +358,13 @@ (defcfun gtk-widget-get-preferred-size :void (widget pobject) (minimum :pointer) (natural :pointer)) -(defgeneric preferred-size (widget)) -(defmethod preferred-size ((widget widget)) - "Returns (values minimum natural). +(defgeneric preferred-size (widget) + (:method ((widget widget)) + "Returns (values minimum natural). Minimum and natural are requisition objects." - (with-foreign-outs ((minimum 'requisition) (natural 'requisition)) - :ignore - (gtk-widget-get-preferred-size widget minimum natural))) + (with-foreign-outs ((minimum 'requisition) (natural 'requisition)) + :ignore + (gtk-widget-get-preferred-size widget minimum natural)))) (defcstruct requested-size "GtkRequestedSize" @@ -372,8 +379,7 @@ "EXTRA-SPACE -- integer, extra space to redistribute among children. SIZES -- {(widget minimum-size natural-size)}*" (let ((length (length sizes))) - (let ((sizes-struct (foreign-alloc 'requested-size - :count length))) + (let ((sizes-struct (foreign-alloc 'requested-size :count length))) (iter (for i from 0 below length) (for x in sizes) @@ -385,9 +391,6 @@ natural-size (third x))))) (gtk-distribute-natural-allocation extra-space length sizes-struct)))) - -(init-slots widget) - (template (name with-type) ((color t) (font nil) (bg-pixmap nil)) @@ -401,7 +404,10 @@ &key ,@(when with-type '(type)) (state :normal)) (setf (,name (style-context widget) ,@(when with-type '(:type type)) :state state) - value)))) + value)) + (save-setter widget ,name))) + +(init-slots widget) (defclass widget-class (g-object-class) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/buildable.lisp 2012/05/07 09:02:05 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/buildable.lisp 2012/05/07 09:02:05 1.1 ;;; ;;; buildable.lisp -- GtkBuildable ;;; ;;; Copyright (C) 2012, Roman Klochkov ;;; (in-package :gtk-cffi) (defclass buildable (object) ()) (defslot buildable name :string)--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-filter.lisp 2012/05/07 09:02:05 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-filter.lisp 2012/05/07 09:02:05 1.1 (in-package :gtk-cffi) (defclass file-filter (g-object) ()) (defcfun gtk-file-filter-new :pointer) (defmethod gconstructor ((file-filter file-filter) &key) (gtk-file-filter-new)) (defslot file-filter name :string) (defbitfield filter-flags :filename :uri :display-name :mime-type) (deffuns file-filter (add-mime-type :void (mime-type :string)) (add-pattern :void (pattern :string)) (add-pixbuf-formats :void) (:get needed filter-flags)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/orientable.lisp 2012/05/07 09:02:05 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/orientable.lisp 2012/05/07 09:02:05 1.1 ;;; ;;; orientable.lisp -- GtkOrientable ;;; ;;; Copyright (C) 2012, Roman Klochkov ;;; (in-package :gtk-cffi) (defclass orientable (object) ()) (defcenum orientation :horizontal :vertical) (defslot orientable orientation orientation) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/range.lisp 2012/05/07 09:02:05 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/range.lisp 2012/05/07 09:02:05 1.1 (in-package :gtk-cffi) (defclass range (widget) ()) (defcenum sensitivity-type :auto :on :off) (defslots range fill-level :double restrict-to-fill-level :boolean show-fill-level :boolean adjustment pobject inverted :boolean value :double round-digits :int lower-stepper-sensitivity sensitivity-type upper-stepper-sensitivity sensitivity-type flippable :boolean min-slider-size :int slider-size-fixed :boolean) (defcfun gtk-range-set-increments :void (range pobject) (step :double) (page :double)) (defgeneric (setf increments) (increments range) (:method (increments (range range)) (destructuring-bind (step page) increments (gtk-range-set-increments range step page)) increments)) (defcfun gtk-range-set-range :void (range pobject) (min :double) (max :double)) (defgeneric (setf range) (min-max range) (:method (min-max (range range)) (destructuring-bind (min max) min-max (gtk-range-set-increments range min max)) min-max)) (defcfun gtk-range-get-slider-range :void (range pobject) (start :pointer) (end :pointer)) (defgeneric slider-range (range) (:method ((range range)) (with-foreign-outs-list ((start :int) (end :int)) :ignore (gtk-range-get-slider-range range start end)))) (defcfun gtk-range-get-range-rect :void (range pobject) (rect (struct rectangle :out t))) (defgeneric range-rect (rect) (:method ((range range)) (let ((dest (make-instance 'rectangle))) (gtk-range-get-range-rect range dest) dest))) From rklochkov at common-lisp.net Mon May 7 09:32:47 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 07 May 2012 02:32:47 -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-serv2732/examples Modified Files: ex6.lisp Log Message: Fixed examples/ex6 --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex6.lisp 2012/05/07 09:02:03 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex6.lisp 2012/05/07 09:32:46 1.4 @@ -40,17 +40,20 @@ (dest-x (- (width (allocation widget)) w)) (dest-y 0)) (format t "~a~%" pixbuf) - (unless (cffi:null-pointer-p (cffi-objects:pointer pixbuf)) (cl-cairo2:with-context ((make-instance 'cl-cairo2:context :pointer context)) - (cairo-set-source-pixbuf pixbuf dest-x dest-y) - (cl-cairo2:paint))) + (unless (cffi:null-pointer-p (cffi-objects:pointer pixbuf)) + (cairo-set-source-pixbuf pixbuf dest-x dest-y) + (cl-cairo2:paint)) + (let ((ch (child widget))) + (when ch (propagate-draw widget ch))))) + t) + ; (draw-pixbuf (gdk-window widget) ; (style-field widget :bg-gc) pixbuf 0 0 dest-x dest-y) ;(let ((ch (child widget))) ; (when ch ; (propagate- widget ch event))) - t)) (let ((eventbox-left (make-instance 'event-box)) From rklochkov at common-lisp.net Mon May 7 09:32:47 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 07 May 2012 02:32:47 -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-serv2732/gtk Modified Files: container.lisp package.lisp widget.lisp Log Message: Fixed examples/ex6 --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2011/08/26 17:16:14 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2012/05/07 09:32:47 1.3 @@ -36,11 +36,6 @@ (defmethod (setf kid) (kid (container container)) (pack container kid)) -(defcfun "gtk_widget_reparent" :void (widget pobject) (parent pobject)) - -(defmethod reparent ((widget widget) (new-parent container)) - (gtk-widget-reparent widget new-parent)) - (defmethod initialize-instance :after ((container container) &key kid kids &allow-other-keys) @@ -126,3 +121,10 @@ (defmethod container-remove ((container container) (widget widget)) (gtk-container-remove container widget)) +(defcfun gtk-container-propagate-draw + :void (container pobject) (child pobject) (context :pointer)) + +(defmethod propagate-draw ((container container) (widget widget) + &optional (context cl-cairo2:*context*)) + (gtk-container-propagate-draw container widget + (cl-cairo2::get-pointer context))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/05/07 09:02:04 1.18 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/05/07 09:32:47 1.19 @@ -190,9 +190,10 @@ #:container ;; container slots #:border-width + #:child-property ;; methods #:add - #:propagate-expose + #:propagate-draw #:window ;; window slots --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/05/07 09:02:04 1.12 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/05/07 09:32:47 1.13 @@ -180,6 +180,7 @@ ((widget-event . event) :boolean (event event)) (send-expose :int (event event)) (send-focus-change :boolean (event event)) + (reparent :void (new-parent pobject)) (is-focus :boolean) (grab-focus :void) (grab-default :void) From rklochkov at common-lisp.net Tue May 8 09:38:07 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Tue, 08 May 2012 02:38:07 -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-serv25361/examples Modified Files: ex7.lisp Log Message: Added GtkComboBoxText Changed GtkTextIter to struct implementation from cffi-objects --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex7.lisp 2012/05/07 09:02:03 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex7.lisp 2012/05/08 09:38:07 1.5 @@ -1,5 +1,4 @@ (asdf:oos 'asdf:load-op :gtk-cffi) -(declaim (optimize speed)) (defpackage #:ex7 (:use #:common-lisp #:gtk-cffi #:g-object-cffi)) (in-package #:ex7) From rklochkov at common-lisp.net Tue May 8 09:38:07 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Tue, 08 May 2012 02:38:07 -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-serv25361/ext Modified Files: lisp-model.lisp package.lisp Log Message: Added GtkComboBoxText Changed GtkTextIter to struct implementation from cffi-objects --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/lisp-model.lisp 2012/02/12 17:29:41 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/lisp-model.lisp 2012/05/08 09:38:07 1.4 @@ -88,8 +88,9 @@ (warn "Undefined implementation of GET-ITER for ~a" lisp-model-impl))) (defun set-iter (iter index) - (with-foreign-slots ((stamp u1) iter tree-iter-struct) - (setf stamp 0 u1 (make-pointer index))) +; (break) + (setf (stamp iter) 0 + (u1 iter) (make-pointer index)) t) (defmethod get-iter ((lisp-model-list lisp-model-list) iter path) @@ -110,7 +111,7 @@ (when found (set-iter iter index))))) (defun iter->index (iter) - (pointer-address (foreign-slot-value iter 'tree-iter-struct 'u1))) + (pointer-address (u1 iter))) (defun iter->aref (lisp-model iter) (aref (larray lisp-model) (iter->index iter))) @@ -176,7 +177,7 @@ (defgeneric iter-children (lisp-model-impl iter parent) (:method ((lisp-model-list lisp-model-list) iter parent) - (when (null-pointer-p parent) + (unless parent (set-iter iter 0))) (:method ((lisp-model lisp-model-tree-array) iter parent) (multiple-value-bind (found index) @@ -205,13 +206,12 @@ (defgeneric iter-nth-child (lisp-model-impl iter parent n) (:method ((lisp-model-list lisp-model-list) iter parent n) - (when (and (null-pointer-p parent) - (< n (lisp-model-length lisp-model-list))) + (when (and (null parent) (< n (lisp-model-length lisp-model-list))) (set-iter iter n))) (:method ((lisp-model lisp-model-tree-array) iter parent n) (multiple-value-bind (found index) (descend (tree lisp-model) - (if (null-pointer-p parent) + (if (null parent) (list n) (let ((r (iter->path-list lisp-model parent))) (append r (list n))))) @@ -267,19 +267,19 @@ get-flags (:int) get-n-columns (:int) get-column-type (:int (index :int)) - get-iter (:boolean (iter tree-iter-struct) (path :pointer)) - get-path (pobject (iter tree-iter-struct)) - get-value (:void (iter tree-iter-struct) (n :int) (value :pointer)) - iter-next (:boolean (iter tree-iter-struct)) - iter-previous (:boolean (iter tree-iter-struct)) - iter-children (:boolean (iter tree-iter-struct) (parent tree-iter-struct)) - iter-has-child (:boolean (iter tree-iter-struct)) - iter-n-children (:int (iter tree-iter-struct)) - iter-nth-child (:boolean (iter tree-iter-struct) - (parent tree-iter-struct) (n :int)) - iter-parent (:boolean (iter tree-iter-struct) (child tree-iter-struct)) - ref-node (:void (iter tree-iter-struct)) - unref-node (:void (iter tree-iter-struct))) + get-iter (:boolean (iter (struct tree-iter)) (path :pointer)) + get-path (pobject (iter (struct tree-iter))) + get-value (:void (iter (struct tree-iter)) (n :int) (value :pointer)) + iter-next (:boolean (iter (struct tree-iter))) + iter-previous (:boolean (iter (struct tree-iter))) + iter-children (:boolean (iter (struct tree-iter)) (parent (struct tree-iter))) + iter-has-child (:boolean (iter (struct tree-iter))) + iter-n-children (:int (iter (struct tree-iter))) + iter-nth-child (:boolean (iter (struct tree-iter)) + (parent (struct tree-iter)) (n :int)) + iter-parent (:boolean (iter (struct tree-iter)) (child (struct tree-iter))) + ref-node (:void (iter (struct tree-iter))) + unref-node (:void (iter (struct tree-iter)))) (defcstruct g-interface-info --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/package.lisp 2012/05/07 09:02:04 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/package.lisp 2012/05/08 09:38:07 1.4 @@ -6,7 +6,7 @@ #:gtk-cffi-utils #:gtk-cffi) (:shadowing-import-from #:gtk-cffi #:image #:window) (:import-from #:gtk-cffi - #:tree-iter-struct #:u1 #:stamp + #: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 @@ -15,9 +15,18 @@ (:export #:lisp-model #:implementation + #:lisp-model-list + #:lisp-model-tree #:lisp-model-array #:lisp-model-tree-array #:larray + + #:get-value + #:lisp-model-length + #:set-value + #:iter->index + #:iter->aref + #:with-progress #:set-progress)) From rklochkov at common-lisp.net Tue May 8 09:38:07 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Tue, 08 May 2012 02:38:07 -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-serv25361/gtk Modified Files: cell-layout.lisp cell-renderer.lisp combo-box.lisp gtk-cffi.asd package.lisp tree-model.lisp Added Files: combo-box-text.lisp Log Message: Added GtkComboBoxText Changed GtkTextIter to struct implementation from cffi-objects --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-layout.lisp 2012/03/06 01:25:26 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-layout.lisp 2012/05/08 09:38:07 1.4 @@ -24,7 +24,12 @@ (funcall (if end #'gtk-cell-layout-pack-end #'gtk-cell-layout-pack-start) - cell-layout cell-renderer expand)) + cell-layout cell-renderer expand) + (iter + (for (attr column) in (attributes cell-renderer)) + (add-attribute cell-layout cell-renderer + attr column))) + (defcfun "gtk_cell_layout_get_cells" g-list-object (cell-layout pobject)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-renderer.lisp 2011/08/26 17:16:14 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-renderer.lisp 2012/05/08 09:38:07 1.3 @@ -1,10 +1,8 @@ (in-package :gtk-cffi) (defclass cell-renderer (g-object) - ()) + ((attributes :initarg :attributes :reader attributes :initform nil))) (defcenum cell-renderer-mode :inert :activatable :editable) - - --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/combo-box.lisp 2012/05/07 09:02:04 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/combo-box.lisp 2012/05/08 09:38:07 1.3 @@ -1,6 +1,6 @@ (in-package :gtk-cffi) -(defclass combo-box (bin) +(defclass combo-box (bin cell-layout) ()) (defcfun gtk-combo-box-new :pointer) @@ -27,6 +27,7 @@ (gtk-combo-box-new))))) +;; separate declaration to avoid auto-adding to initargs (defcfun gtk-combo-box-set-model :void (combo-box pobject) (model pobject)) (defmethod (setf model) (tree-model (combo-box combo-box)) (gtk-combo-box-set-model combo-box tree-model)) @@ -36,7 +37,6 @@ row-span-column :int column-span-column :int active :int - active-iter pobject id-column :int add-tearoffs :boolean title :string @@ -76,6 +76,25 @@ (values active-id (gtk-combo-box-set-active-id combo-box active-id))) +(defcfun gtk-combo-box-set-active-iter + :void (combo-box pobject) (iter (struct tree-iter :free :none))) +(defcfun gtk-combo-box-get-active-iter + :boolean (combo-box pobject) (iter (struct tree-iter :out t))) + +(defgeneric (setf active-iter) (active-iter combo-box) + (:method (active-iter (combo-box combo-box)) + (gtk-combo-box-set-active-iter combo-box active-iter))) + +(defgeneric active-iter (combo-box) + (:method ((combo-box combo-box)) + (let ((res (make-instance 'tree-iter))) + (values res (gtk-combo-box-get-active-iter combo-box res))))) +(save-setter combo-box active-iter) + +(init-slots combo-box) + + + --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/05/07 09:02:04 1.18 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/05/08 09:38:07 1.19 @@ -336,7 +336,8 @@ :license "LLGPL" :depends-on (gtk-cffi-bin gtk-cffi-range) :components - ((:file combo-box))) + ((:file combo-box) + (:file combo-box-text))) (defsystem gtk-cffi-message-dialog :description "Interface to GTK/Glib via CFFI" --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/05/07 09:32:47 1.19 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/05/08 09:38:07 1.20 @@ -439,6 +439,7 @@ #:iter->path #:path->iter #:get-indices + #:tree->indices #:list-store ;; list-store methods @@ -724,6 +725,18 @@ #:active-id #:row-separator-func + #:combo-box-text + ;; methods + #:combo-box-insert + #:combo-box-prepend + #:combo-box-append + #:insert-text + #:append-text + #:prepend-text + #:active-text + #:combo-box-remove + #:remove-all + #:range ;; slots #:fill-level --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/05/07 09:02:04 1.8 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/05/08 09:38:07 1.9 @@ -40,7 +40,7 @@ :collect (mem-aref array :int i)))) (defmethod get-index ((tree-path tree-path) &optional (pos 0)) - (mem-aref (gtk-tree-path-get-indices (pointer tree-path)) :int pos)) + (mem-aref (gtk-tree-path-get-indices tree-path) :int pos)) (defclass tree-row (object) ()) @@ -63,32 +63,35 @@ (defmethod copy ((tree-row tree-row)) (gtk-tree-row-reference-copy tree-row)) -(defcstruct tree-iter-struct +(defcstruct* tree-iter "GtkTreeIter" (stamp :int) (u1 :pointer) (u2 :pointer) (u3 :pointer)) -(defclass tree-iter (object) - ()) +;(defclass tree-iter (object) +; ()) -(defmethod gconstructor ((tree-iter tree-iter) - &key &allow-other-keys) - (foreign-alloc 'tree-iter-struct)) - -(defmethod copy ((tree-iter tree-iter)) - (let* ((res (make-instance 'tree-iter)) - (ptr (pointer tree-iter)) - (new-ptr (pointer res))) - (mapc (lambda (x) - (setf (foreign-slot-value new-ptr 'tree-iter-struct x) - (foreign-slot-value ptr 'tree-iter-struct x))) - (foreign-slot-names 'tree-iter-struct)) - res)) +;(defmethod gconstructor ((tree-iter tree-iter) +; &key &allow-other-keys) +; (foreign-alloc 'tree-iter-struct)) + +;(defmethod copy ((tree-iter tree-iter)) +; (let* ((res (make-instance 'tree-iter)) +; (ptr (pointer tree-iter)) +; (new-ptr (pointer res))) +; (mapc (lambda (x) +; (setf (foreign-slot-value new-ptr 'tree-iter-struct x) +; (foreign-slot-value ptr 'tree-iter-struct x))) +; (foreign-slot-names 'tree-iter-struct)) +; res)) (defcfun "gtk_tree_iter_free" :void (iter pobject)) +(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)) @@ -125,7 +128,7 @@ (defmethod initialize-instance :after ((tree-model tree-model) &key &allow-other-keys) - (setf (tree-iter tree-model) (make-instance 'tree-iter))) + (setf (tree-iter tree-model) (make-instance 'tree-iter :new-struct t))) (defmethod free :before ((tree-model tree-model)) (free (tree-iter tree-model))) @@ -149,6 +152,14 @@ (defmethod iter->string ((tree-model tree-model) (tree-iter tree-iter)) (gtk-tree-model-get-string-from-iter tree-model tree-iter)) +(defgeneric tree->indices (tree-model tree-iter) + (:method ((tree-model tree-model) (tree-iter tree-iter)) + (let ((tree-path (iter->path tree-model tree-iter))) + (prog1 + (get-indices tree-path) + (free tree-path))))) + + (defcfun "gtk_tree_model_get_value" :void (model pobject) (iter pobject) (column :int) (g-value pobject)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/combo-box-text.lisp 2012/05/08 09:38:07 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/combo-box-text.lisp 2012/05/08 09:38:07 1.1 (in-package :gtk-cffi) (defclass combo-box-text (combo-box) ()) (defcfun gtk-combo-box-text-new-with-entry :pointer) (defcfun gtk-combo-box-text-new :pointer) (defmethod gconstructor ((combo-box-text combo-box-text) &key with-entry) (if with-entry (gtk-combo-box-text-new-with-entry) (gtk-combo-box-text-new))) (deffuns combo-box-text ((combo-box-append . append) :void (id :string) (text :string)) ((combo-box-insert . insert) :void (position :int) (id :string) (text :string)) ((combo-box-prepend . prepend) :void (id :string) (text :string)) (append-text :void (text :string)) (insert-text :void (position :int) (text :string)) (prepend-text :void (text :string)) ((combo-box-remove . remove) :void (position :int)) (remove-all :void) (:get active-text :string)) From rklochkov at common-lisp.net Sun May 13 16:20:07 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 13 May 2012 09:20:07 -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-serv17217/gtk Modified Files: statusbar.lisp text-buffer.lisp widget.lisp Log Message: Fixed GtkTextIter (now with cffi-objects struct) Fixed context in GtkStatus (let it be symbol) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/statusbar.lisp 2012/03/08 09:58:12 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/statusbar.lisp 2012/05/13 16:20:07 1.6 @@ -11,7 +11,7 @@ (defgtkfuns statusbar ((statusbar-push . push) :uint (context-id :uint) (text :string)) ((statusbar-pop . pop) :void (context-id :uint)) - (:get context-id :uint (context :string)) + (:get context-id :uint (context pstring)) (:get message-area pobject)) (defcfun gtk-statusbar-remove :void --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/text-buffer.lisp 2012/03/08 09:58:12 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/text-buffer.lisp 2012/05/13 16:20:07 1.8 @@ -17,10 +17,7 @@ (make-foreach text-tag-table (tag (object text-tag)) (data pdata)) -(defclass text-iter (struct) - ()) - -(defcstruct text-iter +(defcstruct* text-iter (u1 :pointer) (u2 :pointer) (u3 :int) @@ -222,7 +219,7 @@ (gtk-text-buffer-deserialize-set-can-create-tags text-buffer format value))) (defcfun gtk-text-buffer-get-start-iter :void - (buffer pobject) (text-iter pobject)) + (buffer pobject) (text-iter (struct text-iter :out t))) (defgeneric start-iter (text-buffer &optional text-iter) (:method ((text-buffer text-buffer) @@ -231,7 +228,7 @@ text-iter)) (defcfun gtk-text-buffer-get-end-iter :void - (buffer pobject) (text-iter pobject)) + (buffer pobject) (text-iter (struct text-iter :out t))) (defgeneric end-iter (text-buffer &optional text-iter) (:method ((text-buffer text-buffer) @@ -245,6 +242,7 @@ (defmethod text ((text-buffer text-buffer) &key (start (start-iter text-buffer)) (end (end-iter text-buffer)) include-hidden) +; (format t "got text (~a ~a ~a)~%" text-buffer start end) (gtk-text-buffer-get-text text-buffer start end include-hidden)) (defcfun gtk-text-buffer-set-text :void (buffer pobject) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/05/07 09:32:47 1.13 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/05/13 16:20:07 1.14 @@ -17,8 +17,10 @@ &key type &allow-other-keys) (gtk-widget-new type (null-pointer))) -(defclass requisition (struct) - ()) +(defcstruct* requisition + "GtkRequisition" + (width :int) + (height :int)) (defcfun gtk-requisition-new :pointer) @@ -30,23 +32,12 @@ (defmethod free-struct ((class (eql 'requisition)) value) (gtk-requisition-free value)) -(defcstruct* requisition - "GtkRequisition" - (width :int) - (height :int)) - -(init-slots requisition) - -(defclass allocation (struct) - ()) (defcstruct* allocation "GtkAllocation" (x :int) (y :int) (width :int) (height :int)) -(init-slots allocation) - (defcfun gtk-widget-show :boolean (widget pobject)) (defcfun gtk-widget-show-all :boolean (widget pobject)) From rklochkov at common-lisp.net Sun May 13 16:20:49 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sun, 13 May 2012 09:20:49 -0700 Subject: [gtk-cffi-cvs] CVS cl-emacs Message-ID: Update of /project/gtk-cffi/cvsroot/cl-emacs In directory tiger.common-lisp.net:/tmp/cvs-serv17406 Modified Files: keymap.lisp main.lisp package.lisp Log Message: Minor fixes --- /project/gtk-cffi/cvsroot/cl-emacs/keymap.lisp 2011/09/15 10:43:25 1.1.1.1 +++ /project/gtk-cffi/cvsroot/cl-emacs/keymap.lisp 2012/05/13 16:20:49 1.2 @@ -3,8 +3,14 @@ (defparameter *entered-sequence* nil) (defvar *global-keymap* nil) +(let (keymap) + (defun gdk-keymap () + (unless keymap + (setf keymap (make-instance 'keymap))) + keymap)) + (defun base-keycode (key) - (let ((keys (entries-for-keyval (make-instance 'keymap) key))) + (let ((keys (entries-for-keyval (gdk-keymap) key))) (unless keys (warn "No keycode. Bad key description ~a" key) (return-from base-keycode nil)) @@ -17,7 +23,7 @@ (defun base-keyval (keycode) (multiple-value-bind (keys keyvals) - (entries-for-keycode (make-instance 'keymap) keycode) + (entries-for-keycode (gdk-keymap) keycode) (iter (for key in-vector keys) (for keyval in-vector keyvals) --- /project/gtk-cffi/cvsroot/cl-emacs/main.lisp 2011/09/15 17:21:22 1.2 +++ /project/gtk-cffi/cvsroot/cl-emacs/main.lisp 2012/05/13 16:20:49 1.3 @@ -1,8 +1,6 @@ ;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: emacs; -*- (in-package :emacs) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (gtk-init)) +(declaim (optimize safety debug)) (defvar *file*) (defvar *region*) @@ -24,13 +22,14 @@ (setf *entered-sequence* nil) (setf ret t)) - (let* ((statusbar (object-by-id :status)) - (context-id (context-id statusbar :key-seq))) - (if *entered-sequence* - (statusbar-push statusbar context-id - (keyseq->string *entered-sequence*)) - (statusbar-remove statusbar context-id)) - ret))) + (let ((statusbar (object-by-id :status))) + (when statusbar + (let ((context-id (context-id statusbar :key-seq))) + (if *entered-sequence* + (statusbar-push statusbar context-id + (keyseq->string *entered-sequence*)) + (statusbar-remove statusbar context-id))))) + ret)) (defun trap-error-handler (condition buf) (with-output-to-string (s buf) @@ -40,6 +39,7 @@ (defun run-if-paired-parens () (let ((text (text (buffer (object-by-id :command)))) (parens 0)) +; (format t "~a~%" text) (iter (for c in-string text) (case c @@ -47,8 +47,7 @@ (#\) (progn (incf parens -1) (when (< parens 0) (return-from run-if-paired-parens nil)))))) - (when (eql parens 0) - + (when (eql parens 0) (let ((repl (text (buffer (object-by-id :repl)))) (buf (make-array '(0) :element-type 'base-char :fill-pointer 0 :adjustable t))) @@ -61,7 +60,9 @@ (with-output-to-string (s buf) (format s "* ~a~%" condition)) (muffle-warning condition)))) - (format s "~a~%" (eval (read-from-string text)))) + (let ((res (eval (read-from-string text)))) + (setf *** ** ** * * res) + (format s "~a~%" res))) (t (var) (trap-error-handler var buf)))) (setf (text (buffer (object-by-id :repl))) buf)) (setf (text (buffer (object-by-id :command))) "")) @@ -128,48 +129,51 @@ (format nil "Saved ~a @ ~a" *file* *encoding*)))) -(global-set-key "C-x C-f" 'open-file) -(global-set-key "C-x C-c" (lambda () (destroy (object-by-id :main)))) -(global-set-key "C-x C-s" 'save-file) (defmacro act (&body body) `(lambda (&rest rest) (declare (ignore rest)) , at body)) -(show - (gtk-model - 'window :signals '(:destroy :gtk-main-quit - :key-press-event on-key-press) - :width 800 :height 600 :title "Editor" :id :main - ('v-box - :expand nil - ('menu-bar - ('menu-item - :label "File" - :submenu - (gtk-model - 'menu - ('menu-item :label "Open" - :signals `(:activate ,(act (open-file)))) - ('menu-item :label "Save" - :signals `(:activate ,(act (save-file)))) - ('menu-item :label "Quit" - :signals `(:activate - ,(act (destroy (object-by-id :main)))))))) - :expand t - ('h-paned - :resize t - ('scrolled-window - ('text-view :id :text)) - ('v-paned - ('scrolled-window :min-content-height 100 - ('text-view :id :command - :signals '(:key-press-event on-command-key-press))) - ('scrolled-window - ('text-view :id :repl)))) - :expand nil - ('statusbar :id :status)))) -(gtk-main) +(defun run-emacs () + (gtk-init) + (global-set-key "C-x C-f" 'open-file) + (global-set-key "C-x C-c" (lambda () (destroy (object-by-id :main)))) + (global-set-key "C-x C-s" 'save-file) + (show + (gtk-model + 'window :signals '(:destroy :gtk-main-quit + :key-press-event on-key-press) + :width 800 :height 600 :title "Editor" :id :main + ('v-box + :expand nil + ('menu-bar + ('menu-item + :label "File" + :submenu + (gtk-model + 'menu + ('menu-item :label "Open" + :signals `(:activate ,(act (open-file)))) + ('menu-item :label "Save" + :signals `(:activate ,(act (save-file)))) + ('menu-item :label "Quit" + :signals `(:activate + ,(act (destroy (object-by-id :main)))))))) + :expand t + ('h-paned + :resize t + ('scrolled-window + ('text-view :id :text)) + ('v-paned + ('scrolled-window + :min-content-height 100 + ('text-view :id :command + :signals '(:key-press-event on-command-key-press))) + ('scrolled-window + ('text-view :id :repl)))) + :expand nil + ('statusbar :id :status)))) + (gtk-main)) --- /project/gtk-cffi/cvsroot/cl-emacs/package.lisp 2011/09/15 10:43:25 1.1.1.1 +++ /project/gtk-cffi/cvsroot/cl-emacs/package.lisp 2012/05/13 16:20:49 1.2 @@ -1,4 +1,5 @@ ;; -*- Mode: LISP; Syntax: COMMON-LISP; -*- (defpackage :emacs (:use :cl :gtk-cffi :gdk-cffi :alexandria :iterate) - (:shadowing-import-from :gtk-cffi #:window #:image)) \ No newline at end of file + (:shadowing-import-from :gtk-cffi #:window #:image) + (:export #:run-emacs))