source: project/release/3/gtk2/trunk/gtk2.scm @ 9932

Last change on this file since 9932 was 9932, checked in by Kon Lovett, 12 years ago

Rel 0.311 w/ Explict use of SRFI 69.

File size: 22.2 KB
Line 
1;;@title "GTK+ 2.0 binding"
2; Copyright (c) 2002-2007 Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
3;
4; Permission is hereby granted, free of charge, to any person obtaining a copy of this
5; software and associated documentation files (the "Software"), to deal in the Software
6; without restriction, including without limitation the rights to use, copy, modify,
7; merge, publish, distribute, sublicense, and/or sell copies of the Software, and to
8; permit persons to whom the Software is furnished to do so, subject to the following
9; conditions:
10;
11; The above copyright notice and this permission notice shall be included in all copies
12; or substantial portions of the Software.
13;
14; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,
15; INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
16; PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE
17; FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
18; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
19; DEALINGS IN THE SOFTWARE.
20(declare
21 (usual-integrations))
22(declare (foreign-declare #<<EOF
23
24#include <gtk/gtk.h>
25
26static void CG_collect_stringlist(C_word k, GSList *head, GSList *curr, C_word acc) {
27   if (curr == NULL) {
28     g_slist_free(head);
29     C_kontinue(k, acc);
30   } else {
31     int len = strlen((gchar const *) curr->data);
32     C_word space[C_SIZEOF_PAIR + C_SIZEOF_STRING(len)];
33     C_word *a = space;
34     C_word s = C_string(&a, len, (gchar *) curr->data);
35     g_free(curr->data);
36     CG_collect_stringlist(k, head, curr->next, C_pair(&a, s, acc));
37   }
38}
39
40static void CG_stock_list_ids(C_word argc, C_word self, C_word k) {
41   GSList *l = gtk_stock_list_ids();
42   CG_collect_stringlist(k, l, l, C_SCHEME_END_OF_LIST);
43}
44
45EOF
46))
47
48;;@ <synopsis>(require 'gtk2)</synopsis>
49;; The gtk extension module provides a wrapping for the GTK+ GUI
50;; toolkit library, version 2.0. It depends upon the gobject
51;; extension.
52
53;---------------------------------------------------------------------------;
54;;@section "General"
55
56;;@ Most of the functions supported by the GTK+ binding extension are
57;; automatically generated from <filename>*.defs</filename> files,
58;; taken from James Henstridge's <application>pygtk</application> GTK+
59;; binding for Python.
60;;
61;; The generated code is contained in internal modules which don't
62;; need to be <function>require</function>d separately - they're
63;; automatically included when the gtk2 module is loaded. Some of the
64;; generated code is not a good fit for Chicken, so it has been
65;; overridden by hand-written code<footnote><para>Isn't it nice having
66;; procedures in mutable global variables?</para></footnote> in the
67;; gtk2 module itself.
68;;
69;; Generated procedures usually have a name derived from the name of
70;; the C function they are wrapping: case is folded to lowercase, and
71;; underscores are replaced with hyphens, so for instance
72;; <literal>gtk_main_quit</literal> becomes
73;; <literal>gtk-main-quit</literal>.
74;;
75;; Methods on wrapped <classname>GtkObject</classname> subclasses are
76;; registered with the introspection facilities of the gobject module
77;; with calls to <function>gobject:register-method!</function>.
78
79(require 'gtk2-gobject)
80(require-for-syntax 'gtk2-gobject)
81
82(require 'srfi-4)
83(require 'srfi-69)
84
85(include "gobject-macros.scm")
86
87((foreign-safe-lambda* void ()
88                  "int argc = 1;"
89                  "char *argv[] = { \"gtkchicken\" , NULL };"
90                  "char **argv_p = &argv[0];"
91                  "gtk_init(&argc, &argv_p);"))
92
93;;(gtype:init-types-from-file "gdk-types")
94;;(gtype:init-types-from-file "gtk-types")
95
96(gtype:init-types-from-file "gdk-types-00")
97(gtype:init-types-from-file "gdk-types-01")
98
99(gtype:init-types-from-file "gtk-types-00")
100(gtype:init-types-from-file "gtk-types-01")
101(gtype:init-types-from-file "gtk-types-02")
102(gtype:init-types-from-file "gtk-types-03")
103(gtype:init-types-from-file "gtk-types-04")
104
105;;@function (gtk-signal-connect object signal-name handler-fn)
106;;An alias for <function>gsignal-connect</function>.
107(define gtk-signal-connect gsignal-connect)
108
109(require "gtk2/wrap-boxed")
110(require "gtk2/wrap-classes")
111(require "gtk2/wrap-enum")
112(require "gtk2/wrap-flags")
113(require "gtk2/wrap-functions")
114
115(require "gtk2/gdkevent")
116
117;; Override entry points to allow callbacks.
118
119;;@function (gtk-main)
120;;Pass control to the GTK+ main loop. This call does not return until
121;;the application indicates it is ready to terminate by calling
122;;<function>gtk-main-quit</function>.
123(define gtk-main
124  (foreign-safe-lambda void "gtk_main"))
125
126;;@function (gtk-main-iteration)
127;;Delegates directly to the C function
128;;<function>gtk_main_iteration</function>.
129(define gtk-main-iteration
130  (foreign-safe-lambda bool "gtk_main_iteration"))
131
132;---------------------------------------------------------------------------;
133;;@section "Timeouts, idle-handlers, and input-handlers"
134;;Input handlers are not currently supported.
135
136(define-record gtk:gtkfunction number kind thunk)
137
138(define gtk:gtkfunctions-freelist '())
139(define gtk:next-gtkfunction 1)
140(define gtk:gtkfunctions (make-hash-table =))
141(define gtk:timeout-handlers (make-hash-table =))
142(define gtk:idle-handlers (make-hash-table =))
143
144(define (gtk:reserve-function-number)
145  (if (null? gtk:gtkfunctions-freelist)
146      (let ((n gtk:next-gtkfunction))
147        (set! gtk:next-gtkfunction (+ n 1))
148        n)
149      (let ((n gtk:gtkfunctions-freelist))
150        (set! gtk:gtkfunctions-freelist (cdr n))
151        (car n))))
152
153(define (gtk:release-function-number n)
154  (set! gtk:gtkfunctions-freelist (cons n gtk:gtkfunctions-freelist)))
155
156(define-external (cg_gtk_function (c-pointer data))
157  bool
158  (let* ((n (gobject:gpointer-to-uint data))
159         (f (hash-table-ref/default gtk:gtkfunctions n #f)))
160    (if f
161        ((gtk:gtkfunction-thunk f))
162        (begin
163          (g-warning "cg_gtk_function: unknown callback number: " n)
164          #f))))
165
166(define-record gtk:timeout-handle number)
167(define-record-printer (gtk:timeout-handle h out)
168  (for-each (lambda (x) (display x out))
169            (list "#<gtk:timeout-handle " (gtk:timeout-handle-number h) ">")))
170
171;;@ Installs a timeout-handling procedure. After
172;;<parameter>interval</parameter> milliseconds, and every
173;;<parameter>interval</parameter> thereafter,
174;;<parameter>thunk</parameter> will be called with no arguments. If
175;;<parameter>thunk</parameter> returns <literal>#f</literal>, the
176;;timeout-handler will not run again (it will be removed). The
177;;semantics are derived from the underlying C procedure,
178;;<function>gtk_timeout_add</function>. This function returns a
179;;<structname>gtk:timeout-handle</structname> record, which can be
180;;passed in to <function>gtk-timeout-remove</function>.
181(define (gtk-timeout-add interval thunk)
182  (let* ((n (gtk:reserve-function-number))
183         (f (make-gtk:gtkfunction n 'timeout thunk)))
184    (hash-table-set! gtk:gtkfunctions n f)
185    (let ((h ((foreign-safe-lambda* unsigned-integer ((unsigned-integer interval)
186                                                 (unsigned-integer data))
187                               "return(gtk_timeout_add(interval, (GtkFunction) cg_gtk_function,"
188                               "                       GUINT_TO_POINTER(data)));")
189              interval
190              n)))
191      (hash-table-set! gtk:timeout-handlers h f)
192      (make-gtk:timeout-handle h))))
193
194;;@ Removes a previously-registered timeout handler, using a
195;;<structname>gtk:timeout-handle</structname> record returned by
196;;<function>gtk-timeout-add</function>.
197(define (gtk-timeout-remove handle)
198  (let* ((h (gtk:timeout-handle-number handle))
199         (f (hash-table-ref/default gtk:timeout-handlers h #f)))
200    (if (not f)
201        (error "gtk-timeout-remove: not found" handle)
202        (begin
203          (assert (eq? 'timeout (gtk:gtkfunction-kind f)))
204          ((foreign-safe-lambda void "gtk_timeout_remove" unsigned-integer) h)
205          (hash-table-delete! gtk:timeout-handlers h)
206          (hash-table-delete! gtk:gtkfunctions (gtk:gtkfunction-number f))
207          (gtk:release-function-number (gtk:gtkfunction-number f))))))
208
209(define-record gtk:idle-handle number)
210(define-record-printer (gtk:idle-handle h out)
211  (for-each (lambda (x) (display x out))
212            (list "#<gtk:idle-handle " (gtk:idle-handle-number h) ">")))
213
214;;@ Installs <parameter>thunk</parameter> as a GTK+ idle handler, as
215;;per the C function <function>gtk_idle_add</function>. Returns a
216;;<structname>gtk:idle-handle</structname> record, which may be used
217;;with <function>gtk-idle-remove</function>.
218(define (gtk-idle-add thunk)
219  (let* ((n (gtk:reserve-function-number))
220         (f (make-gtk:gtkfunction n 'idle thunk)))
221    (hash-table-set! gtk:gtkfunctions n f)
222    (let ((h ((foreign-safe-lambda* unsigned-integer ((unsigned-integer data))
223                               "return(gtk_idle_add((GtkFunction) cg_gtk_function,"
224                               "                    GUINT_TO_POINTER(data)));")
225              n)))
226      (hash-table-set! gtk:idle-handlers h f)
227      (make-gtk:idle-handle h))))
228
229;;@ Removes a previously installed GTK+ idle handler, using the
230;;<structname>gtk:idle-handle</structname> record returned from
231;;<function>gtk-idle-add</function>.
232(define (gtk-idle-remove handle)
233  (let* ((h (gtk:idle-handle-number handle))
234         (f (hash-table-ref/default gtk:idle-handlers h #f)))
235    (if (not f)
236        (error "gtk-idle-remove: not found" handle)
237        (begin
238          (assert (eq? 'idle (gtk:gtkfunction-kind f)))
239          ((foreign-safe-lambda void "gtk_idle_remove" unsigned-integer) h)
240          (hash-table-delete! gtk:idle-handlers h)
241          (hash-table-delete! gtk:gtkfunctions (gtk:gtkfunction-number f))
242          (gtk:release-function-number (gtk:gtkfunction-number f))))))
243
244;---------------------------------------------------------------------------;
245;;@section "GDK"
246
247;;@ Return a list (R G B) of the three colour components contained in
248;;a <structname>GdkColor</structname> structure.
249(define gdk-color->list
250  (let ((color-r (foreign-safe-lambda* int (((pointer "GdkColor") c)) "return(c->red);"))
251        (color-g (foreign-safe-lambda* int (((pointer "GdkColor") c)) "return(c->green);"))
252        (color-b (foreign-safe-lambda* int (((pointer "GdkColor") c)) "return(c->blue);")))
253    (lambda (c)
254      (let ((p (gboxed-pointer c)))
255        (list (color-r p)
256              (color-g p)
257              (color-b p))))))
258
259(gobject:register-method! "GdkColor"
260                          '->list
261                          'gdk-color->list
262                          gdk-color->list)
263
264;;@ Convert a list (R G B) into a <structname>GdkColor</structname>
265;;boxed object.
266(define list->gdk-color
267  (let ((t (gtype-from-name "GdkColor")))
268    (lambda (l)
269      (wrap-gboxed t
270                   (apply (foreign-safe-lambda* c-pointer ((int r) (int g) (int b))
271                                           "GdkColor c;"
272                                           "c.red = r;"
273                                           "c.green = g;"
274                                           "c.blue = b;"
275                                           "return(gdk_color_copy(&c));")
276                          l)
277                   #f))))
278
279;;@ Extract the pixel value from a <structname>GdkColor</structname>
280;;structure.
281(define gdk-color-pixel
282  (let ((color-p (foreign-safe-lambda* int (((pointer "GdkColor") c)) "return(c->pixel);")))
283    (lambda (c)
284      (color-p (gboxed-pointer c)))))
285
286(gobject:register-method! "GdkColor"
287                          'pixel
288                          'gdk-color-pixel
289                          gdk-color-pixel)
290
291;;@ Update the pixel value within a <structname>GdkColor</structname>
292;;structure.
293(define gdk-color-pixel-set!
294  (let ((color-p (foreign-safe-lambda* void (((pointer "GdkColor") c)
295                                        (int p))
296                                  "c->pixel = p;")))
297    (lambda (color newpixel)
298      (color-p (gboxed-pointer color) newpixel)
299      newpixel)))
300
301(gobject:register-method! "GdkColor"
302                          'pixel
303                          'gdk-color-pixel-set!
304                          gdk-color-pixel-set!)
305
306;;@ Convert a <structname>GdkRectangle</structname> into a list (x y
307;;width height).
308(define gdk-rectangle->list
309  (let ((gx (foreign-safe-lambda* integer (((pointer "GdkRectangle") p)) "return(p->x);"))
310        (gy (foreign-safe-lambda* integer (((pointer "GdkRectangle") p)) "return(p->y);"))
311        (gw (foreign-safe-lambda* integer (((pointer "GdkRectangle") p)) "return(p->width);"))
312        (gh (foreign-safe-lambda* integer (((pointer "GdkRectangle") p)) "return(p->height);")))
313    (lambda (r)
314      (let ((p (gboxed-pointer r)))
315        (list (gx p)
316              (gy p)
317              (gw p)
318              (gh p))))))
319
320(gobject:register-method! "GdkRectangle"
321                          '->list
322                          'gdk-rectangle->list
323                          gdk-rectangle->list)
324
325;;@ Convert a list (x y width height) into a
326;;<structname>GdkRectangle</structname> boxed object.
327(define list->gdk-rectangle
328  (let ((t (gtype-from-name "GdkRectangle")))
329    (lambda (l)
330      (wrap-gboxed t
331                   (apply (foreign-safe-lambda* c-pointer ((integer x) (integer y)
332                                                      (integer w) (integer h))
333                                           "static GType r_t = 0;"
334                                           "GdkRectangle r;"
335                                           "if (r_t == 0)"
336                                           "  r_t = g_type_from_name(\"GdkRectangle\");"
337                                           "r.x = x;"
338                                           "r.y = y;"
339                                           "r.width = w;"
340                                           "r.height = h;"
341                                           "return(g_boxed_copy(r_t, &r));")
342                          l)
343                   #f))))
344
345;;@ Returns multiple values: (x y state), where x and y make up the
346;;current pointer coordinate, and state is a list of GdkModifierType
347;;symbols.
348(define (gdk-window-get-pointer w)
349  (let ((v (make-s32vector 3)))
350    ((foreign-safe-lambda* void (((pointer "GdkWindow") w)
351                            (s32vector v))
352                      "int x, y;"
353                      "GdkModifierType state;"
354                      "gdk_window_get_pointer(w, &x, &y, &state);"
355                      "v[0] = x;"
356                      "v[1] = y;"
357                      "v[2] = (int) state;")
358     (g:unbox-GdkWindow w)
359     v)
360    (values (s32vector-ref v 0)
361            (s32vector-ref v 1)
362            (number->GdkModifierType (s32vector-ref v 2)))))
363
364(gobject:register-method! "GdkWindow"
365                          'get-pointer
366                          'gdk-window-get-pointer
367                          gdk-window-get-pointer)
368
369;---------------------------------------------------------------------------;
370; Fill in some missing methods, and override some inappropriately-wrapped methods.
371;;@section "Miscellaneous and overridden procedures"
372
373;;@function (gtk:gc-idle-timeout (#:optional value))
374;; If <parameter>value</parameter> is omitted, returns the current
375;; setting for the number of milliseconds of GTK idleness before a GC
376;; is forced; otherwise, sets the setting to the passed-in number of
377;; milliseconds. Only used when <function>gtk:gc-when-idle</function>
378;; has been enabled. Defaults to 1000 milliseconds.
379(define gtk:gc-idle-timeout (make-parameter 1000))
380
381;;@function (gtk:gc-when-idle (#:optional value))
382;; If <parameter>value</parameter> is omitted, returns
383;; <literal>#t</literal> if the GTK-idle-garbage-collector is enabled,
384;; or <literal>#f</literal> otherwise. If <parameter>value</parameter>
385;; is specified, enables the idle-garbage-collector unless
386;; <parameter>value</parameter> is <literal>#f</literal>. Defaults to
387;; being switched off.
388(define gtk:gc-when-idle
389  (let ((id #f)
390        (gc-idler (lambda ()
391                    (let loop ((collected #f))
392                      (when (zero? (gtk-events-pending))
393                        (if collected
394                            (begin
395                              (gtk-main-iteration)
396                              (loop #f))
397                            (let* ((gc-ran #f)
398                                   (id (gtk-timeout-add
399                                        (gtk:gc-idle-timeout)
400                                        (lambda ()
401;                                           (print* "(gc...") (flush-output) (time
402                                          (gc #t)
403;                                            ) (print "done)")
404                                          (set! gc-ran #t)
405                                          #f))))
406                              (gtk-main-iteration)
407                              (gtk-timeout-remove id)
408                              (loop gc-ran))))))))
409    (lambda arg
410      (if (pair? arg)
411          (if (car arg)
412              (if id
413                  #f
414                  (begin
415                    (set! id (gtk-idle-add gc-idler))
416                    #t))
417              (if id
418                  (begin
419                    (gtk-idle-remove id)
420                    (set! id #f)
421                    #t)
422                  #f))
423          (if id #t #f)))))
424
425;;@ Retrieve the date selected by a <classname>GtkCalendar</classname>
426;;widget, in the form of a list of three numbers, year, month, day:
427;;<literal>(2002 10 13)</literal>.
428(define (gtk-calendar-get-date cal)
429  (u32vector->list
430   (let ((u (make-u32vector 3)))
431     ((foreign-safe-lambda* void ((c-pointer cal)
432                             (u32vector u))
433                       "gtk_calendar_get_date(cal, &u[0], &u[1], &u[2]);")
434      (g:unbox-GtkCalendar cal)
435      u)
436     u)))
437
438;;@function (gtk-stock-list-ids)
439;;Returns a list of all current GTK+ <quote>stock ID</quote> strings.
440(define gtk-stock-list-ids (##core#primitive "CG_stock_list_ids"))
441
442;;@ Allocates a new instance of <classname>GtkTreeIter</classname>,
443;;for use with various GTK+ tree model and view functions.
444(define gtk-tree-iter-new
445  (let ((t (gtype-from-name "GtkTreeIter")))
446    (lambda ()
447      (wrap-gboxed t
448                   ((foreign-safe-lambda* c-pointer ()
449                                     "GtkTreeIter *r = g_new0(GtkTreeIter, 1);"
450                                     "return(r);"))
451                   #f))))
452
453;;@ Creates and returns a new instance of
454;;<classname>GtkListStore</classname> with the same number of columns
455;;as parameters to the function call. Each parameter should be a
456;;<structname>gtype</structname> record (as returned by
457;;<function>gtype-from-name</function>, for example, or as stored in
458;;variables such as <varname>gtype:string</varname> or
459;;<varname>gtype:boolean</varname>).
460(define (gtk-list-store-new . coltypes)
461  (let ((ctvec (list->u32vector (map gtype-number coltypes))))
462    (wrap-gobject
463     ((foreign-safe-lambda* c-pointer ((integer n)
464                                  (u32vector v))
465                       "return(gtk_list_store_newv(n, (GType*) v));")
466      (u32vector-length ctvec)
467      ctvec))))
468
469;;@ Creates and returns a new instance of
470;;<classname>GtkTreeStore</classname> with the same number of columns
471;;as parameters to the function call. Each parameter should be a
472;;<structname>gtype</structname> record, as for
473;;<function>gtk-list-store-new</function>.
474(define (gtk-tree-store-new . coltypes)
475  (let ((ctvec (list->u32vector (map gtype-number coltypes))))
476    (wrap-gobject
477     ((foreign-safe-lambda* c-pointer ((integer n)
478                                  (u32vector v))
479                       "return(gtk_tree_store_newv(n, (GType*) v));")
480      (u32vector-length ctvec)
481      ctvec))))
482
483;;@ Sets the number and type of columns associated with the
484;;<classname>GtkListStore</classname>
485;;<parameter>l</parameter>. <parameter>coltypes</parameter> are as for
486;;<function>gtk-list-store-new</function>.
487(define (gtk-list-store-set-column-types l . coltypes)
488  (let ((ctvec (list->u32vector (map gtype-number coltypes))))
489    ((foreign-safe-lambda* void ((c-pointer l)
490                            (integer n)
491                            (u32vector v))
492                      "gtk_list_store_set_column_types(GTK_LIST_STORE(l), n, (GType*) v);")
493     (gobject-pointer l)
494     (u32vector-length ctvec)
495     ctvec)))
496
497;;@ Sets the number and type of columns associated with the
498;;<classname>GtkTreeStore</classname>
499;;<parameter>t</parameter>. <parameter>coltypes</parameter> are as for
500;;<function>gtk-tree-store-new</function>.
501(define (gtk-tree-store-set-column-types t . coltypes)
502  (let ((ctvec (list->u32vector (map gtype-number coltypes))))
503    ((foreign-safe-lambda* void ((c-pointer t)
504                            (integer n)
505                            (u32vector v))
506                      "gtk_tree_store_set_column_types(GTK_TREE_STORE(t), n, (GType*) v);")
507     (gobject-pointer t)
508     (u32vector-length ctvec)
509     ctvec)))
510
511;;@ Stores the currently-selected row of the
512;;<classname>GtkTreeSelection</classname> <parameter>sel</parameter>
513;;(single-row-selection mode only) into the
514;;<classname>GtkTreeIter</classname> <parameter>iter</parameter>. If
515;;there is no current selection, <literal>#f</literal> is returned;
516;;otherwise, the associated <classname>GtkTreeModel</classname> is
517;;returned.
518(define (gtk-tree-selection-get-selected sel iter)
519  (wrap-gobject
520   ((foreign-safe-lambda* c-pointer ((c-pointer sel)
521                                (c-pointer iter))
522                     "GtkTreeModel *model = NULL;"
523                     "gboolean result = gtk_tree_selection_get_selected((GtkTreeSelection*)sel,"
524                     "                                                  &model,"
525                     "                                                  (GtkTreeIter*)iter);"
526                     "return(result ? model : NULL);")
527    (gobject-pointer sel)
528    (gboxed-pointer iter))))
529
530;;@ Extracts the <structfield>window</structfield> field of the
531;;<structname>GtkWidget</structname> struct associated with the
532;;passed-in object.
533(define gtk-widget-window
534  (let ((ww (foreign-safe-lambda* c-pointer (((pointer "GtkWidget") w))
535                             "return(w->window);")))
536    (lambda (w)
537      (wrap-gobject (ww (gobject-pointer w))))))
538
539(gobject:register-method! "GtkWidget"
540                          'window
541                          'gtk-widget-window
542                          gtk-widget-window)
543
544;;@ Extracts the <structfield>allocation</structfield> field of the
545;;<structname>GtkWidget</structname> struct associated with the
546;;passed-in object.
547(define gtk-widget-allocation
548  (let ((wa (foreign-safe-lambda* c-pointer (((pointer "GtkWidget") w))
549                             "return(&(w->allocation));")))
550    (lambda (w)
551      (g:box-GdkRectangle (wa (gobject-pointer w))))))
552
553(gobject:register-method! "GtkWidget"
554                          'allocation
555                          'gtk-widget-allocation
556                          gtk-widget-allocation)
557
558;;@ Extracts the <structfield>state</structfield> field of the
559;;<structname>GtkWidget</structname> struct associated with the
560;;passed-in object, and returns it in symbolic form.
561(define (gtk-widget-get-state w)
562  (number->GtkStateType
563   ((foreign-safe-lambda int "GTK_WIDGET_STATE" (pointer "GtkWidget"))
564    (gobject-pointer w))))
565
566(gobject:register-method! "GtkWidget"
567                          'get-state
568                          'gtk-widget-get-state
569                          gtk-widget-get-state)
570
571;;@ Retrieves the black GC from the passed-in style.
572(define (gtk-style-black-gc style)
573  (assert (GtkStyle? style))
574  (g:box-GdkGC
575   ((foreign-safe-lambda* c-pointer (((pointer "GtkStyle") style))
576                     "return(style->black_gc);")
577    (gobject-pointer style))))
578
579(gobject:register-method! "GtkStyle"
580                          'black-gc
581                          'gtk-style-black-gc
582                          gtk-style-black-gc)
583
584;;@ Retrieves the white GC from the passed-in style.
585(define (gtk-style-white-gc style)
586  (assert (GtkStyle? style))
587  (g:box-GdkGC
588   ((foreign-safe-lambda* c-pointer (((pointer "GtkStyle") style))
589                     "return(style->white_gc);")
590    (gobject-pointer style))))
591
592(gobject:register-method! "GtkStyle"
593                          'white-gc
594                          'gtk-style-white-gc
595                          gtk-style-white-gc)
596
597;;@ Retrieves the foreground GC from the passed-in style that is
598;;appropriate to the passed-in GtkStateType symbol.
599(define (gtk-style-fg-gc style state)
600  (assert (GtkStyle? style))
601  (g:box-GdkGC
602   ((foreign-safe-lambda* c-pointer (((pointer "GtkStyle") style)
603                                (int state))
604                     "return(style->fg_gc[state]);")
605    (gobject-pointer style)
606    (GtkStateType->number state))))
607
608(gobject:register-method! "GtkStyle"
609                          'fg-gc
610                          'gtk-style-fg-gc
611                          gtk-style-fg-gc)
612
613;;@ Inserts text <parameter>string</parameter> at the
614;;<parameter>position</parameter> passed in. Returns the new insertion
615;;position after the insert operation.
616(define (gtk-editable-insert-text editable string position)
617  ((foreign-safe-lambda* integer (((pointer "GtkEditable") e)
618                             (byte-vector bv)
619                             (unsigned-integer len)
620                             (integer in_pos))
621                    "gint pos = in_pos;"
622                    "gtk_editable_insert_text(e, (gchar const *) bv, len, &pos);"
623                    "return(pos);")
624   (g:unbox-GtkEditable editable)
625   (if (string? string)
626       (string->byte-vector string)
627       string)
628   (if (string? string)
629       (string-length string)
630       (byte-vector-length string))
631   position))
Note: See TracBrowser for help on using the repository browser.