From 15880ea8e5d76fdebf6386d0d654b45bad5e1334 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 5 Aug 2010 14:39:12 -0400 Subject: [PATCH] Implement GTK-native file selector --- collects/mred/private/filedialog.rkt | 8 +- collects/mred/private/wx/gtk/procs.rkt | 97 ++++++++++++++++++++++++- collects/mred/private/wx/gtk/types.rkt | 2 +- collects/mred/private/wx/gtk/utils.rkt | 41 +++++++++++ collects/mred/private/wx/gtk/widget.rkt | 4 + 5 files changed, 147 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index 9babd0879e..5fbe6e3724 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -50,11 +50,13 @@ (string? (cadr p)))) filters)) (raise-type-error who "list of 2-string lists" filters)) + (printf "parent window: ~a ~a\n" parent (and parent (mred->wx parent))) (let* ([std? (memq 'common style)] [style (if std? (remq 'common style) style)]) (if (or std? - #t ; for now, always use the manually constructed dialog - (eq? (system-type) 'unix)) + ;#t ; for now, always use the manually constructed dialog + ;; the platform dialog is only available for Gtk + (not (eq? (system-type) 'unix))) (send (new path-dialog% [put? put?] [dir? dir?] @@ -71,6 +73,8 @@ (let ([s (wx:file-selector message directory filename extension ;; file types: + filters + #; (apply string-append (map (lambda (s) (format "~a|~a|" (car s) (cadr s))) filters)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 0c37c0c2dc..2245c401cf 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -4,8 +4,10 @@ "../../lock.rkt" racket/class racket/draw + racket/match "types.rkt" "utils.rkt" + "widget.rkt" "../common/handlers.rkt") (provide @@ -61,7 +63,6 @@ show-print-setup can-show-print-setup?) - (define-unimplemented special-control-key) (define-unimplemented special-option-key) (define-unimplemented get-color-from-user) @@ -121,7 +122,99 @@ (define (begin-busy-cursor) (as-entry (lambda () (set! busy-count (sub1 busy-count))))) (define-unimplemented is-color-display?) -(define-unimplemented file-selector) + +(define _GtkFileChooserDialog (_cpointer 'GtkFileChooserDialog)) +(define _GtkFileChooser (_cpointer 'GtkFileChooser)) +(define _GtkFileChooserAction + (_enum (list 'open 'save 'select-folder 'create-folder))) + +(define _GtkResponse + (_enum + '(none = -1 + reject = -2 + accept = -3 + delete-event = -4 + ok = -5 + cancel = -6 + close = -7 + yes = -8 + no = -9 + apply = -10 + help = -11) + _fixint)) +(define _GtkDialog (_cpointer 'GtkDialog)) +;; FIXME: really there are varargs here, but we don't need them for +;; our purposes +(define-gtk gtk_file_chooser_dialog_new + (_fun _string (_or-null _GtkWindow) + _GtkFileChooserAction + _string _GtkResponse + _string _GtkResponse + (_or-null _pointer) + -> _GtkFileChooserDialog)) +;; FIXME - should really be _GtkDialog but no subtyping +(define-gtk gtk_dialog_run (_fun _GtkFileChooserDialog -> _int)) +;; FIXME ;; these should really be _GtkFileChooser but no subtyping +(define-gtk gtk_file_chooser_get_filename + (_fun _GtkFileChooserDialog -> _gpath/free)) +(define-gtk gtk_file_chooser_get_filenames + (_fun _GtkFileChooserDialog -> (_GSList _gpath/free))) +(define-gtk gtk_file_chooser_set_current_name + (_fun _GtkFileChooserDialog _path -> _void)) +(define-gtk gtk_file_chooser_set_current_folder + (_fun _GtkFileChooserDialog _path -> _void)) +(define-gtk gtk_file_chooser_set_select_multiple + (_fun _GtkFileChooserDialog _gboolean -> _void)) + +(define _GtkFileFilter (_cpointer 'GtkFileFilter)) +(define-gtk gtk_file_filter_new (_fun -> _GtkFileFilter)) +(define-gtk gtk_file_filter_set_name + (_fun _GtkFileFilter _string -> _void)) +(define-gtk gtk_file_filter_add_pattern + (_fun _GtkFileFilter _string -> _void)) + +(define-gtk gtk_file_chooser_add_filter + (_fun _GtkFileChooserDialog _GtkFileFilter -> _void)) + +(define (file-selector message directory filename + extension ;; always ignored + filters style parent) + (define type (car style)) ;; the rest of `style' is irrelevant on Gtk + (define dlg (gtk_file_chooser_dialog_new + message (and parent (send parent get-gtk)) + (case type + [(dir) 'select-directory] + [(put) 'save] + [else 'open]) + "gtk-cancel" 'cancel + ;; no stock names for "Select" + (case type + [(dir) "Choose"] + [(put) "gtk-save"] + [(get) "gtk-open"] + [(multi) "Choose"]) + 'accept + #f)) + (when (eq? 'multi type) + (gtk_file_chooser_set_select_multiple dlg #t)) + (when filename + (gtk_file_chooser_set_current_name dlg filename)) + (when directory + (gtk_file_chooser_set_current_folder dlg directory)) + (for ([f (in-list filters)]) + (match f + [(list name glob) + (let ([ff (gtk_file_filter_new)]) + (gtk_file_filter_set_name ff name) + (gtk_file_filter_add_pattern ff glob) + (gtk_file_chooser_add_filter dlg ff))])) + (define ans (and (= -3 (gtk_dialog_run dlg)) + (if (eq? type 'multi) + (gtk_file_chooser_get_filenames dlg) + (gtk_file_chooser_get_filename dlg)))) + (gtk_widget_destroy dlg) + ans) + (define (id-to-menu-item i) i) (define-unimplemented get-the-x-selection) (define-unimplemented get-the-clipboard) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 6d2aa48cc2..95103c5b8e 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -111,4 +111,4 @@ [send_event _byte] [area _GdkRectangle] [region _pointer] - [count _int])) \ No newline at end of file + [count _int])) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 5524e5776e..4efd043330 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require ffi/unsafe ffi/unsafe/define + (only-in '#%foreign ctype-c->scheme) "../common/utils.rkt" "types.rkt") @@ -15,6 +16,10 @@ g_object_ref g_object_unref + g_free + _gpath/free + _GSList + g_object_set_data g_object_get_data @@ -77,6 +82,8 @@ (define-gobj g_object_ref (_fun _pointer -> _void)) (define-gobj g_object_unref (_fun _pointer -> _void)) +(define-gobj g_free (_fun _pointer -> _void)) + (define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void)) (define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer)) @@ -115,3 +122,37 @@ (function-ptr handler-proc (_fun #:atomic? #t . args))) (define (connect-name gtk [user-data #f]) (g_signal_connect gtk signal-name handler_function user-data)))) + + +(define _gpath/free + (make-ctype _pointer + path->bytes ; a Racket bytes can be used as a pointer + (lambda (x) + (let ([b (bytes->path (make-byte-string x))]) + (g_free x) + b)))) + +(define-cstruct _g-slist + ([data _pointer] + [next (_or-null _g-slist-pointer)])) + +(define-gobj g_slist_free (_fun _g-slist-pointer -> _void)) +;; This should probably be provided by Racket +(define make-byte-string + (get-ffi-obj 'scheme_make_byte_string #f (_fun _pointer -> _racket))) + +(define (_GSList elem) + (make-ctype (_or-null _g-slist-pointer) + (lambda (l) + (let L ([l l]) + (if (null? l) + #f + (make-g-slist (car l) (L (cdr l)))))) + (lambda (gl) + (begin0 + (let L ([gl gl]) + (if (not gl) + null + (cons ((ctype-c->scheme elem) (g-slist-data gl)) + (L (g-slist-next gl))))) + (g_slist_free gl))))) diff --git a/collects/mred/private/wx/gtk/widget.rkt b/collects/mred/private/wx/gtk/widget.rkt index c8e8ea5450..a836f51686 100644 --- a/collects/mred/private/wx/gtk/widget.rkt +++ b/collects/mred/private/wx/gtk/widget.rkt @@ -13,6 +13,7 @@ gtk_widget_show gtk_widget_hide + gtk_widget_destroy gtk_vbox_new gtk_hbox_new @@ -22,6 +23,9 @@ (define-gtk gtk_widget_show (_fun _GtkWidget -> _void)) (define-gtk gtk_widget_hide (_fun _GtkWidget -> _void)) +(define-gtk gtk_widget_destroy (_fun _pointer -> _void)) + + (define-gtk gtk_vbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_hbox_new (_fun _gboolean _int -> _GtkWidget)) (define-gtk gtk_box_pack_start (_fun _GtkWidget _GtkWidget _gboolean _gboolean _uint -> _void))