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