1#lang racket/base
2(require ffi/unsafe
3         racket/class
4          "../../syntax.rkt"
5          "../../lock.rkt"
6         "item.rkt"
7         "utils.rkt"
8         "types.rkt"
9         "window.rkt"
10         "const.rkt"
11         "pixbuf.rkt"
12         "message.rkt"
13         "../common/event.rkt")
14
15(provide
16 (protect-out button%
17              button-core%))
18
19;; ----------------------------------------
20
21(define-gtk gtk_button_new_with_mnemonic (_fun _string -> _GtkWidget))
22(define-gtk gtk_button_new (_fun -> _GtkWidget))
23(define-gtk gtk_window_set_default (_fun _GtkWidget (_or-null _GtkWidget) -> _void))
24(define-gtk gtk_button_set_label (_fun _GtkWidget _string -> _void))
25(define-gtk gtk_button_set_image (_fun _GtkWidget _GtkWidget -> _void))
26(define-gtk gtk_button_set_image_position (_fun _GtkWidget _int -> _void))
27
28(define GTK_POS_LEFT 0)
29(define GTK_POS_RIGHT 1)
30(define GTK_POS_TOP 2)
31(define GTK_POS_BOTTOM 3)
32
33(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
34(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
35
36(define _GtkSettings (_cpointer 'GtkSettings))
37(define-gtk gtk_settings_get_default (_fun -> _GtkSettings))
38(define-gobj g_object_set/boolean
39  (_fun _GtkSettings _string _gboolean (_pointer = #f) -> _void)
40  #:c-id g_object_set)
41(define (force-button-images-on gtk)
42  ;; Globally turning on button images isn't really the right thing.
43  ;; Is there a way to enable image just for the widget `gtk'?
44  (g_object_set/boolean (gtk_settings_get_default) "gtk-button-images" #t))
45
46(define-signal-handler connect-clicked "clicked"
47  (_fun _GtkWidget -> _void)
48  (lambda (gtk)
49    (let ([wx (gtk->wx gtk)])
50      (when wx
51        (send wx queue-clicked)))))
52
53(defclass button-core% item%
54  (init parent cb label x y w h style font
55        [gtk_new_with_mnemonic gtk_button_new_with_mnemonic]
56        [gtk_new gtk_button_new])
57  (init-field [event-type 'button])
58  (inherit get-gtk get-client-gtk set-auto-size is-window-enabled?
59           get-window-gtk)
60
61  (super-new [parent parent]
62             [gtk (cond
63                   [(or (string? label) (not label))
64                    (as-gtk-allocation
65                     (gtk_new_with_mnemonic (or (mnemonic-string label) "")))]
66                   [else
67                    (let ([pixbuf (bitmap->pixbuf (if (pair? label)
68                                                      (car label)
69                                                      label)
70						  (->screen 1.0))])
71                      (atomically
72                       (let ([gtk (if (pair? label)
73                                      (as-gtk-allocation (gtk_new_with_mnemonic (cadr label)))
74                                      (as-gtk-allocation (gtk_new)))]
75                             [image-gtk (gtk_image_new_from_pixbuf pixbuf)])
76                         (release-pixbuf pixbuf)
77                         (if (pair? label)
78                             (begin
79			       (force-button-images-on gtk)
80			       (gtk_button_set_image gtk image-gtk)
81                               (gtk_button_set_image_position
82                                gtk
83                                (case (caddr label)
84                                  [(left) GTK_POS_LEFT]
85                                  [(right) GTK_POS_RIGHT]
86                                  [(top) GTK_POS_TOP]
87                                  [(bottom) GTK_POS_BOTTOM])))
88                             (begin
89                               (gtk_container_add gtk image-gtk)
90                               (gtk_widget_show image-gtk)))
91                         gtk)))])]
92             [callback cb]
93             [font font]
94             [no-show? (memq 'deleted style)])
95  (define gtk (get-gtk))
96
97  (define both-labels? (pair? label))
98
99  (when (eq? event-type 'button)
100    (gtk_widget_set_can_default gtk #t))
101
102  (set-auto-size)
103
104  (connect-clicked gtk)
105
106  (when (memq 'border style) (set-border #t))
107
108  (define callback cb)
109  (define/public (clicked)
110    (when (is-window-enabled?)
111      (callback this (new control-event%
112                          [event-type event-type]
113                          [time-stamp (current-milliseconds)]))))
114  (define/public (queue-clicked)
115    ;; Called from event-handling thread
116    (queue-window-event this (lambda () (clicked))))
117
118  (define/override (get-label-gtk)
119    (gtk_bin_get_child (get-client-gtk)))
120
121  (define the-font font)
122  (define/override (set-label s)
123    (cond
124     [(string? s)
125      (gtk_button_set_label gtk (mnemonic-string s))
126      (when the-font (install-control-font (get-label-gtk) the-font))]
127     [else
128      (let ([pixbuf (bitmap->pixbuf s (->screen 1.0))])
129        (atomically
130         (let ([image-gtk (gtk_image_new_from_pixbuf pixbuf)])
131           (release-pixbuf pixbuf)
132           (if both-labels?
133               (gtk_button_set_image gtk image-gtk)
134               (begin
135                 (gtk_container_remove gtk (gtk_bin_get_child gtk))
136                 (gtk_container_add gtk image-gtk)
137                 (gtk_widget_show image-gtk))))))]))
138
139  (define/public (set-border on?)
140    (gtk_window_set_default (get-window-gtk) (if on? gtk #f))))
141
142(defclass button% button-core%
143  (super-new))
144
145