From b6ab1cc72291db1dfa138a6249f72e2845fcd458 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sat, 25 Feb 2017 18:12:54 -0700 Subject: [PATCH] glib: Use bytevectors instead of strings. --- src/glib/gio.scm | 77 ++++++++++++++++++++++------------------- src/glib/glib-tests.scm | 2 +- src/glib/gobject.scm | 23 ++++++------ 3 files changed, 56 insertions(+), 46 deletions(-) diff --git a/src/glib/gio.scm b/src/glib/gio.scm index 588bb898d..15b3265c6 100644 --- a/src/glib/gio.scm +++ b/src/glib/gio.scm @@ -318,7 +318,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (begin (C->= pointer "* GError" 0) (C-call "g_error_free" gerror))) - message)) + (utf8->string message))) (define-integrable (%queue! queue value) ;; The GIO finish callbacks use this procedure to queue a value on a @@ -726,7 +726,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (cleanup-gio gio-info))) (define (gfile-query-info gfile attributes follow-symlinks?) - (guarantee-string attributes 'gfile-query-info) + (guarantee string? attributes 'gfile-query-info) (gfile-open gfile 'QUERY make-gfile-info (named-lambda (query-callout @@ -758,7 +758,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%queue! queue #t)))))) (define (gfile-info-list-attributes ginfo namespace) - (guarantee-string namespace 'gfile-info-list-attributes) + (guarantee string? namespace 'gfile-info-list-attributes) (map! string->symbol (let ((alien (make-cstringv (lambda (copy) @@ -771,7 +771,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gfile-info-get-attribute-status ginfo name) (let ((code (C-call "g_file_info_get_attribute_status" (gobject-alien ginfo) - name))) + (string->utf8 name)))) (cond ((fix:= code (C-enum "G_FILE_ATTRIBUTE_STATUS_UNSET")) 'unset) ((fix:= code (C-enum "G_FILE_ATTRIBUTE_STATUS_SET")) 'set) ((fix:= code (C-enum "G_FILE_ATTRIBUTE_STATUS_ERROR_SETTING")) @@ -780,35 +780,38 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gfile-info-get-attribute-value ginfo name) (let* ((alien (gobject-alien ginfo)) - (type (C-call "g_file_info_get_attribute_type" alien name))) + (name-bv (string->utf8 name)) + (type (C-call "g_file_info_get_attribute_type" alien name-bv))) (cond ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_INVALID")) (error "Invalid attribute:" name)) ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_STRING")) - (c-peek-cstring - (C-call "g_file_info_get_attribute_string" - (make-alien 'char) alien name))) + (utf8->string + (c-peek-cstring + (C-call "g_file_info_get_attribute_string" + (make-alien 'char) alien name-bv)))) ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_BYTE_STRING")) - (c-peek-cstring - (C-call "g_file_info_get_attribute_byte_string" - (make-alien 'uchar) alien name))) + (utf8->string + (c-peek-cstring + (C-call "g_file_info_get_attribute_byte_string" + (make-alien 'uchar) alien name-bv)))) ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_BOOLEAN")) (not (fix:zero? - (C-call "g_file_info_get_attribute_boolean" alien name)))) + (C-call "g_file_info_get_attribute_boolean" alien name-bv)))) ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_UINT32")) - (C-call "g_file_info_get_attribute_uint32" alien name)) + (C-call "g_file_info_get_attribute_uint32" alien name-bv)) ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_INT32")) - (C-call "g_file_info_get_attribute_int32" alien name)) + (C-call "g_file_info_get_attribute_int32" alien name-bv)) ; ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_UINT64")) -; (C-call "g_file_info_get_attribute_uint64" alien name)) +; (C-call "g_file_info_get_attribute_uint64" alien name-bv)) ; ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_INT64")) -; (C-call "g_file_info_get_attribute_int64" alien name)) +; (C-call "g_file_info_get_attribute_int64" alien name-bv)) ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_OBJECT")) (C-call "g_file_info_get_attribute_object" - (make-alien '|GObject|) alien name)) + (make-alien '|GObject|) alien name-bv)) ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_STRINGV")) (peek-cstringv (C-call "g_file_info_get_attribute_stringv" - (make-alien '(* (const char))) alien name))) + (make-alien '(* (const char))) alien name-bv))) (else (error "Unexpected GFileAttributeType:" type))))) (define-class ( (constructor ())) @@ -850,14 +853,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (loop)))))) (define (gfile-enumerate-children gfile attributes follow-symlinks?) - (guarantee-string attributes 'gfile-enumerate-children) + (guarantee string? attributes 'gfile-enumerate-children) (gfile-open gfile 'OPEN make-gfile-enumerator (named-lambda (query-callout gfile* priority gcancellable* callback id) (C-call "g_file_enumerate_children_async" gfile* - attributes + (string->utf8 attributes) (if follow-symlinks? (C-enum "G_FILE_QUERY_INFO_NONE") (C-enum "G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS")) @@ -884,7 +887,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%queue! queue #t)))))) (define (gfile-enumerator-next-files genum nfiles) - (guarantee-fixnum nfiles 'gfile-enumerator-next-files) + (guarantee fixnum? nfiles 'gfile-enumerator-next-files) (let* ((gio-info (gio-cleanup-info genum)) (callback-id (gio-cleanup-info-callback-id gio-info))) (guarantee-gio-idle genum) @@ -1011,7 +1014,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-call "g_mount_operation_set_anonymous" alien 1) (set-g-mount-operation-username! gmountop "anonymous")) (begin - (C-call "g_mount_operation_set_username" alien userinfo) + (C-call "g_mount_operation_set_username" + alien (string->utf8 userinfo)) (set-g-mount-operation-username! gmountop userinfo))))) (attach-mount-signal-handlers gmountop gfile) (let retry () @@ -1057,17 +1061,17 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-g-mount-operation-username! alien "anonymous"))) (if (memq 'NEED-DOMAIN flags) (let ((d (prompt-for-string* "Domain" domain port))) - (C-call "g_mount_operation_set_domain" alien d) + (C-call "g_mount_operation_set_domain" alien (string->utf8 d)) (set-g-mount-operation-domain! gmountop d))) (if (memq 'NEED-USERNAME flags) (let ((u (prompt-for-string* "Username" username port))) - (C-call "g_mount_operation_set_username" alien u) + (C-call "g_mount_operation_set_username" alien (string->utf8 u)) (set-g-mount-operation-username! gmountop u))) (if (memq 'NEED-PASSWORD flags) (call-with-pass-phrase "Password" (lambda (phrase) - (C-call "g_mount_operation_set_password" alien phrase)))) + (C-call "g_mount_operation_set_password" alien (string->utf8 phrase))))) (if (memq 'SAVING-SUPPORTED flags) (if (prompt-for-confirmation "Save password permanently" port) (C-call "g_mount_operation_set_password_save" alien @@ -1108,15 +1112,18 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (named-lambda (mount-password-callback gmountop message user domain flags) (%trace-auth ";mount-password-callback "(gfile-uri gfile) " "gmountop - " "(c-peek-cstring message) - " "(c-peek-cstring user) - " "(c-peek-cstring domain) + " "(utf8->string (c-peek-cstring message)) + " "(utf8->string (c-peek-cstring user)) + " "(utf8->string (c-peek-cstring domain)) " "(->ask-password-flags flags)"\n") (let ((old (g-mount-operation-ask-password-flags gmountop)) (new (->ask-password-flags flags))) - (set-g-mount-operation-message! gmountop (c-peek-cstring message)) - (set-g-mount-operation-username! gmountop (c-peek-cstring user)) - (set-g-mount-operation-domain! gmountop (c-peek-cstring domain)) + (set-g-mount-operation-message! gmountop + (utf8->string (c-peek-cstring message))) + (set-g-mount-operation-username! gmountop + (utf8->string (c-peek-cstring user))) + (set-g-mount-operation-domain! gmountop + (utf8->string (c-peek-cstring domain))) (set-g-mount-operation-ask-password-flags! gmountop new) (cond ((not old) ;; Punt, %queuing "Password dialog cancelled". @@ -1149,13 +1156,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace-auth ";make-mount-question-callback" " "(gfile-uri gfile) " "gmountop - " "(c-peek-cstring message) + " "(utf8->string (c-peek-cstring message)) " "(peek-gstrv! choices)"\n") (warn "Unimplemented" 'mount-question-callback))) (define (peek-gstrv! alien) (let loop () - (let ((str (c-peek-cstringp! alien))) + (let ((str (utf8->string (c-peek-cstringp! alien)))) (if (null? str) '() (cons str (loop)))))) @@ -1165,7 +1172,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace-auth ";make-mount-processes-callback" " "gfile " "gmountop - " "(c-peek-cstring message) + " "(utf8->string (c-peek-cstring message)) " "processes " "(peek-gstrv! choices)"\n") (warn "Unimplemented" 'mount-processes-callback))) @@ -1225,7 +1232,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-> scan "* uchar" cstr) (if (alien-null? cstr) '() - (let ((str (c-peek-cstring cstr))) + (let ((str (utf8->string (c-peek-cstring cstr)))) (alien-byte-increment! scan (C-sizeof "* uchar")) (cons str (loop))))))) diff --git a/src/glib/glib-tests.scm b/src/glib/glib-tests.scm index 38173e814..4dc83863c 100644 --- a/src/glib/glib-tests.scm +++ b/src/glib/glib-tests.scm @@ -79,6 +79,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (map (lambda (elt) (let ((alien (weak-car elt))) (if (eq? 'uchar (alien/ctype alien)) - (c-peek-cstring alien) + (utf8->string (c-peek-cstring alien)) alien))) (access malloced-aliens ffi)))))) \ No newline at end of file diff --git a/src/glib/gobject.scm b/src/glib/gobject.scm index 3fede7dfb..3e33e13ba 100644 --- a/src/glib/gobject.scm +++ b/src/glib/gobject.scm @@ -119,12 +119,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-car! id.handle newid) (set-cdr! id.handle (C-call "g_signal_connect_data" alien - (symbol-name (car name.id.handle)) + (string->utf8 (symbol->string (car name.id.handle))) alien-function newid 0 0)))) (define (g-signal-disconnect gobject name) (guarantee-gobject gobject 'g-signal-disconnect) - (guarantee-symbol name 'g-signal-disconnect) + (guarantee symbol? name 'g-signal-disconnect) (without-interrupts (lambda () (let* ((alien (gobject-alien gobject)) @@ -156,7 +156,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (unimplemented type) (error "Unimplemented property type:" type name gobject)) - (C-call "g_object_get_property" (gobject-alien gobject) name gvalue) + (C-call "g_object_get_property" (gobject-alien gobject) + (string->utf8 name) gvalue) (let* ((type (C-> gvalue "GValue g_type")) (value (cond @@ -195,9 +196,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((int:= type (C-enum "G_TYPE_STRING")) (let ((alien (make-alien '(const (* |gchar|))))) (C-call "g_value_get_string" alien gvalue) - (let ((str (c-peek-cstring alien))) + (let ((bv (c-peek-cstring alien))) (free alien) - str))) + (utf8->string bv)))) ((int:= type (C-enum "G_TYPE_POINTER")) (let ((alien (make-alien '|gpointer|))) (C-call "g_value_get_pointer" alien gvalue) @@ -227,7 +228,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (else (let ((name (check-prop-name (car plist))) (value (cadr plist))) - (C-call "g_object_class_find_property" pspec gclass name) + (C-call "g_object_class_find_property" + pspec gclass (string->utf8 name)) (if (alien-null? pspec) (error "No property:" name gclass-name)) (let ((flags (C-> pspec "GParamSpec flags"))) @@ -296,7 +298,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (or (C-enum "enum GFundamentalType" fundamental) fundamental) name gclass-name)))) - (C-call "g_object_set_property" gobject-alien name gvalue) + (C-call "g_object_set_property" gobject-alien + (string->utf8 name) gvalue) (C-call "g_value_reset" gvalue))) (loop (cddr plist))))) (free gtype) @@ -313,7 +316,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; GCLASS should be an alien of type GObjectClass. (let ((c* (make-alien '(* |gchar|)))) (C-call "G_OBJECT_CLASS_NAME" c* gclass) - (c-peek-cstring c*))) + (utf8->string (c-peek-cstring c*)))) (define (gobject-get-gtype gobject) (let ((ret (make-alien '|GType|))) @@ -325,7 +328,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (check-prop-name name) ;; Allows NAME to be a symbol OR string. - (cond ((symbol? name) (symbol-name name)) + (cond ((symbol? name) (symbol->string name)) ((string? name) name) (else (check-prop-name (error "Invalid property name:" name))))) @@ -400,7 +403,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (gquark-from-string string) (or (hash-table/get gquark-from-string-cache string #f) - (let ((gq (C-call "g_quark_from_string" string))) + (let ((gq (C-call "g_quark_from_string" (string->utf8 string)))) (hash-table/put! gquark-from-string-cache string gq) (hash-table/put! gquark-to-string-cache gq string) gq))) -- 2.25.1