[gtk-cffi-cvs] CVS gtk-cffi/gtk
CVS User rklochkov
rklochkov at common-lisp.net
Sun Aug 28 10:30:13 UTC 2011
Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk
In directory tiger.common-lisp.net:/tmp/cvs-serv21254
Modified Files:
accel-group.lisp cell-layout.lisp enums.lisp gtk-cffi.asd
menu-bar.lisp package.lisp widget.lisp
Added Files:
menu-item.lisp
Log Message:
GtkWidget is finished
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/accel-group.lisp 2011/08/26 17:16:14 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/accel-group.lisp 2011/08/28 10:30:13 1.3
@@ -27,9 +27,16 @@
(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)))
+ "FUNC should have args: (accel-group acceleratable keyval modifier)
+CONNECT returns foreign pointer to create GLib closure"
+ (let ((closure (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))))
+ key accel-mods accel-flags closure))
+ closure))
+
+(defgtkfun disconnect :boolean accel-group (closure object))
+
+(defcfun ("gtk_accel_group_from_accel_closure" accel-group-from-accel-closure)
+ pobject (closure :pointer))
\ No newline at end of file
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-layout.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-layout.lisp 2011/08/28 10:30:13 1.2
@@ -55,14 +55,10 @@
(gtk-cell-layout-set-cell-data-func
cell-layout cell-renderer
c-handler
- (cond
- ((pointerp data) data)
- ((null data) (null-pointer))
- ((typep data 'gobject) (pointer data))
- (t (pointer (make-instance 'storage :data data))))
+ data
;; destroy-notify
(or destroy-notify
- (if (or (null data) (pointerp data) (typep data 'gobject))
+ (if (or (null data) (pointerp data) (typep data 'g-object))
(null-pointer) (callback free-storage))))))
(defcfun "gtk_cell_layout_clear_attributes" :void
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2011/08/26 17:16:14 1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/enums.lisp 2011/08/28 10:30:13 1.2
@@ -10,3 +10,9 @@
(defbitfield state-flags
(:normal 0) :active :prelight :selected :insensitive :inconsistent :focused)
+
+(defcenum direction-type
+ :tab-forward :tab-backward :up :down :left :right)
+
+(defcenum orientation
+ :horizontal :vertical)
\ No newline at end of file
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/08/26 17:16:14 1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/08/28 10:30:13 1.4
@@ -31,7 +31,7 @@
(defsystem gtk-cffi-widget
: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-core)
:components
@@ -72,7 +72,8 @@
:depends-on (gtk-cffi-container)
:components
((:file bin)
- (:file expander :depends-on (bin))))
+ (:file expander :depends-on (bin))
+ (:file menu-item :depends-on (bin))))
(defsystem gtk-cffi-window
:description "Interface to GTK/Glib via CFFI"
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/menu-bar.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/menu-bar.lisp 2011/08/28 10:30:13 1.2
@@ -5,6 +5,14 @@
(defcfun "gtk_menu_bar_new" :pointer)
-(defmethod gconstructor ((menu-bar menu-bar) &rest rest)
- (declare (ignore rest menu-bar))
- (gtk-menu-bar-new))
\ No newline at end of file
+(defmethod gconstructor ((menu-bar menu-bar) &key &allow-other-keys)
+ (gtk-menu-bar-new))
+
+(defcenum pack-direction
+ :ltr :rtl :ttb :btt)
+
+(defgtkslots menu-bar
+ pack-direction pack-direction
+ child-pack-direction pack-direction)
+
+(init-slots menu-bar nil)
\ No newline at end of file
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/26 17:16:14 1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/28 10:30:13 1.4
@@ -25,28 +25,31 @@
#:gsignal
#:yield
- ;; size-request structure
- #:make-size-request
- #:size-request-width
- #:size-request-height
-
- ;; allocation structure
- #:make-allocation
- #:allocation-x
- #:allocation-y
- #:allocation-width
- #:allocation-height
-
- #:gtk-object
- ;; methods
- #:destroy
#:widget
;; widget slots
#:name
+ #:direction
+ #:default-direction
+ #:parent-window
+ #:has-tooltip
+ #:can-focus
+ #:double-buffered
+ #:events
+ #:visual
+ #:composite-name
+ #:halign
+ #:valign
+ #:margin-left
+ #:margin-right
+ #:margin-top
+ #:margin-bottom
+ #:hexpand
+ #:hexpand-set
+ #:vexpand
+ #:vexpand-set
+ #:app-paintable
#:size-request
- #:style-field
- #:style
#:direction
#:default-direction
#:color
@@ -69,13 +72,101 @@
#:no-show-all
#:colormap
#:sensitive
+ #:accel-path
+ #:style-context
+ #:device-events
+ #:device-enabled
+ #:toplevel
+ #:ancestor
+ #:is-ancestor
+ #:path
+ #:is-composited
+ #:pango-context
+ #:redraw-on-allocate ; setter only
+ #:accessible
+ #:settings
+ #:clipboard
+ #:display
+ #:root-window
+ #:screen
+ #:has-screen
+ #:allocated-width
+ #:allocated-height
+ #:is-sensitive
+ #:is-focus
+ #:state-flags
+ #:has-default
+ #:has-focus
+ #:has-grab
+ #:is-drawable
+ #:is-toplevel
+ #:device-is-shadowed
+ #:preferred-height
+ #:preferred-width
+ #:preferred-size
;; methods
#:activate
#:show
#:hide
- #:rc-parse-string
+ #:draw
+ #:queue-draw
+ #:queue-resize
+ #:size-allocate
+ #:add-accelerator
+ #:remove-accelerator
+ #:list-accel-closures
+ #:can-activate-accel
+ #:widget-event
+ #:send-expose
+ #:send-focus-change
+ #:intersect
+ #:grab-focus
+ #:grab-default
+ #:override-color
+ #:override-background-color
+ #:override-symbolic-color
+ #:override-font
+ #:override-cursor
+ #:render-icon-pixbuf
+ #:add-events
+ #:get-pointer
+ #:translate-coordinates
+ #:shape-combine-region
+ #:input-shape-combine-region
+ #:create-pango-context
+ #:create-pango-layout
+ #:mnemonic-activate
+ #:widget-map
+ #:unmap
#:realize
- #:gdk-window
+ #:unrealize
+ #:child-focus
+ #:child-notify
+ #:freeze-child-notify
+ #:thaw-child-notify
+ #:destroy
+ #:list-mnemonic-labels
+ #:add-mnemonic-label
+ #:remove-mnemonic-label
+ #:error-bell
+ #:keynav-failed
+ #:trigger-tooltip-query
+ #:reset-style
+ #:queue-compute-expand
+ #:compute-expand
+
+ #:pop-composite-child
+ #:push-composite-child
+ #:cairo-should-draw-window
+ #:cairo-transform-to-window
+ #:distribute-natural-allocation
+
+ #:widget-class
+ #:install-style-property
+ #:install-style-property-parser
+ #:list-style-properties
+ #:find-style-property
+ #:style-property
#:bin
;; methods
@@ -279,6 +370,14 @@
#:menu
#:menu-bar
+ #:pack-direction
+ #:child-pack-direction
+
+ #:menu-item
+ #:right-justified
+ #:use-underline
+ #:submenu
+
#:tool-shell
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2011/08/26 17:16:14 1.2
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2011/08/28 10:30:13 1.3
@@ -1,36 +1,46 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; widget.asd --- Wrapper for GtkWidget
+;;;
+;;; Copyright (C) 2007, Roman Klochkov <kalimehtar at mail.ru>
+;;;
+
(in-package :gtk-cffi)
(defclass widget (g-object)
- ())
+ ((%style-properties :accessor %style-properties
+ :initform nil :allocation :class)))
-(defclass requisition (object)
+(defclass requisition (struct)
())
(defcfun gtk-requisition-new :pointer)
-(defmethod gconstructor ((requisition requisition) &key &allow-other-keys)
+(defmethod new-struct ((class (eql 'requisition)))
(gtk-requisition-new))
-(defcfun gtk-requisition-copy :pointer (requisition pobject))
-
-(defmethod copy ((requisition requisition))
- (make-instance 'requisition :pointer (gtk-requisition-copy requisition)))
-
(defcfun gtk-requisition-free :void (requisition pobject))
-(defmethod free ((requisition requisition))
- (gtk-requisition-free requisition))
+(defmethod free-struct ((class (eql 'requisition)) value)
+ (gtk-requisition-free value))
(defcstruct* requisition
"GtkRequisition"
(width :int)
(height :int))
-(defcstruct allocation
+(init-slots requisition nil)
+
+(defclass allocation (struct)
+ ())
+
+(defcstruct* allocation
"GtkAllocation"
(x :int) (y :int)
(width :int) (height :int))
+(init-slots allocation nil)
+
(defgtkfun activate :boolean widget)
(defcfun gtk-widget-show :boolean (widget pobject))
@@ -45,8 +55,6 @@
(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)
@@ -76,9 +84,8 @@
(defmethod size-request ((widget widget))
"returns (width 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))))
+ (with-foreign-outs-list ((width :int) (height :int))
+ (gtk-widget-get-size-request widget width height)))
(defcfun "gtk_widget_set_size_request"
:void (widget pobject) (w :int) (h :int))
@@ -88,8 +95,40 @@
(gtk-widget-set-size-request widget
(first coords)
(second coords)))
+(save-setter widget size-request)
+(defgtkfun size-allocate :void widget (allocation (struct allocation)))
+(defgtkfun add-accelerator :void widget
+ (accel-signal :string) (accel-group pobject) (accel-key key)
+ (accel-mods modifier-type) (accel-flags accel-flags))
+
+(defgtkfun remove-accelerator :boolean widget
+ (accel-group pobject) (accel-key key) (accel-mods modifier-type))
+
+(defcfun gtk-widget-set-accel-path :void
+ (widget pobject) (accel-path :string) (accel-group pobject))
+
+(defmethod (setf accel-path) (value (widget widget) (accel-group accel-group))
+ (gtk-widget-set-accel-path widget value accel-group))
+
+(defgtkfun list-accel-closures g-list widget)
+(defgtkfun can-activate-accel :boolean widget (signal-id :uint))
+(defgtkfun (widget-event . event) :boolean widget (event event))
+(defgtkfun send-expose :int widget (event event))
+(defgtkfun send-focus-change :boolean widget (event event))
+
+(defcfun gtk-widget-intersect :boolean
+ (src1 pobject) (src2 (struct rectangle)) (dest (struct rectangle :out t)))
+
+(defmethod intersect ((rect1 widget) (rect2 rectangle))
+ (let ((dest (make-instance 'rectangle)))
+ (when (gtk-widget-intersect rect1 rect2 dest)
+ dest)))
+
+(defgtkfun is-focus :boolean widget)
+(defgtkfun grab-focus :void widget)
+(defgtkfun grab-default :void widget)
(defgtkfun override-color :void widget (state state-flags) (color prgba))
@@ -98,7 +137,6 @@
(defgtkfun override-symbolic-color :void widget (name :string) (color prgba))
-
(defcfun gtk-widget-get-style-context pobject (widget pobject))
(defmethod style-context ((widget widget))
@@ -118,6 +156,7 @@
tooltip-markup gtk-string
tooltip-text gtk-string
tooltip-window pobject
+ has-tooltip :boolean
can-default :boolean
can-focus :boolean
double-buffered :boolean
@@ -140,8 +179,10 @@
hexpand :boolean
hexpand-set :boolean
vexpand :boolean
- allocation allocation
vexpand-set :boolean
+ allocation (struct allocation)
+ window pobject
+ support-multidevice :boolean
app-paintable :boolean)
(defbitfield widget-flags
@@ -203,9 +244,8 @@
(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))))
+ (with-foreign-outs ((x :int) (y :int))
+ (gtk-widget-get-pointer widget x y)))
(defgtkfun is-ancestor :boolean widget (ancestor pobject))
@@ -215,11 +255,11 @@
(defmethod translate-coordinates ((src-widget widget) (dst-widget widget)
src-x src-y)
- (with-foreign-objects ((dst-x :int) (dst-y :int))
+ (with-foreign-outs ((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))))
+ src-x src-y dst-x dst-y)))
+;; region should be cairo_region_t, but it is not realized in cl-cairo2 yet
(defgtkfun shape-combine-region :void widget (region pobject))
(defgtkfun input-shape-combine-region :void widget (region pobject))
@@ -231,11 +271,156 @@
(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)
+(defgtkfun unparent :void widget)
+(defgtkfun (widget-map . map) :void widget)
+(defgtkfun unmap :void widget)
+(defgtkfun realize :void widget)
+(defgtkfun unrealize :void widget)
+
+(defgtkgetter accessible pobject widget)
+(defgtkfun child-focus :boolean widget (direction direction-type))
+(defgtkfun child-notify :void widget (child-property :string))
+(defgtkfun freeze-child-notify :void widget)
+
+;(defgtkgetter window pobject widget)
(defgtkgetter settings pobject widget)
+(defgtkgetter clipboard pobject widget (selection gatom))
+(setf (documentation 'clipboard 'function)
+ "SELECTION should be :PRIMARY or :CLIPOARD")
+
+(defgtkgetter display pobject widget)
+(defgtkgetter root-window pobject widget)
+(defgtkgetter screen pobject widget)
+(defgtkfun has-screen :boolean widget)
+(defgtkfun thaw-child-notify :void widget)
+(defgtkfun list-mnemonic-labels g-list-object widget)
+(defgtkfun add-mnemonic-label :void widget (label pobject))
+(defgtkfun remove-mnemonic-label :void widget (label pobject))
+(defgtkfun error-bell :void widget)
+(defgtkfun keynav-failed :boolean widget (direction direction-type))
+(defgtkfun trigger-tooltip-query :void widget)
+
+(defcfun gtk-cairo-should-draw-window :boolean
+ (context :pointer) (gdk-window pobject))
+
+(defmethod cairo-should-draw-window (window
+ &optional (context cl-cairo2:*context*))
+ (cl-cairo2::with-context-pointer (context cntx-pointer)
+ (gtk-cairo-should-draw-window cntx-pointer window)))
+
+(defmethod cairo-should-draw-window ((widget widget)
+ &optional (context cl-cairo2:*context*))
+ (cairo-should-draw-window (window widget) context))
+
+(defcfun gtk-cairo-transform-to-window :void
+ (context :pointer) (widget pobject) (gdk-window pobject))
+
+(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)))
+
+(defmethod cairo-transform-to-window ((widget widget) (window widget)
+ &optional (context cl-cairo2:*context*))
+ (cairo-transform-to-window widget (window window) context))
+
+
+(defgtkgetter allocated-width :int widget)
+(defgtkgetter allocated-height :int widget)
+(defgtkfun is-sensitive :boolean widget)
+(defgtkgetter state-flags state-flags widget)
+
+(defcfun gtk-widget-set-state-flags :void
+ (widget pobject) (flags state-flags) (clear :boolean))
+(defcfun gtk-widget-unset-state-flags :void
+ (widget pobject) (flags state-flags))
+
+(defmethod (setf state-flags) (value (widget widget) &key type)
+ "If TYPE = :CLEAR, clear state before set, :UNSET -- unset bits"
+ (case type
+ (:clear (gtk-widget-set-state-flags widget value t))
+ (:unset (gtk-widget-unset-state-flags widget value))
+ (t (gtk-widget-set-state-flags widget value nil))))
+
+(defgtkfun has-default :boolean widget)
+(defgtkfun has-focus :boolean widget)
+(defgtkfun has-grab :boolean widget)
+(defgtkfun is-drawable :boolean widget)
+(defgtkfun is-toplevel :boolean widget)
+(defgtkfun device-is-shadowed :boolean widget (device pobject))
+(defgtkfun reset-style :void widget)
+
+(defcfun gtk-widget-get-preferred-height :void
+ (widget pobject) (minimum :pointer) (natural :pointer))
+(defcfun gtk-widget-get-preferred-height-for-width :void
+ (widget pobject) (width :int) (minimum :pointer) (natural :pointer))
+
+(defmethod preferred-height ((widget widget) &key for-width)
+ "Returns (values minimum natural)"
+ (with-foreign-outs ((minimum :int) (natural :int))
+ (if for-width
+ (gtk-widget-get-preferred-height-for-width widget
+ for-width minimum natural)
+ (gtk-widget-get-preferred-height widget minimum natural))))
+
+(defcfun gtk-widget-get-preferred-width :void
+ (widget pobject) (minimum :pointer) (natural :pointer))
+(defcfun gtk-widget-get-preferred-width-for-height :void
+ (widget pobject) (height :int) (minimum :pointer) (natural :pointer))
+
+(defmethod preferred-width ((widget widget) &key for-height)
+ "Returns (values minimum natural)"
+ (with-foreign-outs ((minimum :int) (natural :int))
+ (if for-height
+ (gtk-widget-get-preferred-width-for-height widget
+ for-height minimum natural)
+ (gtk-widget-get-preferred-width widget minimum natural))))
+
+(defcenum size-request-mode
+ :height-for-width :width-for-height)
+
+(defgtkgetter request-mode size-request-mode widget)
+
+(defcfun gtk-widget-get-preferred-size :void
+ (widget pobject) (minimum :pointer) (natural :pointer))
+
+(defmethod preferred-size ((widget widget))
+ "Returns (values minimum natural).
+Minimum and natural are requisition objects."
+ (with-foreign-outs ((minimum 'requisition) (natural 'requisition))
+ (gtk-widget-get-preferred-size widget minimum natural)))
+
+(defcstruct requested-size
+ "GtkRequestedSize"
+ (data pobject)
+ (minimum-size :int)
+ (natural-size :int))
+
+(defcfun gtk-distribute-natural-allocation :int
+ (extra-space :int) (n-requested-sizes :int) (sizes :pointer))
+
+(defun distribute-natural-allocation (extra-space sizes)
+ "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)))
+ (iter
+ (for i from 0 below length)
+ (for x in sizes)
+ (let ((el (mem-aref sizes-struct 'requested-size i)))
+ (with-foreign-slots ((data minimum-size natural-size)
+ el requested-size)
+ (setf data (first x)
+ minimum-size (second x)
+ natural-size (third x)))))
+ (gtk-distribute-natural-allocation extra-space length sizes-struct))))
+
+(defgtkfun queue-compute-expand :void widget)
+(defgtkfun compute-expand :boolean widget (orientation orientation))
(init-slots widget nil)
@@ -340,6 +525,9 @@
(gtk_reserved :pointer :count 8))
(defgtkfun install-style-property :void widget-class (pspec pobject))
+(defgtkfun install-style-property-parser :void widget-class
+ (pspec pobject) (parser pfunction))
+
(defcfun gtk-widget-class-list-style-properties (garray (object g-param-spec))
(widget-class pobject) (n-properties :pointer))
@@ -349,3 +537,11 @@
(gtk-widget-class-list-style-properties widget-class *array-length*)))
+(defgtkfun find-style-property (object g-param-spec)
+ widget-class (name :string))
+
+(g-object-cffi::generate-property-accessors
+ style-property widget
+ nil gtk-widget-style-get-property
+ style-property-type
+ widget-class find-style-property %style-properties)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/menu-item.lisp 2011/08/28 10:30:13 NONE
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/menu-item.lisp 2011/08/28 10:30:13 1.1
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; menu-item.lisp --- GtkMenuItem
;;;
;;; Copyright (C) 2011, Roman Klochkov <kalimehtar at mail.ru>
;;;
(in-package :gtk-cffi)
(defclass menu-item (bin)
())
(defcfun gtk-menu-item-new :pointer)
(defcfun gtk-menu-item-new-with-label :pointer (label gtk-string))
(defcfun gtk-menu-item-new-with-mnemonic :pointer (label gtk-string))
(defmethod gconstructor ((menu-item menu-item)
&key label mnemonic &allow-other-keys)
(if label
(if mnemonic
(gtk-menu-item-new-with-mnemonic label)
(gtk-menu-item-new-with-label label))
(gtk-menu-bar-new)))
(defgtkslots menu-item
right-justified :boolean
label gtk-string
use-underline :boolean
submenu pobject
accel-path gtk-string
reserve-indicator :boolean)
(defgtkfun select :void menu-item)
(defgtkfun deselect :void menu-item)
(defgtkfun activate :void menu-item)
(defgtkfun toggle-size-request :void menu-item (requisition :pointer))
(defgtkfun toggle-size-allocate :void menu-item (allocation :int))
(init-slots menu-item nil)
More information about the gtk-cffi-cvs
mailing list