[gtk-cffi-cvs] CVS gtk-cffi/gtk
CVS User rklochkov
rklochkov at common-lisp.net
Fri Aug 26 17:16:14 UTC 2011
Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk
In directory tiger.common-lisp.net:/tmp/cvs-serv16215/gtk
Modified Files:
accel-group.lisp cell-renderer.lisp common.lisp container.lisp
dialog.lisp entry.lisp file-chooser-button.lisp
file-chooser-dialog.lisp generics.lisp gtk-cffi.asd icon.lisp
lisp-model.lisp list-store.lisp loadlib.lisp package.lisp
paned.lisp tree-model-filter.lisp tree-model.lisp widget.lisp
window.lisp
Added Files:
css-provider.lisp enums.lisp expander.lisp style-context.lisp
style-provider.lisp widget-path.lisp
Removed Files:
gtk-object.lisp
Log Message:
Added GTK3 support. Dropped GTK2 support.
Refactored CFFI layer.
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/accel-group.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/accel-group.lisp 2011/08/26 17:16:14 1.2
@@ -10,8 +10,26 @@
(defclass accel-group (object)
())
+(defbitfield accel-flags
+ :visible :locked)
+
(defcfun "gtk_accel_group_new" :pointer)
(defmethod gconstructor ((accel-group accel-group) &key &allow-other-keys)
(gtk-accel-group-new))
+(defcfun gtk-accel-group-connect :void
+ (accel-group pobject) (accel-key :uint) (accel-mods modifier-type)
+ (accel-flags accel-flags) (closure :pointer))
+
+(defcfun gtk-accel-group-connect-by-path :void
+ (accel-group pobject) (accel-path :string) (closure :pointer))
+
+(defmethod connect ((accel-group accel-group) func
+ &key path key accel-mods accel-flags)
+ "FUNC should have args: (accel_group acceleratable, keyval, modifier)"
+ (let ((closure (g-object-cffi::make-closure func)))
+ (if path
+ (gtk-accel-group-connect-by-path accel-group path closure)
+ (gtk-accel-group-connect accel-group
+ key accel-mods accel-flags closure))))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-renderer.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-renderer.lisp 2011/08/26 17:16:14 1.2
@@ -1,6 +1,6 @@
(in-package :gtk-cffi)
-(defclass cell-renderer (gtk-object)
+(defclass cell-renderer (g-object)
())
(defcenum cell-renderer-mode
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/common.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/common.lisp 2011/08/26 17:16:14 1.2
@@ -11,9 +11,11 @@
(defun gtk-init ()
;(load-gtk)
+ #+sbcl (sb-ext::set-floating-point-modes :traps nil)
(with-foreign-objects ((argc :int) (argv :pointer))
- (setf (mem-ref argc :int) 0 )
- (setf (mem-ref argv :pointer) (null-pointer))
+ (setf (mem-ref argc :int) 0
+ (mem-ref argv :pointer) (foreign-alloc :string
+ :initial-element "program"))
(%gtk-init argc argv)))
(defcfun "gtk_main" :void)
@@ -99,27 +101,3 @@
(process body))))
-(defmacro defgtkslot (current-class slot-name slot-type)
- (let ((getter (intern (format nil "GTK-~a-GET-~a" current-class slot-name)))
- (setter (intern (format nil "GTK-~a-SET-~a" current-class slot-name))))
- `(progn
- (defcfun ,getter ,slot-type (object pobject))
- (defcfun ,setter :void (widget pobject) (value ,slot-type))
- (unless (fboundp ',slot-name)
- (defgeneric ,slot-name (,current-class)))
- (unless (fboundp '(setf ,slot-name))
- (defgeneric (setf ,slot-name) (value ,current-class)))
- (defmethod ,slot-name ((object ,current-class)) (,getter object))
- (defmethod (setf ,slot-name) (value (object ,current-class))
- (,setter object value)))))
-
-(defmacro defgtkslots (current-class &rest slots)
- `(progn
- ,@(loop :for x :on slots :by #'cddr
- :collecting `(defgtkslot ,current-class ,(first x) ,(second x)))))
-
-(defun find-key (key seq)
- (when seq
- (if (eq key (car seq)) (list (car seq) (cadr seq))
- (find-key key (cddr seq)))))
-
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2011/08/26 17:16:14 1.2
@@ -9,11 +9,12 @@
(defcfun "gtk_container_add" :void (container pobject) (widget pobject))
-(defcfun "gtk_container_set_border_width" :void
- (container pobject) (width :uint))
-
-(defcfun "gtk_container_get_border_width" :uint
- (container pobject))
+(defgtkslots container
+ border-width :uint
+ resize-mode resize-mode
+ focus-child pobject
+ focus-vadjustment pobject
+ focus-hadjustment pobject)
(defmethod add ((container container) (widget widget))
(gtk-container-add container widget))
@@ -23,12 +24,11 @@
(add container widget))
(defmacro pack* (box &rest widgets)
- (cons 'progn
- (mapcar
- (lambda (widget) (if (and widget (listp widget))
- `(pack ,box , at widget)
- `(pack ,box ,widget)))
- widgets)))
+ `(progn
+ ,@(mapcar
+ (lambda (widget)
+ `(pack ,box ,@(ensure-cons widget)))
+ widgets)))
(defmethod (setf kids) (kids (container container))
(mapc (lambda (x) (setf (kid container) x)) kids))
@@ -36,24 +36,11 @@
(defmethod (setf kid) (kid (container container))
(pack container kid))
-(defmethod (setf border-width) (width (container container))
- (gtk-container-set-border-width (pointer container) width))
-
-(defmethod border-width ((container container))
- (gtk-container-get-border-width (pointer container)))
-
(defcfun "gtk_widget_reparent" :void (widget pobject) (parent pobject))
(defmethod reparent ((widget widget) (new-parent container))
(gtk-widget-reparent widget new-parent))
-(defcfun "gtk_container_propagate_expose" :void (container pobject)
- (child pobject) (event pobject))
-
-(defmethod propagate-expose ((container container) (child widget)
- (event event))
- (gtk-container-propagate-expose container child event))
-
(defmethod initialize-instance
:after ((container container)
&key kid kids &allow-other-keys)
@@ -62,9 +49,9 @@
(defmacro pack-with-param (container token cur-param keyword-list)
"Handle to let user set (pack* box widget1 :expand t widget2 widget3)
Here, widget2 and widget3 will be packed with expand."
- `(if (find ,token ,keyword-list) ;'(:pack-fill :padding :expand))
+ `(if (member ,token ,keyword-list) ;'(:pack-fill :padding :expand))
(setf (slot-value ,container ',cur-param)
- (intern (string ,token) :gtk-cffi))
+ (intern (string ,token) #.*package*))
(let ((param (slot-value ,container ',cur-param)))
(when param
(setf (slot-value ,container param) ,token)))))
@@ -118,7 +105,8 @@
(let ((skey (string-downcase key)))
(with-g-value (:value value
:g-type (child-property-type parent skey))
- (gtk-container-child-set-property parent widget skey *g-value*))))
+ (gtk-container-child-set-property parent widget
+ skey *g-value*))))
keys (if (listp values) values (list values))))
(defmethod (setf child-property) (values (widget widget) (parent null)
@@ -131,4 +119,10 @@
(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:gparam-spec :pointer ptr))))
+ (make-instance 'g-object-cffi:g-param-spec :pointer ptr))))
+
+(defcfun gtk-container-remove :void (container pobject) (widget pobject))
+
+(defmethod container-remove ((container container) (widget widget))
+ (gtk-container-remove container widget))
+
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/dialog.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/dialog.lisp 2011/08/26 17:16:14 1.2
@@ -1,8 +1,7 @@
(in-package :gtk-cffi)
(defclass dialog (window)
- ((v-box :accessor v-box)
- (action-area :accessor action-area)))
+ ())
(defbitfield dialog-flags
:modal
@@ -19,11 +18,6 @@
(defcfun "gtk_dialog_new" :pointer)
-(defcstruct dialog
- ""
- (v-box :pointer :offset 148)
- (action-area :pointer))
-
(defmethod gconstructor ((dialog dialog)
&key title parent (flags 0) &allow-other-keys)
(if title
@@ -32,22 +26,13 @@
(defmethod initialize-instance
:after ((dialog dialog)
- &key with-buttons &allow-other-keys)
-
+ &key with-buttons &allow-other-keys)
(mapcar
(lambda (x)
(destructuring-bind (str resp) x
(add-button dialog str resp)))
- with-buttons)
+ with-buttons))
- (setf (v-box dialog)
- (make-instance 'v-box
- :pointer (foreign-slot-value
- (pointer dialog) 'dialog 'v-box))
- (action-area dialog)
- (make-instance 'h-button-box
- :pointer (foreign-slot-value
- (pointer dialog) 'dialog 'action-area))))
(defcfun "gtk_dialog_run" dialog-response (dialog :pointer))
@@ -57,19 +42,72 @@
(destroy dialog))
resp))
-(defcfun "gtk_dialog_set_has_separator" :void (dialog :pointer) (has :boolean))
-
-(defmethod (setf has-separator) (has (dialog dialog))
- (gtk-dialog-set-has-separator (pointer dialog) has))
-
-(defcfun "gtk_dialog_get_has_separator" :boolean (dialog :pointer))
-
-(defmethod has-separator ((dialog dialog))
- (gtk-dialog-get-has-separator (pointer dialog)))
-
(defcfun "gtk_dialog_add_button" pobject (dialog pobject)
(str gtk-string) (resp dialog-response))
(defmethod add-button ((dialog dialog) str response)
(gtk-dialog-add-button dialog (if (keywordp str) (string-downcase str) str)
- response))
\ No newline at end of file
+ response))
+
+(defcfun gtk-dialog-response :void (dialog pobject) (resp dialog-response))
+
+(defmethod response ((dialog dialog) response)
+ (gtk-dialog-response dialog response))
+
+(defcfun gtk-dialog-add-action-widget
+ :void (dialog pobject) (child pobject) (resp dialog-response))
+
+(defmethod add-action-widget ((dialog dialog) (child widget) response)
+ (gtk-dialog-add-action-widget dialog child response))
+
+(defcfun gtk-dialog-set-default-response
+ :void (dialog pobject) (resp dialog-response))
+
+(defmethod (setf default-response) (response (dialog dialog))
+ (gtk-dialog-set-default-response dialog response))
+
+(defcfun gtk-dialog-set-response-sensitive
+ :void (dialog pobject) (resp dialog-response) (setting :boolean))
+
+(defmethod (setf response-sensitive) (setting (dialog dialog) response)
+ (gtk-dialog-set-response-sensitive dialog response setting))
+
+(defcfun gtk-dialog-get-response-for-widget
+ dialog-response (dialog pobject) (widget pobject))
+
+(defmethod response-for-widget ((dialog dialog) (widget widget))
+ (gtk-dialog-get-response-for-widget dialog widget))
+
+(defcfun gtk-dialog-get-widget-for-response
+ pobject (dialog pobject) (response dialog-response))
+
+(defmethod widget-for-response ((dialog dialog) response)
+ (gtk-dialog-get-widget-for-response dialog response))
+
+(defcfun gtk-dialog-get-action-area pobject (dialog pobject))
+
+(defmethod action-area ((dialog dialog))
+ (gtk-dialog-get-action-area dialog))
+
+(defcfun gtk-dialog-get-content-area pobject (dialog pobject))
+
+(defmethod content-area ((dialog dialog))
+ (gtk-dialog-get-content-area dialog))
+
+(defcfun gtk-alternative-dialog-button-order :boolean (screen pobject))
+
+(defmethod alternative-dialog-button-order ((screen screen))
+ (gtk-alternative-dialog-button-order screen))
+
+(defcfun gtk-dialog-set-alternative-button-order-from-array
+ :void (dialog pobject) (n-params :int) (new-order :pointer))
+
+(defmethod (setf alternative-button-order) (order (dialog dialog))
+ (let ((n-params (length order)))
+ (with-foreign-object (arr :int n-params)
+ (loop
+ :for i :from 0 :to n-params
+ :for l :in order
+ :do (setf (mem-aref arr :int i) l))
+ (gtk-dialog-set-alternative-button-order-from-array dialog
+ n-params arr))))
\ No newline at end of file
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/entry.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/entry.lisp 2011/08/26 17:16:14 1.2
@@ -12,13 +12,11 @@
(defcfun "gtk_entry_new" :pointer)
-(defcfun "gtk_entry_new_with_max_length" :pointer (max :int))
+;(defcfun "gtk_entry_new_with_max_length" :pointer (max :int))
(defmethod gconstructor ((entry entry)
- &key max-length &allow-other-keys)
- (if max-length
- (gtk-entry-new-with-max-length (round max-length))
- (gtk-entry-new)))
+ &key &allow-other-keys)
+ (gtk-entry-new))
(defcfun gtk-entry-get-text gtk-string (entry pobject))
(defcfun gtk-entry-set-text :void (entry pobject) (text gtk-string))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser-button.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser-button.lisp 2011/08/26 17:16:14 1.2
@@ -6,14 +6,9 @@
(defcfun "gtk_file_chooser_button_new" :pointer
(title gtk-string) (action file-chooser-action))
-(defcfun "gtk_file_chooser_button_new_with_backend" :pointer
- (title gtk-string) (action file-chooser-action) (backend gtk-string))
+;(defcfun "gtk_file_chooser_button_new_with_backend" :pointer
+; (title gtk-string) (action file-chooser-action) (backend gtk-string))
(defmethod gconstructor ((file-chooser-button file-chooser-button)
- &key title action backend &allow-other-keys)
- (apply
- (if backend #'gtk-file-chooser-button-new-with-backend
- #'gtk-file-chooser-button-new)
- (append
- (list title action)
- (when backend (list backend)))))
+ &key title action &allow-other-keys)
+ (gtk-file-chooser-button-new title action))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser-dialog.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/file-chooser-dialog.lisp 2011/08/26 17:16:14 1.2
@@ -9,23 +9,19 @@
(but2-text gtk-string) (but2-response dialog-response)
(null :pointer))
-(defcfun "gtk_file_chooser_dialog_new_with_backend" :pointer
- (title gtk-string) (parent pobject) (action file-chooser-action)
- (backend gtk-string)
- (but1-text gtk-string) (but1-response dialog-response)
- (but2-text gtk-string) (but2-response dialog-response)
- (null :pointer))
+;; (defcfun "gtk_file_chooser_dialog_new_with_backend" :pointer
+;; (title gtk-string) (parent pobject) (action file-chooser-action)
+;; (backend gtk-string)
+;; (but1-text gtk-string) (but1-response dialog-response)
+;; (but2-text gtk-string) (but2-response dialog-response)
+;; (null :pointer))
(defmethod gconstructor ((file-chooser-dialog file-chooser-dialog)
- &key title parent action backend &allow-other-keys)
- (apply
- (if backend #'gtk-file-chooser-dialog-new-with-backend
- #'gtk-file-chooser-dialog-new)
- (append
- (list title parent action)
- (when backend (list backend))
- (list "gtk-cancel" :cancel
- (case action
- ((:open :select-folder) "gtk-open")
- ((:save :create-folder) "gtk-save")) :accept (null-pointer)))))
+ &key title parent action &allow-other-keys)
+ (gtk-file-chooser-dialog-new
+ title parent action
+ "gtk-cancel" :cancel
+ (case action
+ ((:open :select-folder) "gtk-open")
+ ((:save :create-folder) "gtk-save")) :accept (null-pointer)))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/generics.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/generics.lisp 2011/08/26 17:16:14 1.2
@@ -13,16 +13,16 @@
(defgeneric (setf size-request) (size widget))
(defgeneric style-field (widget field &optional state type))
(defgeneric (setf style-field) (value widget field &optional state type))
-(defgeneric color (widget &optional field state))
-(defgeneric (setf color) (color widget &optional field state))
-(defgeneric font (widget))
-(defgeneric (setf font) (font widget))
-(defgeneric bg-pixmap (widget &optional state))
-(defgeneric (setf bg-pixmap) (pixmap widget &optional state))
+(defgeneric color (widget &rest rest))
+(defgeneric (setf color) (color widget &rest rest))
+(defgeneric font (widget &rest rest))
+(defgeneric (setf font) (font widget &rest rest))
+(defgeneric bg-pixmap (widget &rest state))
+(defgeneric (setf bg-pixmap) (pixmap widget &rest rest))
(defgeneric allocation (widget))
(defgeneric (setf allocation) (value widget))
(defgeneric show (widget &rest flags))
-(defgeneric hide (widget &rest flags))
+(defgeneric hide (widget))
(defgeneric gdk-window (widget))
(defgeneric (setf justify) (justify label))
(defgeneric justify (label))
@@ -48,7 +48,7 @@
(defgeneric has-separator (dialog))
(defgeneric add-button (dialog string response))
-(defgeneric get-iter (text-buffer text-iter pos))
+;(defgeneric get-iter (text-buffer text-iter pos))
(defgeneric buffer (text-view))
(defgeneric (setf buffer) (buffer text-view))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/08/08 15:02:02 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/08/26 17:16:14 1.3
@@ -14,14 +14,19 @@
:author "Roman Klochkov <kalimehtar at mail.ru>"
:version "0.5"
:license "GPL"
- :depends-on (gdk-cffi g-object-cffi g-lib-cffi)
+ :depends-on (gdk-cffi g-object-cffi g-lib-cffi gtk-cffi-utils)
:components
- ((:file :package)
- (:file :loadlib :depends-on (:package))
- (:file :generics :depends-on (:package))
- (:file :common :depends-on (:loadlib :generics))
- (:file :gtk-object :depends-on (:loadlib))
- (:file :pango :depends-on (:loadlib))))
+ ((:file package)
+ (:file enums :depends-on (package))
+ (:file loadlib :depends-on (package))
+ (:file generics :depends-on (package))
+ (:file common :depends-on (loadlib generics))
+ (:file pango :depends-on (loadlib))
+ (:file accel-group :depends-on (loadlib))
+ (:file style-context :depends-on (loadlib enums icon css-provider))
+ (:file style-provider :depends-on (loadlib))
+ (:file css-provider :depends-on (style-provider))
+ (:file icon :depends-on (loadlib enums))))
(defsystem gtk-cffi-widget
:description "Interface to GTK/Glib via CFFI"
@@ -30,7 +35,7 @@
:license "GPL"
:depends-on (gtk-cffi-core)
:components
- ((:file :widget)))
+ ((:file widget)))
(defsystem gtk-cffi-misc
:description "Interface to GTK/Glib via CFFI"
@@ -39,7 +44,7 @@
:license "GPL"
:depends-on (gtk-cffi-widget)
:components
- ((:file :misc)))
+ ((:file misc)))
(defsystem gtk-cffi-label
:description "Interface to GTK/Glib via CFFI"
@@ -48,7 +53,7 @@
:license "GPL"
:depends-on (gtk-cffi-misc)
:components
- ((:file :label)))
+ ((:file label)))
(defsystem gtk-cffi-container
:description "Interface to GTK/Glib via CFFI"
@@ -57,7 +62,7 @@
:license "GPL"
:depends-on (gtk-cffi-widget)
:components
- ((:file :container)))
+ ((:file container)))
(defsystem gtk-cffi-bin
:description "Interface to GTK/Glib via CFFI: GtkBin"
@@ -66,7 +71,8 @@
:license "GPL"
:depends-on (gtk-cffi-container)
:components
- ((:file :bin)))
+ ((:file bin)
+ (:file expander :depends-on (bin))))
(defsystem gtk-cffi-window
:description "Interface to GTK/Glib via CFFI"
@@ -80,7 +86,7 @@
(defsystem gtk-cffi-dialog
:description "Interface to GTK/Glib via CFFI"
:author "Roman Klochkov <kalimehtar at mail.ru>"
- :version "0.1"
+ :version "0.99"
:license "GPL"
:depends-on (gtk-cffi-window gtk-cffi-vbox gtk-cffi-hbuttonbox)
:components
@@ -429,21 +435,12 @@
:components
((:file :statusbar)))
-(defsystem gtk-cffi-icon
- :description "Interface to GTK/Glib via CFFI"
- :author "Roman Klochkov <kalimehtar at mail.ru>"
- :version "0.1"
- :license "GPL"
- :depends-on (gtk-cffi-widget)
- :components
- ((:file :icon)))
-
(defsystem gtk-cffi-image
:description "Interface to GTK/Glib via CFFI"
:author "Roman Klochkov <kalimehtar at mail.ru>"
:version "0.1"
:license "GPL"
- :depends-on (gtk-cffi-icon)
+ :depends-on (gtk-cffi-misc)
:components
((:file :image)))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/icon.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/icon.lisp 2011/08/26 17:16:14 1.2
@@ -9,6 +9,9 @@
:dnd
:dialog)
+(defcenum state
+ :normal :active :prelight :selected :insensitive :inconsistent :focused)
+
(defclass icon-source (object) ())
(defcfun "gtk_icon_source_new" :pointer)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/lisp-model.lisp 2011/08/08 15:02:02 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/lisp-model.lisp 2011/08/26 17:16:14 1.3
@@ -15,11 +15,11 @@
(defgeneric get-n-columns (lisp-model-impl)
(:method ((lisp-model-list lisp-model-list))
- 1))
+ (length (columns lisp-model-list))))
(defgeneric get-column-type (lisp-model-impl index)
(:method ((lisp-model-impl lisp-model-impl) index)
- (name->g-type (nth index (columns lisp-model-impl)))))
+ (keyword->g-type (nth index (columns lisp-model-impl)))))
(defgeneric lisp-model-length (lisp-model-list)
(:method ((lisp-model-array lisp-model-array))
@@ -41,7 +41,7 @@
(defgeneric get-value (lisp-model-impl iter n value)
(:method ((lisp-model-array lisp-model-array) iter n value)
- (debug-out "get-value~%")
+ ;(debug-out "get-value~%")
(let* ((index (pointer-address (foreign-slot-value
iter 'tree-iter-struct 'u1)))
(lval (nth n (aref (larray lisp-model-array) index))))
@@ -56,6 +56,15 @@
(setf (foreign-slot-value iter 'tree-iter-struct 'u1)
(make-pointer (1+ index)))))))
+(defgeneric iter-previous (lisp-model-impl iter)
+ (:method ((lisp-model-list lisp-model-list) iter)
+ (let ((index (pointer-address
+ (foreign-slot-value iter 'tree-iter-struct 'u1))))
+ (when (> index 0)
+ (setf (foreign-slot-value iter 'tree-iter-struct 'u1)
+ (make-pointer (1- index)))))))
+
+
(defgeneric iter-children (lisp-model-impl iter parent)
(:method ((lisp-model-list lisp-model-list) iter parent)
(when (null-pointer-p parent)
@@ -126,6 +135,7 @@
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))
@@ -136,35 +146,6 @@
unref-node (:void (iter tree-iter-struct)))
-
-;(defcallback cb-init- :void ((class tree-model-iface) (data pdata))
-; (setf (foreign-slot-value class 'tree-model-iface 'get-flags)
-; (callback cb-get-flags)))
- ;; (init-iface class tree-model-iface
- ;; get-flags
- ;; get-column-type
- ;; get-iter
- ;; get-path
- ;; get-value
- ;; iter-next
- ;; iter-children
- ;; iter-has-child
- ;; iter-n-children
- ;; iter-nth-child
- ;; iter-parent
- ;; ref-node
- ;; unref-node))
-
-
-; (check-type data symbol)
-; (init-interface data
-; (g-type->lisp
-; (foreign-slot-value class 'tree-model-iface 'g-iface))
-; class))
-
-
-
-
(defcstruct g-interface-info
(init :pointer)
(finalize :pointer)
@@ -181,7 +162,7 @@
(prog1
(setf g-type
(g-type-register-static-simple
- #.(name->g-type :object)
+ #.(keyword->g-type :object)
(g-intern-static-string "GtkLispModel")
(foreign-type-size 'g-object-class)
(callback cb-lisp-model-class-init)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/list-store.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/list-store.lisp 2011/08/26 17:16:14 1.2
@@ -7,6 +7,7 @@
;;;
(in-package :gtk-cffi)
+(declaim (optimize (speed 3)))
(defclass list-store (g-object tree-model)
())
@@ -25,7 +26,7 @@
(with-foreign-object (arr :int n)
(dotimes (i n)
(setf (mem-aref arr :int i)
- (name->g-type (nth i columns))))
+ (keyword->g-type (nth i columns))))
(gtk-list-store-newv n arr)))
(mapc (lambda (row) (append-values list-store row)) values)))
@@ -33,7 +34,7 @@
(defcfun "gtk_list_store_append" :void (store pobject) (iter pobject))
(defmethod append-iter ((list-store list-store) &optional
- (tree-iter (iter list-store)))
+ (tree-iter (tree-iter list-store)))
(gtk-list-store-append list-store tree-iter))
(defcfun "gtk_list_store_set_value" :void (store pobject) (iter pobject)
@@ -41,8 +42,9 @@
(defmethod (setf model-values)
(values (list-store list-store)
- &key (iter (iter list-store)) col (columns (when col (list col))))
+ &key (iter (tree-iter list-store)) col (columns (when col (list col))))
"Example: (setf (model-values list-store :col 1) \"val1\")"
+ (declare (type list columns values))
(let ((%cols (append columns (loop :for i
:from (length columns)
:below (length values)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/loadlib.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/loadlib.lisp 2011/08/26 17:16:14 1.2
@@ -18,8 +18,8 @@
(define-foreign-library :gtk
- (:unix "libgtk-x11-2.0.so")
- (:windows "libgtk-win32-2.0-0.dll"))
+ (:unix "libgtk-3.so.0") ;libgtk-x11-2.0.so")
+ (:windows "libgtk-win32-3-0.dll"))
(load-foreign-library :gtk)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/08 15:02:02 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/26 17:16:14 1.3
@@ -8,8 +8,9 @@
(in-package #:cl-user)
(defpackage gtk-cffi
- (:use #:common-lisp #:cffi
- #:cffi-object #:g-object-cffi #:g-lib-cffi #:gdk-cffi)
+ (:use #:common-lisp #:cffi #:alexandria #:iterate
+ #:cffi-object #:g-object-cffi #:g-lib-cffi #:gdk-cffi
+ #:gtk-cffi-utils)
(:shadow #:image #:window)
(:export
;;;; common
@@ -92,15 +93,22 @@
#:default-size
#:screen
#:transient-for
- #:win-position
+ #:window-position
;; methods
#:dialog
- ;; dialog slots
- #:has-separator
;;methods
#:run
+ #:response
#:add-button
+ #:default-response
+ #:add-action-widget
+ #:response-sensitive
+ #:response-for-widget
+ #:action-area
+ #:content-area
+ #:alternative-button-order
+ #:alternative-dialog-button-order
#:entry
;; entry slots
@@ -285,8 +293,11 @@
#:image
#:lisp-model
+ #:implementation
#:lisp-model-array
#:larray
+
+ #:expander
))
(in-package #:gtk-cffi)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/paned.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/paned.lisp 2011/08/26 17:16:14 1.2
@@ -6,6 +6,8 @@
(pane-type :initform 1)
(cur-param :initform nil :allocation :class)))
+(defgtkslot paned (paned-position . position) :int)
+
(defcfun "gtk_paned_add1" :void (paned pobject) (widget pobject))
(defcfun "gtk_paned_add2" :void (paned pobject) (widget pobject))
@@ -17,7 +19,7 @@
(resize :boolean) (shrink :boolean))
(defmethod pack ((paned paned) (widget widget)
- &key (pane-type 1) (resize :default) (shrink :default))
+ &key (pane-type :default) (resize :default) (shrink :default))
(macrolet ((default (field)
`(if (eq ,field :default) (slot-value paned ',field) ,field)))
(case (default pane-type)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model-filter.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model-filter.lisp 2011/08/26 17:16:14 1.2
@@ -1,6 +1,6 @@
(in-package :gtk-cffi)
-(defclass tree-model-filter (gobject tree-model)
+(defclass tree-model-filter (g-object tree-model)
((model :accessor model :initarg :model)))
(defcfun "gtk_tree_model_filter_new" :pointer (model pobject) (path pobject))
@@ -58,8 +58,8 @@
&key (iter (iter tree-model-filter)) col
(columns (when col (list col))))
(with-child-iter child-iter tree-model-filter iter
- (apply #'(setf model-values)
- (append (list values (model tree-model-filter)
- child-iter) columns))))
+ (setf (model-values (model tree-model-filter)
+ :iter child-iter :columns columns) values)))
+
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2011/08/08 15:02:02 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2011/08/26 17:16:14 1.3
@@ -94,7 +94,7 @@
(defclass tree-model (object)
((columns :accessor columns :initarg :columns)
- (iter :accessor iter)))
+ (iter :accessor tree-iter)))
(defcstruct tree-model-iface
"GtkTreeModelIface"
@@ -113,6 +113,7 @@
(get-path :pointer)
(get-value :pointer)
(iter-next :pointer)
+ (iter-previous :pointer)
(iter-children :pointer)
(iter-has-child :pointer)
(iter-n-children :pointer)
@@ -124,20 +125,20 @@
(defmethod initialize-instance
:after ((tree-model tree-model)
&key &allow-other-keys)
- (setf (iter tree-model) (make-instance 'tree-iter)))
+ (setf (tree-iter tree-model) (make-instance 'tree-iter)))
(defmethod free :before ((tree-model tree-model))
- (free (iter tree-model)))
+ (free (tree-iter tree-model)))
(defvar *tree-model-foreach* nil)
(defcallback cb-tree-model-foreach :boolean
- ((model pobject) (path :pointer) (iter :pointer) (data pdata))
+ ((model pobject) (path :pointer) (tree-iter :pointer) (data pdata))
(if *tree-model-foreach*
(funcall *tree-model-foreach*
model
(make-instance 'tree-path :pointer path)
- (make-instance 'tree-iter :pointer iter)
+ (make-instance 'tree-iter :pointer tree-iter)
data)
t))
@@ -165,7 +166,7 @@
(defmethod model-values
((tree-model tree-model) &key
- (iter (iter tree-model)) col (columns (when col (list col))))
+ (iter (tree-iter tree-model)) col (columns (when col (list col))))
"columns = num0 &optional num1 num2 ..."
;(format t "model-values: ~a ~a ~a~%" tree-model tree-iter cols)
(mapcar
@@ -186,7 +187,7 @@
(model pobject) (iter pobject) (path :string))
(defmethod path->iter ((tree-model tree-model) tree-path-string
- &optional (tree-iter (iter tree-model)))
+ &optional (tree-iter (tree-iter tree-model)))
(gtk-tree-model-get-iter-from-string tree-model tree-iter tree-path-string)
tree-iter)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2011/08/26 17:16:14 1.2
@@ -1,70 +1,84 @@
(in-package :gtk-cffi)
-(defclass widget (gtk-object)
+(defclass widget (g-object)
())
-(defcstruct requisition
- "GtkRequisition"
- (width :int)
- (height :int))
-
-(defcstruct allocation
- "GtkAllocation"
- (x :int) (y :int)
- (width :int) (height :int))
-
-(defcstruct widget
- "GtkWidget"
- (object gtk-object)
- (private-flags :uint16)
- (state :uint8)
- (saved-state :uint8)
- (name :string)
- (style :pointer)
- (requisition requisition)
- (allocation allocation)
- (window pobject)
- (parent pobject))
+(defclass requisition (object)
+ ())
+(defcfun gtk-requisition-new :pointer)
-(defcfun "gtk_widget_activate" :boolean (widget pobject))
+(defmethod gconstructor ((requisition requisition) &key &allow-other-keys)
+ (gtk-requisition-new))
-(defmethod activate ((widget widget))
- (gtk-widget-activate widget))
+(defcfun gtk-requisition-copy :pointer (requisition pobject))
-(defcfun "gtk_widget_show" :boolean (widget pobject))
-(defcfun "gtk_widget_show_all" :boolean (widget pobject))
+(defmethod copy ((requisition requisition))
+ (make-instance 'requisition :pointer (gtk-requisition-copy requisition)))
-(defmethod show ((widget widget) &key (all t))
- (funcall (if all #'gtk-widget-show-all
- #'gtk-widget-show) widget))
+(defcfun gtk-requisition-free :void (requisition pobject))
-(defcfun "gtk_widget_hide" :boolean (widget pobject))
-(defcfun "gtk_widget_hide_all" :boolean (widget pobject))
+(defmethod free ((requisition requisition))
+ (gtk-requisition-free requisition))
-(defmethod hide ((widget widget) &key all)
- (funcall (if all #'gtk-widget-hide-all
- #'gtk-widget-hide) widget))
+(defcstruct* requisition
+ "GtkRequisition"
+ (width :int)
+ (height :int))
-(defcfun "gtk_widget_realize" :void (widget pobject))
+(defcstruct allocation
+ "GtkAllocation"
+ (x :int) (y :int)
+ (width :int) (height :int))
-(defmethod realize ((widget widget))
- (gtk-widget-realize widget))
+(defgtkfun activate :boolean widget)
-(defstruct (size-request (:type list)) width height)
+(defcfun gtk-widget-show :boolean (widget pobject))
+(defcfun gtk-widget-show-all :boolean (widget pobject))
+(defcfun gtk-widget-show-now :boolean (widget pobject))
+
+(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))
+
+(defgtkfun hide :boolean widget)
+
+(defgtkfun realize :void widget)
+
+(defcfun gtk-widget-draw :void (widget pobject) (context :pointer))
+(defmethod draw ((widget widget) &optional (context cl-cairo2:*context*))
+ (cl-cairo2::with-context-pointer (context 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))
+
+(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))))
+
+(defcfun gtk-widget-queue-resize :void (widget pobject))
+(defcfun gtk-widget-queue-resize-no-redraw :void (widget pobject))
+
+(defmethod queue-resize ((widget widget) &key no-redraw)
+ (if no-redraw
+ (gtk-widget-queue-resize-no-redraw widget)
+ (gtk-widget-queue-resize widget)))
-(defcfun "gtk_widget_size_request" :void
- (widget pobject) (req requisition))
+(defcfun "gtk_widget_get_size_request" :void
+ (widget pobject) (width :pointer) (height :pointer))
(defmethod size-request ((widget widget))
"returns (width height)"
- (with-foreign-object (res 'requisition)
- (gtk-widget-size-request widget res)
- (with-foreign-slots
- ((width height) res requisition)
- (make-size-request :width width
- :height height))))
-
+ (with-foreign-objects ((width :int) (height :int))
+ (gtk-widget-get-size-request widget width height)
+ (list (mem-ref width :int) (mem-ref height :int))))
(defcfun "gtk_widget_set_size_request"
:void (widget pobject) (w :int) (h :int))
@@ -72,142 +86,28 @@
(defmethod (setf size-request) (coords (widget widget))
"coords = (width height)"
(gtk-widget-set-size-request widget
- (size-request-width coords)
- (size-request-height coords)))
+ (first coords)
+ (second coords)))
+
+
+
+(defgtkfun override-color :void widget (state state-flags) (color prgba))
+
+(defgtkfun override-background-color :void
+ widget (state state-flags) (color prgba))
+(defgtkfun override-symbolic-color :void widget (name :string) (color prgba))
-(defcstruct style
- (parent-instance g-object)
- (fg color-struct :count 5)
- (bg color-struct :count 5)
- (light color-struct :count 5)
- (dark color-struct :count 5)
- (mid color-struct :count 5)
- (text color-struct :count 5)
- (base color-struct :count 5)
- (text-aa color-struct :count 5)
- (black color-struct :count 5)
- (white color-struct :count 5)
- (font-desc pango-cffi:font)
- (xthickness :int)
- (ythickness :int)
- (fg-gc pobject :count 5)
- (bg-gc pobject :count 5)
- (light-gc pobject :count 5)
- (dark-gc pobject :count 5)
- (mid-gc pobject :count 5)
- (text-gc pobject :count 5)
- (base-gc pobject :count 5)
- (text-aa-gc pobject :count 5)
- (black-gc pobject :count 5)
- (white-gc pobject :count 5)
- (bg-pixmap pobject :count 5))
-
-(defcstruct rcstyle
- (parent-instance g-object)
- (name gtk-dyn-string)
- (bg-pixmap-name gtk-dyn-string :count 5)
- (font-desc pango-cffi:font)
- (color-flags :int :count 5)
- (fg pcolor :count 5)
- (bg pcolor :count 5)
- (text pcolor :count 5)
- (base pcolor :count 5)
- (xthickness :int)
- (ythickness :int))
-
-(defcenum state
- :normal :active :prelight :selected :insensitive)
-
-(defcfun "gtk_widget_modify_fg"
- :void (widget pobject) (state state) (color pcolor))
-
-(defcfun "gtk_widget_modify_bg"
- :void (widget pobject) (state state) (color pcolor))
-
-(defcfun "gtk_widget_modify_text"
- :void (widget pobject) (state state) (color pcolor))
-
-(defcfun "gtk_widget_modify_base"
- :void (widget pobject) (state state) (color pcolor))
-
-(macrolet ((select-accessor (type)
- `(ccase ,type
- ,@(mapcar (lambda (x)
- (list x
- (list 'function
- (intern
- (format nil
- "GTK-WIDGET-MODIFY-~A" x)))))
- '(:fg :bg :text :base)))))
-
- (defmethod (setf color) (color (widget widget)
- &optional (type :fg) (state :normal))
- "TYPE may be :fg :bg :text :base,
- STATE may be :normal :active :prelight :selected :insensitive"
- (funcall (select-accessor type) widget state color)))
-
-(macrolet ((style-field-place
- ()
- `(mem-aref
- (foreign-slot-pointer (style widget)
- 'style (intern (string field) #.*package*))
- type
- (foreign-enum-value 'state state))))
-
- (defmethod style-field ((widget widget) field
- &optional (state :normal) (type 'pobject))
- (style-field-place))
-
- (defmethod (setf style-field) (value (widget widget) field
- &optional (state :normal)
- (type :pointer))
- (setf (style-field-place) value)))
-
-(defmethod color ((widget widget)
- &optional (field :fg) (state :normal))
- "TYPE may be :fg :bg :text :base,
- STATE may be :normal :active :prelight :selected :insensitive"
- (style-field widget field state 'color-struct))
-
-(defcfun "gtk_widget_modify_font" :void (widget pobject)
- (font pango-cffi:font))
-
-(defmethod (setf font) (font (widget widget))
- (gtk-widget-modify-font widget font))
-
-(defmethod font ((widget widget))
- (style-field widget :font-desc)) ;; = widget->get_style()->font_desc
-
-
-(defcenum text-direction
- :none :ltr :rtl)
-
-(defcfun "gtk_widget_get_modifier_style" rcstyle (widget pobject))
-
-(defcfun "gtk_widget_modify_style" :void (widget pobject) (style rcstyle))
-
-(defcfun ("gtk_rc_parse_string" rc-parse-string) :void (str gtk-string))
-
-(defmethod (setf bg-pixmap) (pixmap-name (widget widget)
- &optional (state :normal))
- (let ((rcstyle (gtk-widget-get-modifier-style widget)))
- (setf (mem-aref
- (foreign-slot-pointer rcstyle 'rcstyle 'bg-pixmap-name)
- 'gtk-string
- (foreign-enum-value 'state state))
- pixmap-name)
- (gtk-widget-modify-style widget rcstyle)
- (setf (app-paintable widget) t)))
-
-(defmethod bg-pixmap ((widget widget) &optional (state :normal))
- (let ((rcstyle (gtk-widget-get-modifier-style widget)))
- (mem-aref
- (foreign-slot-pointer rcstyle 'rcstyle 'bg-pixmap-name)
- 'gtk-string
- (foreign-enum-value 'state state))))
-
+(defcfun gtk-widget-get-style-context pobject (widget pobject))
+
+(defmethod style-context ((widget widget))
+ (gtk-widget-get-style-context widget))
+
+(defgtkfun override-font :void widget (font pango-cffi:font))
+
+(defcenum align :fill :start :end :center)
+
(defgtkslots widget
name gtk-string
direction text-direction
@@ -227,10 +127,21 @@
mapped :boolean
realized :boolean
no-show-all :boolean
- colormap pobject
sensitive :boolean
- state state
- style style
+ events event-mask
+ visual pobject
+ composite-name gtk-string
+ halign align
+ valign align
+ margin-left :int
+ margin-right :int
+ margin-top :int
+ margin-bottom :int
+ hexpand :boolean
+ hexpand-set :boolean
+ vexpand :boolean
+ allocation allocation
+ vexpand-set :boolean
app-paintable :boolean)
(defbitfield widget-flags
@@ -255,36 +166,186 @@
:no-show-all)
-(defcfun "gtk_widget_size_allocate" :void
- (widget pobject) (allocation allocation))
+(defgtkfun destroy :void widget)
+
+(defgtkfun render-icon-pixbuf pobject widget
+ (stock-id :string) (size icon-size))
+
+(defgtkfun add-events :void widget (events event-mask))
+
+(defgtkgetter device-events event-mask widget (device pobject))
+
+(defcfun gtk-widget-set-device-events :void
+ (widget pobject) (device pobject) (events event-mask))
+
+(defmethod (setf device-events) (events (widget widget) device)
+ (gtk-widget-set-device-events widget device events))
+
+(defgtkfun add-device-events :void widget
+ (device pobject) (events event-mask))
+
+(defcfun gtk-widget-set-device-enabled :void
+ (widget pobject) (device pobject) (enabled :boolean))
+
+(defmethod (setf device-enabled) (enabled (widget widget) device)
+ (gtk-widget-set-device-enabled widget device enabled))
+
+(defgtkgetter device-enabled :boolean widget (device pobject))
+
+(defgtkgetter toplevel pobject widget)
+(defgtkgetter ancestor pobject widget (widget-type g-type))
+
+
+(defcfun ("gtk_widget_pop_composite_child" pop-composite-child) :void)
+(defcfun ("gtk_widget_push_composite_child" push-composite-child) :void)
+
+(defcfun gtk-widget-get-pointer :void
+ (widget pobject) (x :pointer) (y :pointer))
+
+(defmethod get-pointer ((widget widget))
+ (with-foreign-objects ((x :int) (y :int))
+ (gtk-widget-get-pointer widget x y)
+ (list (mem-ref x :int) (mem-ref y :int))))
+
+(defgtkfun is-ancestor :boolean widget (ancestor pobject))
+
+(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)
+ (with-foreign-objects ((dst-x :int) (dst-y :int))
+ (gtk-widget-translate-coordinates src-widget dst-widget
+ src-x src-y dst-x dst-y)
+ (list (mem-ref dst-x :int) (mem-ref dst-y :int))))
+
+(defgtkfun shape-combine-region :void widget (region pobject))
+(defgtkfun input-shape-combine-region :void widget (region pobject))
+
+(defgtkgetter path (object widget-path) widget)
+(defgtkfun is-composited :boolean widget)
+
+(defgtkfun override-cursor :void widget (cursor prgba) (secondary-cursor prgba))
+
+(defgtkfun create-pango-context pobject widget)
+(defgtkgetter pango-context pobject widget)
+(defgtkfun create-pango-layout pobject widget)
+(defgtksetter redraw-on-allocate :boolean widget)
+(defgtkfun mnemonic-activate :boolean widget (group-cycling :boolean))
+
+(defgtkgetter window pobject widget)
+(defgtkgetter settings pobject widget)
+
[142 lines skipped]
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/window.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/window.lisp 2011/08/26 17:16:14 1.2
@@ -6,6 +6,15 @@
(defclass window (bin)
())
+(defmethod gconstructor ((window window)
+ &key (type :top-level) &allow-other-keys)
+ (gtk-window-new type))
+
+(defgtkslots window
+ title gtk-string
+ screen pobject
+ transient-for pobject)
+
(defcfun "gtk_window_new" :pointer (type window-type))
(defcfun "gtk_window_set_default_size"
@@ -14,19 +23,6 @@
(defcfun "gtk_window_get_default_size"
:void (window pobject) (w :pointer) (h :pointer))
-(defmethod gconstructor ((window window)
- &key (type :top-level) &allow-other-keys)
- (gtk-window-new type))
-
-(defmethod initialize-instance
- :after ((window window)
- &key (width -1) (height -1) title transient-for win-position
- &allow-other-keys)
- (when (or (/= width -1) (/= height -1))
- (gtk-window-set-default-size window width height))
- (setf-init window title transient-for win-position))
-
-
(defmethod (setf default-size) (coords (window window))
(let ((width (first coords))
(height (second coords)))
@@ -38,17 +34,6 @@
(gtk-window-get-default-size window width height)
(list (mem-ref width :int) (mem-ref height :int))))
-(defcfun "gtk_window_get_screen" :pointer (window pobject))
-
-(defmethod screen ((window window))
- (make-instance 'gdk-cffi:screen
- :pointer (gtk-window-get-screen window)))
-
-(defcfun "gtk_window_set_screen" :void (window pobject) (screen pobject))
-
-(defmethod (setf screen) ((screen gdk-cffi:screen) (window window))
- (gtk-window-set-screen window screen))
-
(defcenum position
:none
:center
@@ -58,25 +43,11 @@
(defcfun "gtk_window_set_position" :void (window pobject) (pos position))
-(defmethod (setf win-position) (pos (window window))
+(defmethod (setf window-position) (pos (window window))
(gtk-window-set-position window pos))
-(defcfun "gtk_window_set_title" :void (window pobject) (title gtk-string))
-(defcfun "gtk_window_get_title" gtk-string (window pobject))
-
-(defmethod title ((window window))
- (gtk-window-get-title window))
-
-(defmethod (setf title) (title (window window))
- (gtk-window-set-title window title))
-
-(defcfun "gtk_window_set_transient_for" :void
- (window pobject) (parent pobject))
-
-(defcfun "gtk_window_get_transient_for" pobject (window pobject))
-
-(defmethod (setf transient-for) (parent (window window))
- (gtk-window-set-transient-for window parent))
+(init-slots window ((width -1) (height -1) position)
+ (when (or (/= width -1) (/= height -1))
+ (gtk-window-set-default-size window width height))
+ (when position (setf (window-position window) position)))
-(defmethod transient-for ((window window))
- (gtk-window-get-transient-for window))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/css-provider.lisp 2011/08/26 17:16:14 NONE
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/css-provider.lisp 2011/08/26 17:16:14 1.1
(in-package :gtk-cffi)
(defclass css-provider (g-object style-provider)
())
(defcfun gtk-css-provider-get-default :pointer)
(defcfun gtk-css-provider-get-named :pointer (name :string) (variant :string))
(defcfun gtk-css-provider-new :pointer)
(defmethod gconstructor ((css-provide css-provider) &key name variant default)
(cond
(default (gtk-css-provider-get-default))
(name (gtk-css-provider-get-named name variant))
(t (gtk-css-provider-new))))
(defcfun gtk-css-provider-load-from-data :boolean
(css-provider pobject) (data :string) (length :int) (g-error object))
(defcfun gtk-css-provider-load-from-file :boolean
(css-provider pobject) (file g-file) (g-error object))
(defcfun gtk-css-provider-load-from-path :boolean
(css-provider pobject) (path :string) (g-error object))
(defmethod css-provider-load ((css-provider css-provider)
&key data filename gfile)
(with-g-error g-error
(unless
(cond
(data (gtk-css-provider-load-from-data css-provider data -1 g-error))
(filename (gtk-css-provider-load-from-path css-provider
filename g-error))
(gfile (gtk-css-provider-load-from-file css-provider gfile g-error)))
(cerror "Continue" "CSS Provider load error: ~a" g-error))))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2011/08/26 17:16:14 NONE
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2011/08/26 17:16:14 1.1
(in-package :gtk-cffi)
(defcenum text-direction
:none :ltr :rtl)
(defbitfield junction-sides
(:none 0) :corner-topleft :corner-topright
:corner-bottomleft :corner-bottomright
(:top #b0011) (:bottom #b1100) (:left #b0101) (:right #b1010))
(defbitfield state-flags
(:normal 0) :active :prelight :selected :insensitive :inconsistent :focused)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/expander.lisp 2011/08/26 17:16:14 NONE
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/expander.lisp 2011/08/26 17:16:14 1.1
(in-package :gtk-cffi)
(defclass expander (bin)
())
(defcfun gtk-expander-new-with-mnemonic :pointer (label gtk-string))
(defcfun gtk-expander-new :pointer (label gtk-string))
(defmethod gconstructor ((expander expander)
&key label mnemonic &allow-other-keys)
(if mnemonic
(gtk-expander-new-with-mnemonic mnemonic)
(gtk-expander-new label)))
(defgtkslots expander
label gtk-string
spacing :int
expanded :boolean
use-underline :boolean
use-markup :boolean
label-widget pobject
label-fill :boolean)
(init-slots expander nil)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/style-context.lisp 2011/08/26 17:16:14 NONE
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/style-context.lisp 2011/08/26 17:16:14 1.1
(in-package :gtk-cffi)
(defclass style-context (g-object)
(provider (styles :initform nil)))
(defcfun gtk-style-context-new :pointer)
(defmethod gconstructor ((style-context style-context) &key &allow-other-keys)
(gtk-style-context-new))
(defgtkgetter direction text-direction style-context)
(defgtkgetter junction-sides junction-sides style-context)
(defgtkgetter screen pobject style-context)
(defgtkgetter state state-flags style-context)
(defcfun gtk-style-context-get-color :void
(style-context pobject) (state state-flags) (color :pointer))
(defcfun gtk-style-context-get-background-color :void
(style-context pobject) (state state-flags) (color :pointer))
(defcfun gtk-style-context-get-border-color :void
(style-context pobject) (state state-flags) (color :pointer))
(defmethod color ((style-context style-context)
&key type (state :normal))
(with-foreign-object (color 'prgba)
(funcall
(case type
(:bg #'gtk-style-context-get-background-color)
(:border #'gtk-style-context-get-border-color)
(t #'gtk-style-context-get-color)) style-context state color)
(convert-from-foreign color 'prgba)))
(defcfun gtk-style-context-get-font pango-cffi:font
(style-context pobject) (state state-flags))
(defmethod font ((style-context style-context)
&key (state :normal))
(gtk-style-context-get-font style-context state))
(defgtkfun add-provider :void style-context
(style-provider pobject) (priority :uint))
(defmethod load-css ((style-context style-context) text)
(if (slot-boundp style-context 'provider)
(css-provider-load (slot-value style-context 'provider) :data text)
(progn
(let ((provider (make-instance 'css-provider)))
(setf (slot-value style-context 'provider) provider)
(css-provider-load provider :data text)
(add-provider style-context provider 600)))))
(defun make-css (style-context type state value)
(let ((found (assoc (list type state) (slot-value style-context 'styles)
:test #'equal)))
(if found
(setf (cdr found) value)
(push (cons (list type state) value)
(slot-value style-context 'styles))))
(with-output-to-string (s)
(mapc (lambda (x)
(destructuring-bind ((type state) . value) x
(format s "~a {~a: ~a}"
(if (eq state :normal) "*" state)
(case type
(:bg "background-color")
(:border "border-color")
(:font "font")
;(:bg-image "border-image")
(:bg-image "background-image")
(t "color"))
value)))
(slot-value style-context 'styles))))
(defmethod (setf color) (value (style-context style-context)
&key type (state :normal))
(check-type type (member :bg :border nil))
(load-css style-context (make-css style-context type state value)))
(defmethod (setf font) (value (style-context style-context)
&key (state :normal))
(load-css style-context (make-css style-context :font state value)))
(defmethod (setf bg-pixmap) (value (style-context style-context)
&key (state :normal))
(load-css style-context
(make-css style-context :bg-image state
(format nil
"url('~a')" value))))
(defmethod bg-pixmap ((style-context style-context) &key (state :normal))
(cdr (assoc (list :bg-image state) (slot-value style-context 'styles)
:test #'equal)))--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/style-provider.lisp 2011/08/26 17:16:14 NONE
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/style-provider.lisp 2011/08/26 17:16:14 1.1
(in-package :gtk-cffi)
(defclass style-provider (object)
())--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget-path.lisp 2011/08/26 17:16:14 NONE
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget-path.lisp 2011/08/26 17:16:14 1.1
(in-package :gtk-cffi)
(defclass widget-path (object)
())
(defgtkfun free :void widget-path)
(defcfun gtk-widget-path-new :pointer)
(defmethod gconstructor ((widget-path widget-path) &key &allow-other-keys)
(gtk-widget-path-new))
More information about the gtk-cffi-cvs
mailing list