From a2b781e00ac85ed769af0b5f07bf4f39dafdd3b7 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 27 Jul 2011 12:38:55 -0700 Subject: [PATCH] Wrapped GFileInfo, GFileEnumerator. --- src/gtk/Includes/gio/gfile.cdecl | 36 +- src/gtk/Includes/gio/gfileenumerator.cdecl | 32 + src/gtk/Includes/gio/gfileinfo.cdecl | 68 ++ src/gtk/Includes/gio/gio.cdecl | 4 +- src/gtk/Includes/gio/gioenums.cdecl | 25 +- src/gtk/Includes/glib.cdecl | 2 +- src/gtk/Includes/glib/glist.cdecl | 17 + src/gtk/gio.scm | 687 +++++++++++++++++---- src/gtk/gtk.pkg | 32 +- 9 files changed, 768 insertions(+), 135 deletions(-) create mode 100644 src/gtk/Includes/gio/gfileenumerator.cdecl create mode 100644 src/gtk/Includes/gio/gfileinfo.cdecl create mode 100644 src/gtk/Includes/glib/glist.cdecl diff --git a/src/gtk/Includes/gio/gfile.cdecl b/src/gtk/Includes/gio/gfile.cdecl index a2b415b3e..41661fe9d 100644 --- a/src/gtk/Includes/gio/gfile.cdecl +++ b/src/gtk/Includes/gio/gfile.cdecl @@ -67,7 +67,7 @@ glib-2.0/gio/gfile.h |# (res (* GAsyncResult)) (error (* (* GError)))) -(extern void +#;(extern void g_file_open_readwrite_async (file (* GFile)) (io_priority int) @@ -75,8 +75,40 @@ glib-2.0/gio/gfile.h |# (CALLBACK GAsyncReadyCallback) (ID gpointer)) -(extern (* GFileIOStream) +#;(extern (* GFileIOStream) g_file_open_readwrite_finish (file (* GFile)) (res (* GAsyncResult)) + (error (* (* GError)))) + +(extern void + g_file_query_info_async + (file (* GFile)) + (attributes (* (const char))) + (flags GFileQueryInfoFlags) + (io_priority int) + (cancellable (* GCancellable)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) + +(extern (* GFileInfo) + g_file_query_info_finish + (file (* GFile)) + (res (* GAsyncResult)) + (error (* (* GError)))) + +(extern void + g_file_enumerate_children_async + (file (* GFile)) + (attributes (* (const char))) + (flags GFileQueryInfoFlags) + (io_priority int) + (cancellable (* GCancellable)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) + +(extern (* GFileEnumerator) + g_file_enumerate_children_finish + (file (* GFile)) + (res (* GAsyncResult)) (error (* (* GError)))) \ No newline at end of file diff --git a/src/gtk/Includes/gio/gfileenumerator.cdecl b/src/gtk/Includes/gio/gfileenumerator.cdecl new file mode 100644 index 000000000..1766e7734 --- /dev/null +++ b/src/gtk/Includes/gio/gfileenumerator.cdecl @@ -0,0 +1,32 @@ +#| -*-Scheme-*- + +glib-2.0/gio/gfileenumerator.h |# + +(extern void + g_file_enumerator_next_files_async + (enumerator (* GFileEnumerator)) + (num_files int) + (io_priority int) + (cancellable (* GCancellable)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) + +(extern (* GList) + g_file_enumerator_next_files_finish + (enumerator (* GFileEnumerator)) + (result (* GAsyncResult)) + (error (* (* GError)))) + +(extern void + g_file_enumerator_close_async + (enumerator (* GFileEnumerator)) + (io_priority int) + (cancellable (* GCancellable)) + (CALLBACK GAsyncReadyCallback) + (ID gpointer)) + +(extern gboolean + g_file_enumerator_close_finish + (enumerator (* GFileEnumerator)) + (result (* GAsyncResult)) + (error (* (* GError)))) \ No newline at end of file diff --git a/src/gtk/Includes/gio/gfileinfo.cdecl b/src/gtk/Includes/gio/gfileinfo.cdecl new file mode 100644 index 000000000..0ba36a92c --- /dev/null +++ b/src/gtk/Includes/gio/gfileinfo.cdecl @@ -0,0 +1,68 @@ +#| -*-Scheme-*- + +glib-2.0/gio/gfileinfo.h |# + +(extern (* (* char)) + g_file_info_list_attributes + (info (* GFileInfo)) + (name_space (* (const char)))) + +(extern GFileAttributeType + g_file_info_get_attribute_type + (info (* GFileInfo)) + (attribute (* (const char)))) + +(extern void + g_file_info_remove_attribute + (info (* GFileInfo)) + (attribute (* (const char)))) + +(extern GFileAttributeStatus + g_file_info_get_attribute_status + (info (* GFileInfo)) + (attribute (* (const char)))) + +(extern (* (const char)) + g_file_info_get_attribute_string + (info (* GFileInfo)) + (attribute (* (const char)))) + +(extern (* (const char)) + g_file_info_get_attribute_byte_string + (info (* GFileInfo)) + (attribute (* (const char)))) + +(extern gboolean + g_file_info_get_attribute_boolean + (info (* GFileInfo)) + (attribute (* (const char)))) + +(extern guint32 + g_file_info_get_attribute_uint32 + (info (* GFileInfo)) + (attribute (* (const char)))) + +(extern gint32 + g_file_info_get_attribute_int32 + (info (* GFileInfo)) + (attribute (* (const char)))) + +(extern guint64 + g_file_info_get_attribute_uint64 + (info (* GFileInfo)) + (attribute (* (const char)))) + +(extern gint64 + g_file_info_get_attribute_int64 + (info (* GFileInfo)) + (attribute (* (const char)))) + +(extern (* GObject) + g_file_info_get_attribute_object + (info (* GFileInfo)) + (attribute (* (const char)))) + +(extern (* (* char)) + g_file_info_get_attribute_stringv + (info (* GFileInfo)) + (attribute (* (const char)))) \ No newline at end of file diff --git a/src/gtk/Includes/gio/gio.cdecl b/src/gtk/Includes/gio/gio.cdecl index e286396ed..113e00bd3 100644 --- a/src/gtk/Includes/gio/gio.cdecl +++ b/src/gtk/Includes/gio/gio.cdecl @@ -39,10 +39,10 @@ glib-2.0/gio/gio.h |# ;(include "gdrive") ;(include "gemblemedicon") ;(include "gfileattribute") -;(include "gfileenumerator") +(include "gfileenumerator") (include "gfile") ;(include "gfileicon") -;(include "gfileinfo") +(include "gfileinfo") ;(include "gfileinputstream") ;(include "gfileiostream") ;(include "gfilemonitor") diff --git a/src/gtk/Includes/gio/gioenums.cdecl b/src/gtk/Includes/gio/gioenums.cdecl index 9efdb7f1d..2a555b20a 100644 --- a/src/gtk/Includes/gio/gioenums.cdecl +++ b/src/gtk/Includes/gio/gioenums.cdecl @@ -8,4 +8,27 @@ glib-2.0/gio/gioenums.h |# (enum (G_FILE_CREATE_NONE) (G_FILE_CREATE_PRIVATE) - (G_FILE_CREATE_REPLACE_DESTINATION))) \ No newline at end of file + (G_FILE_CREATE_REPLACE_DESTINATION))) + +(typedef GFileAttributeType + (enum + (G_FILE_ATTRIBUTE_TYPE_INVALID) + (G_FILE_ATTRIBUTE_TYPE_STRING) + (G_FILE_ATTRIBUTE_TYPE_BYTE_STRING) + (G_FILE_ATTRIBUTE_TYPE_BOOLEAN) + (G_FILE_ATTRIBUTE_TYPE_UINT32) + (G_FILE_ATTRIBUTE_TYPE_INT32) + (G_FILE_ATTRIBUTE_TYPE_UINT64) + (G_FILE_ATTRIBUTE_TYPE_INT64) + (G_FILE_ATTRIBUTE_TYPE_OBJECT) + (G_FILE_ATTRIBUTE_TYPE_STRINGV))) + +(typedef GFileAttributeStatus + (enum + (G_FILE_ATTRIBUTE_STATUS_UNSET) + (G_FILE_ATTRIBUTE_STATUS_SET) + (G_FILE_ATTRIBUTE_STATUS_ERROR_SETTING))) + +(typedef GFileQueryInfoFlags (enum + (G_FILE_QUERY_INFO_NONE) + (G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS))) \ No newline at end of file diff --git a/src/gtk/Includes/glib.cdecl b/src/gtk/Includes/glib.cdecl index 9287bb501..24ecb79f1 100644 --- a/src/gtk/Includes/glib.cdecl +++ b/src/gtk/Includes/glib.cdecl @@ -25,7 +25,7 @@ glib-2.0/glib.h |# ;(include "glib/ghostutils") ;(include "glib/giochannel") ;(include "glib/gkeyfile") -;(include "glib/glist") +(include "glib/glist") ;(include "glib/gmacros") ;(include "glib/gmain") ;(include "glib/gmappedfile") diff --git a/src/gtk/Includes/glib/glist.cdecl b/src/gtk/Includes/glib/glist.cdecl new file mode 100644 index 000000000..c44d1b6fe --- /dev/null +++ b/src/gtk/Includes/glib/glist.cdecl @@ -0,0 +1,17 @@ +#| -*-Scheme-*- + +glib-2.0/glib/glist.h |# + +;(include "gmem") + +(typedef GList + (struct _GList)) + +(struct _GList + (data gpointer) + (next (* GList)) + (prev (* GList))) + +(extern void + g_list_free + (list (* GList))) \ No newline at end of file diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm index c4d5cf6db..e87f59b16 100644 --- a/src/gtk/gio.scm +++ b/src/gtk/gio.scm @@ -125,13 +125,14 @@ USA. (make-alien '(* |GError|))) (define-structure g-input-stream-cancel-info - pending-op ; #f, OPEN, READ, SKIP, CLOSE or ERROR. + pending-op ; #f, OPEN, READ, SKIP, CLOSE, CLOSED or ERROR. + ; The last two are more permanent states than "op"s. callback-id ; #f or the open/close finish callback ID gcancellable ; a GCancellable alien - gerror-pointer ; null or malloced GError* that MAY ref. a GError + gerror-pointer ; a (* GError) alien - ;; To avoid registering read or skip finish callbacks for every read - ;; or skip (a LOT of registering/deregistering!), the open operation + ;; To avoid registering a read or skip finish callback for every + ;; read or skip (a LOT of de/registering!), the open operation ;; (i.e. gfile-read) registers them in advance. read-id ; #f or the read finish callback ID skip-id ; #f or the skip finish callback ID @@ -141,28 +142,32 @@ USA. (call-next-method object) (let* ((info (g-input-stream-cancel-info object)) (gerror* (g-input-stream-cancel-info-gerror-pointer info))) - (add-gc-cleanup object - (make-g-input-stream-cleanup info)) + (add-gc-cleanup object (make-g-input-stream-cleanup info)) (C-call "g_malloc0" gerror* (C-sizeof "*")) (error-if-null gerror* "Could not create:" gerror*))) (define (make-g-input-stream-cleanup info) (named-lambda (g-input-stream-cleanup) - (let ((pending-op (g-input-stream-cancel-info-pending-op info)) - (gcancellable (g-input-stream-cancel-info-gcancellable info))) - (if (and pending-op (not (eq? pending-op 'ERROR))) - (C-call "g_cancellable_cancel" gcancellable)) - (cleanup-g-input-stream info)))) + (let ((pending-op (g-input-stream-cancel-info-pending-op info))) + (if (not (memq pending-op '(#f ERROR CLOSED))) + (C-call "g_cancellable_cancel" + (gobject-alien + (g-input-stream-cancel-info-gcancellable info))))) + (cleanup-g-input-stream info))) (define-syntax cleanup-callback-id (sc-macro-transformer (lambda (form environment) (if (syntax-match? '(IDENTIFIER SYMBOL SYMBOL) (cdr form)) (let ((info (close-syntax (cadr form) environment)) - (i/o (caddr form)) + (type-name (caddr form)) (slot (cadddr form))) - (let ((accessor (symbol ' G- i/o '-STREAM-CANCEL-INFO- slot)) - (modifier (symbol 'SET-G- i/o '-STREAM-CANCEL-INFO- slot '!))) + (let ((accessor (close-syntax + (symbol type-name '-CANCEL-INFO- slot) + environment)) + (modifier (close-syntax + (symbol 'SET- type-name '-CANCEL-INFO- slot '!) + environment))) `(LET ((ID (,accessor ,info))) (IF ID (BEGIN @@ -171,11 +176,11 @@ USA. (define (cleanup-g-input-stream info) ;; For gc-cleanup. Run without-interrupts. - (cleanup-callback-id info input callback-id) - (cleanup-callback-id info input read-id) - (cleanup-callback-id info input skip-id) - (cleanup-gerror-pointer (g-input-stream-cancel-info-gerror-pointer info)) - (gobject-unref! (g-input-stream-cancel-info-gcancellable info))) + (cleanup-callback-id info g-input-stream callback-id) + (cleanup-callback-id info g-input-stream read-id) + (cleanup-callback-id info g-input-stream skip-id) + (gobject-unref! (g-input-stream-cancel-info-gcancellable info)) + (cleanup-gerror-pointer (g-input-stream-cancel-info-gerror-pointer info))) (define-integrable (cleanup-gerror-pointer gerror*) (if (not (alien-null? gerror*)) @@ -189,9 +194,11 @@ USA. (define (g-input-stream-read gstream buffer start end) (let* ((info (g-input-stream-cancel-info gstream)) (callback-id (g-input-stream-cancel-info-read-id info))) - (if (not callback-id) (error "Not open:" gstream)) - (if (g-input-stream-cancel-info-pending-op info) - (error "Operation pending:" gstream)) + (let ((pending-op (g-input-stream-cancel-info-pending-op info))) + (if (memq pending-op '(#f ERROR CLOSED)) + (error "Operation pending:" gstream)) + (if pending-op + (error "Not open:" gstream))) (let* ((count (fix:- end start)) (async-buffer (ensure-buffer gstream count))) (set-g-input-stream-cancel-info-pending-op! info 'READ) @@ -226,16 +233,16 @@ USA. buffer*)) buffer))) -(define (make-g-input-stream-read-finish-callback queue gerror*) +(define (make-read-finish-callback queue gerror*) (C-callback - (named-lambda (g-input-stream-read-finish-callback source result) + (named-lambda (read-finish-callback source result) (let ((bytes (C-call "g_input_stream_read_finish" source result gerror*))) (if (fix:= bytes -1) (let ((message (%gerror-message gerror*))) - (%trace ";g-input-stream-read-finish-callback "message" "queue"\n") + (%trace ";read-finish-callback "message" "queue"\n") (%queue! queue message)) (begin - (%trace ";g-input-stream-read-finish-callback "bytes" "queue"\n") + (%trace ";read-finish-callback "bytes" "queue"\n") (%queue! queue bytes))))))) (define-integrable-operator (%gerror-message pointer) @@ -259,9 +266,11 @@ USA. (define (g-input-stream-skip gstream count) (let* ((info (g-input-stream-cancel-info gstream)) (callback-id (g-input-stream-cancel-info-skip-id info))) - (if (not callback-id) (error "Not open:" gstream)) - (if (g-input-stream-cancel-info-pending-op info) - (error "Operation pending:" gstream)) + (let ((pending-op (g-input-stream-cancel-info-pending-op info))) + (if (not (memq pending-op '(#f ERROR CLOSED))) + (error "Operation pending:" gstream)) + (if pending-op + (error "Not open:" gstream))) (set-g-input-stream-cancel-info-pending-op! info 'SKIP) (C-call "g_input_stream_skip_async" (gobject-alien gstream) @@ -280,16 +289,16 @@ USA. (set-g-input-stream-cancel-info-pending-op! info #f) value))))) -(define (make-g-input-stream-skip-finish-callback queue gerror*) +(define (make-skip-finish-callback queue gerror*) (C-callback - (named-lambda (g-input-stream-skip-finish-callback source result) + (named-lambda (skip-finish-callback source result) (let ((bytes (C-call "g_input_stream_skip_finish" source result gerror*))) (if (fix:= bytes -1) (let ((message (%gerror-message gerror*))) - (%trace ";g-input-stream-skip-finish-callback "message" "queue"\n") + (%trace ";skip-finish-callback "message" "queue"\n") (%queue! queue message)) (begin - (%trace ";g-input-stream-skip-finish-callback "bytes" "queue"\n") + (%trace ";skip-finish-callback "bytes" "queue"\n") (%queue! queue bytes))))))) (define (g-input-stream-close gstream) @@ -297,13 +306,15 @@ USA. (queue (g-stream-queue gstream)) (gerror* (g-input-stream-cancel-info-gerror-pointer info)) (read-id (g-input-stream-cancel-info-read-id info))) - (if (not read-id) (error "Not open:" gstream)) - (if (g-input-stream-cancel-info-pending-op info) (error "Operation pending:" gstream)) + (let ((pending-op (g-input-stream-cancel-info-pending-op info))) + (if (not (memq pending-op '(#f ERROR CLOSED))) + (error "Operation pending:" gstream)) + (if pending-op + (error "Not open:" gstream))) (let ((callback-id (without-interrupts ;don't leak callback IDs (lambda () - (let ((id (make-g-input-stream-close-finish-callback - queue gerror*))) + (let ((id (make-input-close-finish-callback queue gerror*))) (set-g-input-stream-cancel-info-pending-op! info 'CLOSE) (set-g-input-stream-cancel-info-callback-id! info id) id))))) @@ -319,22 +330,22 @@ USA. (set-g-input-stream-cancel-info-pending-op! info 'ERROR) (error "Error in g-input-stream-close:" gstream value)) (begin - (set-g-input-stream-cancel-info-pending-op! info #f) + (set-g-input-stream-cancel-info-pending-op! info 'CLOSED) (without-interrupts (lambda () (cleanup-g-input-stream info))) value)))))) -(define (make-g-input-stream-close-finish-callback queue gerror*) +(define (make-input-close-finish-callback queue gerror*) (C-callback - (named-lambda (g-input-stream-close-finish-callback source result) + (named-lambda (input-close-finish-callback source result) (if (fix:zero? (C-call "g_input_stream_close_finish" source result gerror*)) (let ((message (%gerror-message gerror*))) - (%trace ";g-input-stream-close-finish-callback "message" "queue"\n") + (%trace ";input-close-finish-callback "message" "queue"\n") (%queue! queue message)) (begin - (%trace ";g-input-stream-close-finish-callback #t "queue"\n") + (%trace ";input-close-finish-callback #t "queue"\n") (%queue! queue #t)))))) (define-class ( (constructor ())) @@ -346,10 +357,10 @@ USA. #f #f (make-gcancellable) (make-alien '(* |GError|)) #f #f)))) (define-structure g-output-stream-cancel-info - pending-op ; #f, OPEN, WRITE, FLUSH, CLOSE or ERROR. + pending-op ; #f, OPEN, WRITE, FLUSH, CLOSE, CLOSED or ERROR. callback-id ; #f or the open/close finish callback ID gcancellable ; a GCancellable alien - gerror-pointer ; null or malloced GError* that MAY ref. a GError + gerror-pointer ; a (* GError) alien ;; To avoid registering write or flush finish callbacks for every ;; write or flush (a LOT of registering/deregistering!), the open @@ -362,34 +373,36 @@ USA. (call-next-method object) (let* ((info (g-output-stream-cancel-info object)) (gerror* (g-output-stream-cancel-info-gerror-pointer info))) - (add-gc-cleanup object - (make-g-output-stream-cleanup info)) + (add-gc-cleanup object (make-g-output-stream-cleanup info)) ((ucode-primitive c-malloc 2) gerror* (C-sizeof "*")) (error-if-null gerror* "Could not create:" gerror*) (C->= gerror* "*" 0))) (define (make-g-output-stream-cleanup info) (named-lambda (g-output-stream-cleanup) - (let ((pending-op (g-output-stream-cancel-info-pending-op info)) - (gcancellable (g-output-stream-cancel-info-gcancellable info))) - (if (and pending-op (not (eq? pending-op 'ERROR))) - (C-call "g_cancellable_cancel" gcancellable)) - (cleanup-g-output-stream info)))) + (let ((pending-op (g-output-stream-cancel-info-pending-op info))) + (if (not (memq pending-op '(#f ERROR CLOSED))) + (C-call "g_cancellable_cancel" + (gobject-alien + (g-output-stream-cancel-info-gcancellable info))))) + (cleanup-g-output-stream info))) (define (cleanup-g-output-stream info) ;; For gc-cleanup. Run without-interrupts. - (cleanup-callback-id info output callback-id) - (cleanup-callback-id info output write-id) - (cleanup-callback-id info output flush-id) - (cleanup-gerror-pointer (g-output-stream-cancel-info-gerror-pointer info)) - (gobject-unref! (g-output-stream-cancel-info-gcancellable info))) + (cleanup-callback-id info g-output-stream callback-id) + (cleanup-callback-id info g-output-stream write-id) + (cleanup-callback-id info g-output-stream flush-id) + (gobject-unref! (g-output-stream-cancel-info-gcancellable info)) + (cleanup-gerror-pointer (g-output-stream-cancel-info-gerror-pointer info))) (define (g-output-stream-write gstream buffer start end) (let* ((info (g-output-stream-cancel-info gstream)) (callback-id (g-output-stream-cancel-info-write-id info))) - (if (not callback-id) (error "Not open:" gstream)) - (if (g-output-stream-cancel-info-pending-op info) - (error "Operation pending:" gstream)) + (let ((pending-op (g-output-stream-cancel-info-pending-op info))) + (if (not (memq pending-op '(#f ERROR CLOSED))) + (error "Operation pending:" genum)) + (if pending-op + (error "Not open:" gstream))) (let* ((count (fix:- end start)) (async-buffer (ensure-buffer gstream count))) (set-g-output-stream-cancel-info-pending-op! info 'WRITE) @@ -412,27 +425,28 @@ USA. (set-g-input-stream-cancel-info-pending-op! info #f) value)))))) -(define (make-g-output-stream-write-finish-callback queue gerror*) +(define (make-write-finish-callback queue gerror*) (C-callback - (named-lambda (g-output-stream-write-finish-callback source result) + (named-lambda (write-finish-callback source result) (let ((bytes (C-call "g_output_stream_write_finish" source result gerror*))) (if (fix:= bytes -1) (let ((message (%gerror-message gerror*))) - (%trace ";g-output-stream-write-finish-callback "message - " "queue"\n") + (%trace ";write-finish-callback "message" "queue"\n") (%queue! queue message)) (begin - (%trace ";g-output-stream-write-finish-callback "bytes" "queue"\n") + (%trace ";write-finish-callback "bytes" "queue"\n") (%queue! queue bytes))))))) (define (g-output-stream-flush gstream) (let* ((info (g-output-stream-cancel-info gstream)) (callback-id (g-output-stream-cancel-info-write-id info))) - (if (not callback-id) (error "Not open:" gstream)) - (if (g-output-stream-cancel-info-pending-op info) - (error "Operation pending:" gstream)) - (set-g-output-stream-cancel-info-pending-op! info 'WRITE) + (let ((pending-op (g-output-stream-cancel-info-pending-op info))) + (if (not (memq pending-op '(#f ERROR CLOSED))) + (error "Operation pending:" gstream)) + (if pending-op + (error "Not open:" gstream))) + (set-g-output-stream-cancel-info-pending-op! info 'FLUSH) (C-call "g_output_stream_flush_async" (gobject-alien gstream) (g-stream-io-priority gstream) @@ -449,16 +463,16 @@ USA. (set-g-input-stream-cancel-info-pending-op! info #f) (not (fix:zero? value))))))) -(define (make-g-output-stream-flush-finish-callback queue gerror*) +(define (make-flush-finish-callback queue gerror*) (C-callback - (named-lambda (g-output-stream-flush-finish-callback source result) + (named-lambda (flush-finish-callback source result) (if (fix:zero? (C-call "g_output_stream_flush_finish" source result gerror*)) (let ((message (%gerror-message gerror*))) - (%trace ";g-output-stream-flush-finish-callback "message" "queue"\n") + (%trace ";flush-finish-callback "message" "queue"\n") (%queue! queue message)) (begin - (%trace ";g-output-stream-flush-finish-callback #t "queue"\n") + (%trace ";flush-finish-callback #t "queue"\n") (%queue! queue #t)))))) (define (g-output-stream-close gstream) @@ -466,14 +480,15 @@ USA. (queue (g-stream-queue gstream)) (gerror* (g-output-stream-cancel-info-gerror-pointer info)) (write-id (g-output-stream-cancel-info-write-id info))) - (if (not write-id) (error "Not open:" gstream)) - (if (g-output-stream-cancel-info-pending-op info) - (error "Operation pending:" gstream)) + (let ((pending-op (g-output-stream-cancel-info-pending-op info))) + (if (not (memq pending-op '(#f ERROR CLOSED))) + (error "Operation pending:" gstream)) + (if pending-op + (error "Not open:" gstream))) (let ((callback-id (without-interrupts ;don't leak callback IDs (lambda () - (let ((id (make-g-output-stream-close-finish-callback - queue gerror*))) + (let ((id (make-output-close-finish-callback queue gerror*))) (set-g-output-stream-cancel-info-pending-op! info 'CLOSE) (set-g-output-stream-cancel-info-callback-id! info id) id))))) @@ -489,22 +504,22 @@ USA. (set-g-output-stream-cancel-info-pending-op! info 'ERROR) (error "Error in g-output-stream-close:" gstream value)) (begin - (set-g-output-stream-cancel-info-pending-op! info #f) + (set-g-output-stream-cancel-info-pending-op! info 'CLOSED) (without-interrupts (lambda () (cleanup-g-output-stream info))) value)))))) -(define (make-g-output-stream-close-finish-callback queue gerror*) +(define (make-output-close-finish-callback queue gerror*) (C-callback - (named-lambda (g-output-stream-close-finish-callback source result) + (named-lambda (output-close-finish-callback source result) (if (fix:zero? (C-call "g_output_stream_close_finish" source result gerror*)) (let ((message (%gerror-message gerror*))) - (%trace ";g-output-stream-close-finish-callback "message" "queue"\n") + (%trace ";output-close-finish-callback "message" "queue"\n") (%queue! queue message)) (begin - (%trace ";g-output-stream-close-finish-callback #t "queue"\n") + (%trace ";output-close-finish-callback #t "queue"\n") (%queue! queue #t)))))) (define-class @@ -524,7 +539,7 @@ USA. (without-interrupts ;don't leak callback IDs (lambda () (let* ((alien (gobject-alien gstream)) - (id (make-gfile-read-finish-callback alien queue gerror*))) + (id (make-open-finish-callback alien queue gerror*))) (set-g-input-stream-cancel-info-pending-op! info 'OPEN) (set-g-input-stream-cancel-info-callback-id! info id) id))))) @@ -546,22 +561,22 @@ USA. (de-register-c-callback callback-id) (set-g-input-stream-cancel-info-callback-id! info #f) (set-g-input-stream-cancel-info-read-id! - info (make-g-input-stream-read-finish-callback queue gerror*)) + info (make-read-finish-callback queue gerror*)) (set-g-input-stream-cancel-info-skip-id! - info (make-g-input-stream-skip-finish-callback queue gerror*)))) + info (make-skip-finish-callback queue gerror*)))) gstream))))) -(define (make-gfile-read-finish-callback alien queue gerror*) +(define (make-open-finish-callback alien queue gerror*) (C-callback - (named-lambda (gfile-read-finish-callback source result) - (let ((bytes (C-call "g_file_read_finish" alien source result gerror*))) - (if (fix:= bytes -1) - (let ((message (%gerror-message gerror*))) - (%trace ";g-file-read-finish-callback \""message"\" "queue"\n") - (%queue! queue message)) - (begin - (%trace ";g-file-read-finish-callback "bytes" "queue"\n") - (%queue! queue bytes))))))) + (named-lambda (open-finish-callback source result) + (C-call "g_file_read_finish" alien source result gerror*) + (if (alien-null? alien) + (let ((message (%gerror-message gerror*))) + (%trace ";open-finish-callback \""message"\" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";open-finish-callback "alien" "queue"\n") + (%queue! queue #t)))))) (define-class ()) @@ -573,12 +588,12 @@ USA. (define (gfile-append-to gfile . flags) (let ((flags* (->gfile-create-flags flags))) - (gfile-open gfile 'append-to - (lambda (gfile priority gcancellable callback id) - (C-call "g_file_append_to_async" - gfile flags* - priority gcancellable callback id)) - make-gfile-append-to-finish-callback))) + (gfile-open-write gfile 'append-to + (lambda (gfile priority gcancellable callback id) + (C-call "g_file_append_to_async" + gfile flags* + priority gcancellable callback id)) + make-append-to-finish-callback))) (define (->gfile-create-flags flags) (reduce-left fix:or 0 (map ->gfile-create-flag flags))) @@ -590,24 +605,24 @@ USA. (else (error:wrong-type-argument flag "GFile create flag" '->GFILE-CREATE-FLAG)))) -(define (make-gfile-append-to-finish-callback alien queue gerror*) +(define (make-append-to-finish-callback alien queue gerror*) (C-callback - (named-lambda (gfile-append-to-finish-callback source result) + (named-lambda (append-to-finish-callback source result) (C-call "g_file_append_to_finish" alien source result gerror*) (g-output-stream-finish alien queue gerror* 'append-to)))) (define (gfile-create gfile . flags) (let ((flags* (->gfile-create-flags flags))) - (gfile-open gfile 'create - (lambda (gfile priority gcancellable callback id) - (C-call "g_file_create_async" - gfile flags* - priority gcancellable callback id)) - make-gfile-create-finish-callback))) - -(define (make-gfile-create-finish-callback alien queue gerror*) + (gfile-open-write gfile 'create + (lambda (gfile priority gcancellable callback id) + (C-call "g_file_create_async" + gfile flags* + priority gcancellable callback id)) + make-create-finish-callback))) + +(define (make-create-finish-callback alien queue gerror*) (C-callback - (named-lambda (gfile-create-finish-callback source result) + (named-lambda (create-finish-callback source result) (C-call "g_file_create_finish" alien source result gerror*) (g-output-stream-finish alien queue gerror* 'create)))) @@ -615,12 +630,12 @@ USA. (let ((etag (->gfile-etag etag)) (make-backups (if backup? 1 0)) (flags* (->gfile-create-flags flags))) - (gfile-open gfile 'replace - (lambda (gfile priority gcancellable callback id) - (C-call "g_file_replace_async" - gfile etag make-backups flags* - priority gcancellable callback id)) - make-gfile-replace-finish-callback))) + (gfile-open-write gfile 'replace + (lambda (gfile priority gcancellable callback id) + (C-call "g_file_replace_async" + gfile etag make-backups flags* + priority gcancellable callback id)) + make-replace-finish-callback))) (define-integrable (->gfile-etag etag) (cond ((and (alien? etag) (eq? (alien/ctype etag) '|GFile etag|)) @@ -630,13 +645,13 @@ USA. (else (error:wrong-type-argument etag "GFile etag" '->GFILE-ETAG)))) -(define (make-gfile-replace-finish-callback alien queue gerror*) +(define (make-replace-finish-callback alien queue gerror*) (C-callback - (named-lambda (gfile-replace-finish-callback source result) + (named-lambda (replace-finish-callback source result) (C-call "g_file_replace_finish" alien source result gerror*) (g-output-stream-finish alien queue gerror* 'replace)))) -(define-integrable-operator (gfile-open gfile op callout make-callback) +(define-integrable-operator (gfile-open-write gfile op callout make-callback) (let* ((gstream (make-g-output-stream)) (info (g-output-stream-cancel-info gstream)) (gerror* (g-output-stream-cancel-info-gerror-pointer info)) @@ -666,20 +681,396 @@ USA. (de-register-c-callback callback-id) (set-g-output-stream-cancel-info-callback-id! info #f) (set-g-output-stream-cancel-info-write-id! - info (make-g-output-stream-write-finish-callback queue gerror*)) + info (make-write-finish-callback queue gerror*)) (set-g-output-stream-cancel-info-flush-id! - info - (make-g-output-stream-flush-finish-callback queue gerror*)))) + info (make-flush-finish-callback queue gerror*)))) gstream))))) (define-integrable-operator (g-output-stream-finish alien queue gerror* op) (if (alien-null? alien) (let ((message (%gerror-message gerror*))) - (%trace ";g-output-stream-"op"-callback "message" "queue"\n") + (%trace ";"op"-finish-callback "message" "queue"\n") (%queue! queue message)) (begin - (%trace ";g-output-stream-"op"-callback "alien" "queue"\n") - (%queue! queue alien)))) + (%trace ";"op"-finish-callback "alien" "queue"\n") + (%queue! queue #t)))) + +(define-class ( (constructor ())) + () + + (io-priority + define standard initial-value 10) + + (queue + define accessor initializer (lambda () (make-thread-queue 1))) + + (cancel-info + define accessor initializer + (lambda () + (make-ginfo-cancel-info #f #f (make-gcancellable) (make-gerror*))))) + +(define-structure ginfo-cancel-info + pending-op ; #f, QUERY, CLOSED or ERROR + callback-id ; #f or query finish callback ID + gcancellable ; a GCancellable alien + gerror-pointer) ; a (* GError) alien + +(define-method initialize-instance ((object )) + (call-next-method object) + (let* ((info (gfile-info-cancel-info object)) + (gerror* (ginfo-cancel-info-gerror-pointer info))) + (add-gc-cleanup object (make-ginfo-cleanup info)) + (C-call "g_malloc0" gerror* (C-sizeof "*")) + (error-if-null gerror* "Could not create:" gerror*))) + +(define (make-ginfo-cleanup info) + (named-lambda (ginfo-cleanup) + (let ((pending-op (ginfo-cancel-info-pending-op info))) + (if (not (memq pending-op '(#f CLOSED ERROR))) + (C-call "g_cancellable_cancel" + (gobject-alien + (ginfo-cancel-info-gcancellable info))))) + (cleanup-callback-id info ginfo callback-id) + (gobject-unref! (ginfo-cancel-info-gcancellable info)) + (cleanup-gerror-pointer (ginfo-cancel-info-gerror-pointer info)))) + +(define (gfile-query-info gfile pattern follow-symlinks?) + (guarantee-string pattern 'gfile-query-info) + (let* ((ginfo (make-gfile-info)) + (info (gfile-info-cancel-info ginfo)) + (queue (gfile-info-queue ginfo)) + (gerror* (ginfo-cancel-info-gerror-pointer info)) + (callback-id + (without-interrupts ;don't leak callback IDs + (lambda () + (let* ((alien (gobject-alien ginfo)) + (id (make-query-finish-callback alien queue gerror*))) + (set-ginfo-cancel-info-pending-op! info 'QUERY) + (set-ginfo-cancel-info-callback-id! info id) + id))))) + (C-call "g_file_query_info_async" + (gobject-alien gfile) + pattern + (if follow-symlinks? + (C-enum "G_FILE_QUERY_INFO_NONE") + (C-enum "G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS")) + (gfile-info-io-priority ginfo) + (gobject-alien (ginfo-cancel-info-gcancellable info)) + (C-callback "async_ready") + callback-id) + (let ((value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-ginfo-cancel-info-pending-op! info 'ERROR) + (error "Error in gfile-query-info:" gfile value)) + (begin + (set-ginfo-cancel-info-pending-op! info 'CLOSED) + (without-interrupts + (lambda () + (de-register-c-callback callback-id) + (set-ginfo-cancel-info-callback-id! info #f))) + ginfo))))) + +(define (make-query-finish-callback alien queue gerror*) + (C-callback + (named-lambda (query-finish-callback source result) + (C-call "g_file_query_info_finish" alien source result gerror*) + (if (alien-null? alien) + (let ((message (%gerror-message gerror*))) + (%trace ";query-finish-callback "message" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";query-finish-callback "alien" "queue"\n") + (%queue! queue #t)))))) + +(define (gfile-info-list-attributes ginfo namespace) + (guarantee-string namespace 'gfile-info-list-attributes) + (map string->symbol + (let ((alien (make-cstringv + (lambda (copy) + (C-call "g_file_info_list_attributes" copy + (gobject-alien ginfo) namespace))))) + (let ((strings (peek-cstringv alien))) + (free-cstringv alien) + strings)))) + +(define (gfile-info-remove-attribute ginfo name) + (guarantee-string name 'gfile-info-remove-attribute) + (C-call "g_file_info_remove_attribute" (gobject-alien ginfo) name)) + +(define (gfile-info-get-attribute-status ginfo name) + (let ((code (C-call "g_file_info_get_attribute_status" + (gobject-alien ginfo) + 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")) + 'error-setting) + (else (error "Unknown GFileAttributeStatus:" code))))) + +(define (gfile-info-get-attribute-value ginfo name) + (let* ((alien (gobject-alien ginfo)) + (type (C-call "g_file_info_get_attribute_type" alien name))) + (cond ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_INVALID")) + #f) + ((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))) + ((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))) + ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_BOOLEAN")) + (not (fix:zero? + (C-call "g_file_info_get_attribute_boolean" alien name)))) + ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_UINT32")) + (C-call "g_file_info_get_attribute_uint32" alien name)) + ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_INT32")) + (C-call "g_file_info_get_attribute_int32" alien name)) + ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_UINT64")) + (C-call "g_file_info_get_attribute_uint64" alien name)) + ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_INT64")) + (C-call "g_file_info_get_attribute_int64" alien name)) + ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_OBJECT")) + (C-call "g_file_info_get_attribute_object" + (make-alien '|GObject|) alien name)) + ((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))) + (else (error "Unexpected GFileAttributeType:" type))))) + +(define-class ( (constructor ())) + () + + (io-priority + define standard initial-value 10) + + (queue + define accessor initializer (lambda () (make-thread-queue 1))) + + (cancel-info + define accessor initializer + (lambda () + (make-gfile-enumerator-cancel-info + #f #f (make-alien '|GList|) (make-gcancellable) (make-gerror*))))) + +(define-structure gfile-enumerator-cancel-info + pending-op ; #f, NEXT, CLOSE, CLOSED or ERROR + callback-id ; #f or the pending-op's callback id + ginfos ; a GList alien, a list of GFileInfos + gcancellable ; a GCancellable alien + gerror-pointer) ; a (* GError) alien + +(define-method initialize-instance ((object )) + (call-next-method object) + (let* ((info (gfile-enumerator-cancel-info object)) + (gerror* (gfile-enumerator-cancel-info-gerror-pointer info))) + (add-gc-cleanup object (make-gfile-enumerator-cleanup info)) + (C-call "g_malloc0" gerror* (C-sizeof "*")) + (error-if-null gerror* "Could not create:" gerror*))) + +(define (make-gfile-enumerator-cleanup info) + (named-lambda (gfile-enumerator-cleanup) + (let ((pending-op (gfile-enumerator-cancel-info-pending-op info))) + (if (not (memq pending-op '(#f CLOSED ERROR))) + (C-call "g_cancellable_cancel" + (gobject-alien + (gfile-enumerator-cancel-info-gcancellable info))))) + (cleanup-gfile-enumerator info))) + +(define (cleanup-gfile-enumerator info) + ;; For gc-cleanup. Run without-interrupts. + (cleanup-callback-id info gfile-enumerator callback-id) + (cleanup-ginfos info) + (gobject-unref! (gfile-enumerator-cancel-info-gcancellable info)) + (cleanup-gerror-pointer (gfile-enumerator-cancel-info-gerror-pointer info))) + +(define (cleanup-ginfos info) + (let ((glist (gfile-enumerator-cancel-info-ginfos info))) + (if (not (alien-null? glist)) + (let ((scan (copy-alien glist)) + (ginfo (make-alien '|GFileInfo|))) + (let loop () + (C-> scan "GList data" ginfo) + (if (not (alien-null? ginfo)) + (begin + (C->= scan "GList data" 0) + (C-call "g_object_unref" ginfo))) + (C-> scan "GList next" scan) + (if (alien-null? scan) + (begin + (C-call "g_list_free" glist) + (alien-null! glist)) + (loop))))))) + +(define (gfile-enumerate-children gfile pattern follow-symlinks?) + (guarantee-string pattern 'gfile-enumerate-children) + (let* ((genum (make-gfile-enumerator)) + (info (gfile-enumerator-cancel-info genum)) + (queue (gfile-enumerator-queue genum)) + (gerror* (gfile-enumerator-cancel-info-gerror-pointer info)) + (callback-id + (without-interrupts ;don't leak callback IDs + (lambda () + (let* ((alien (gobject-alien genum)) + (id (make-enumerator-finish-callback alien queue gerror*))) + (set-gfile-enumerator-cancel-info-pending-op! info 'OPEN) + (set-gfile-enumerator-cancel-info-callback-id! info id) + id))))) + (C-call "g_file_enumerate_children_async" + (gobject-alien gfile) + pattern + (if follow-symlinks? + (C-enum "G_FILE_QUERY_INFO_NONE") + (C-enum "G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS")) + (gfile-enumerator-io-priority genum) + (gobject-alien (gfile-enumerator-cancel-info-gcancellable info)) + (C-callback "async_ready") + callback-id) + (let ((value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-gfile-enumerator-cancel-info-pending-op! info 'ERROR) + (error "Error in gfile-enumerator-children:" gfile value)) + (let ((ginfos (gfile-enumerator-cancel-info-ginfos info))) + (set-gfile-enumerator-cancel-info-pending-op! info #f) + (without-interrupts + (lambda () + (de-register-c-callback callback-id) + (set-gfile-enumerator-cancel-info-callback-id! + info (make-next-files-finish-callback ginfos queue gerror*)))) + genum))))) + +(define (make-enumerator-finish-callback alien queue gerror*) + (C-callback + (named-lambda (enumerator-finish-callback source result) + (C-call "g_file_enumerate_children_finish" alien source result gerror*) + (if (alien-null? alien) + (let ((message (%gerror-message gerror*))) + (%trace ";enumerator-finish-callback "message" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";enumerator-finish-callback "alien" "queue"\n") + (%queue! queue #t)))))) + +(define (gfile-enumerator-next-files genum nfiles) + (guarantee-fixnum nfiles 'gfile-enumerator-next-files) + (let* ((info (gfile-enumerator-cancel-info genum)) + (callback-id (gfile-enumerator-cancel-info-callback-id info))) + (let ((pending-op (gfile-enumerator-cancel-info-pending-op info))) + (if (not (memq pending-op '(#f ERROR CLOSED))) + (error "Operation pending:" genum)) + (if pending-op + (error "Not open:" genum))) + (set-gfile-enumerator-cancel-info-pending-op! info 'NEXT) + (C-call "g_file_enumerator_next_files_async" + (gobject-alien genum) + nfiles + (gfile-enumerator-io-priority genum) + (gobject-alien (gfile-enumerator-cancel-info-gcancellable info)) + (C-callback "async_ready") + callback-id) + (let* ((queue (gfile-enumerator-queue genum)) + (value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-gfile-enumerator-cancel-info-pending-op! info 'ERROR) + (error "Error in gfile-enumerator-next-files:" genum value)) + (begin + (set-gfile-enumerator-cancel-info-pending-op! info #f) + (make-ginfos info)))))) + +(define (make-ginfos info) + (let* ((glist (gfile-enumerator-cancel-info-ginfos info)) + (scan (copy-alien glist)) + (ginfo (make-alien '|GFileInfo|)) + (ginfos + (let loop () + (if (alien-null? scan) + '() + (begin + (C-> scan "GList data" ginfo) + (if (not (alien-null? ginfo)) + (let ((new (make-gfile-info))) + (without-interrupts + (lambda () + (copy-alien-address! (gobject-alien new) ginfo) + (C->= scan "GList data" 0))) + (C-> scan "GList next" scan) + (cons new (loop))) + (begin + (C-> scan "GList next" scan) + (loop)))))))) + (without-interrupts + (lambda () + (if (not (alien-null? glist)) + (begin + (C-call "g_list_free" glist) + (alien-null! glist))))) + ginfos)) + +(define (make-next-files-finish-callback ginfos queue gerror*) + (C-callback + (named-lambda (next-files-finish-callback source result) + (C-call "g_file_enumerator_next_files_finish" ginfos source result gerror*) + (if (and (alien-null? ginfos) + (not (alien-null? (C-> gerror* "* GError")))) + (let ((message (%gerror-message gerror*))) + (%trace ";next-files-finish-callback "message" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";next-files-finish-callback #t "queue"\n") + (%queue! queue #t)))))) + +(define (gfile-enumerator-close genum) + (let* ((info (gfile-enumerator-cancel-info genum)) + (queue (gfile-enumerator-queue genum)) + (gerror* (gfile-enumerator-cancel-info-gerror-pointer info))) + (let ((pending-op (gfile-enumerator-cancel-info-pending-op info))) + (if (not (memq pending-op '(#f ERROR CLOSED))) + (error "Operation pending:" genum)) + (if pending-op + (error "Not open:" genum))) + (let ((callback-id + (without-interrupts ;don't leak callback IDs + (lambda () + (let ((old (gfile-enumerator-cancel-info-callback-id info))) + (if old (de-register-c-callback old))) + (let ((id (make-enumerator-close-finish-callback queue gerror*))) + (set-gfile-enumerator-cancel-info-pending-op! info 'CLOSE) + (set-gfile-enumerator-cancel-info-callback-id! info id) + id))))) + (C-call "g_file_enumerator_close_async" + (gobject-alien genum) + (gfile-enumerator-io-priority genum) + (gobject-alien (gfile-enumerator-cancel-info-gcancellable info)) + (C-callback "async_ready") + callback-id) + (let ((value (thread-queue/dequeue! queue))) + (if (string? value) + (begin + (set-gfile-enumerator-cancel-info-pending-op! info 'ERROR) + (error "Error in gfile-enumerator-close:" genum value)) + (begin + (set-gfile-enumerator-cancel-info-pending-op! info 'CLOSED) + (without-interrupts + (lambda () + (cleanup-gfile-enumerator info))) + value)))))) + +(define (make-enumerator-close-finish-callback queue gerror*) + (C-callback + (named-lambda (enumerator-close-finish-callback source result) + (if (fix:zero? + (C-call "g_file_enumerator_close_finish" source result gerror*)) + (let ((message (%gerror-message gerror*))) + (%trace ";enumerator-close-finish-callback "message" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";enumerator-close-finish-callback #t "queue"\n") + (%queue! queue #t)))))) (define-class ( (constructor (uri))) () @@ -706,6 +1097,48 @@ USA. (define-structure gfile-etag alien) +(define (make-cstringv setter) + ;; SETTER is applied to an alien that must not escape. + (let ((alien (make-alien '(* uchar))) + (copy (make-alien '(* uchar)))) + (add-gc-cleanup alien (make-cstringv-cleanup copy)) + (setter copy) + (copy-alien-address! alien copy) + alien)) + +(define (make-cstringv-cleanup alien) + (named-lambda (cstringv-cleanup) + (if (not (alien-null? alien)) + (let ((scan (copy-alien alien)) + (cstr (make-alien 'uchar))) + (let loop () + (C-> scan "* uchar" cstr) + (if (not (alien-null? cstr)) + (begin + (C-call "g_free" cstr) + (alien-byte-increment! scan (C-sizeof "* uchar")) + (loop)))) + (C-call "g_free" alien) + (alien-null! alien))))) + +(define (peek-cstringv alien) + (let ((scan (copy-alien alien)) + (cstr (make-alien 'uchar))) + (let loop () + (C-> scan "* uchar" cstr) + (if (alien-null? cstr) + '() + (let ((str (c-peek-cstring cstr))) + (alien-byte-increment! scan (C-sizeof "* uchar")) + (cons str (loop))))))) + +(define (free-cstringv alien) + (without-interrupts + (lambda () + (let ((cleanup (punt-gc-cleanup alien))) + (if cleanup (cleanup)) + (alien-null! alien))))) + (define %trace? #f) (define-syntax %trace diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 90b9e98ee..e6e64f10f 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -67,9 +67,37 @@ USA. make-gsink) (import (gtk main) maybe-yield-gtk) - (export (gtk) + (export () open-input-gfile - open-output-gfile)) + open-output-gfile) + (export (gtk) + + + g-input-stream-read + g-input-stream-skip + g-input-stream-close + + g-output-stream-write + g-output-stream-flush + g-output-stream-close + + gfile-read + + gfile-append-to + gfile-create + gfile-replace + + gfile-query-info + gfile-info-list-attributes + gfile-info-remove-attribute + gfile-info-get-attribute-status + gfile-info-get-attribute-value + + gfile-enumerate-children + gfile-enumerator-next-files + gfile-enumerator-close + + make-gfile)) (define-package (gtk pango) (parent (gtk)) -- 2.25.1