From bc56160529adc6afa9ad47fafff5bd063b70e02d Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Fri, 12 Aug 2011 11:21:54 -0700 Subject: [PATCH] Factored gfile-open out of -read, -open-write and -enumerate-children. --- src/gtk/gio.scm | 219 ++++++++++++++++++++---------------------------- 1 file changed, 90 insertions(+), 129 deletions(-) diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm index 6a95d7e52..506af3f11 100644 --- a/src/gtk/gio.scm +++ b/src/gtk/gio.scm @@ -554,25 +554,33 @@ USA. (set-alien/ctype! alien '|GFileInputStream|))) (define (gfile-read gfile) - (let* ((gstream (make-g-input-stream)) + (gfile-open gfile 'OPEN + make-g-input-stream + (named-lambda (open-callout + gfile* priority gcancellable* callback id) + (C-call "g_file_read_async" + gfile* priority gcancellable* callback id)) + make-open-finish-callback + setup-input)) + +(define (gfile-open gfile operation make-gstream callout make-callback setup) + (let* ((gstream (make-gstream)) (gio-info (gio-cleanup-info gstream)) (queue (gio-queue gstream)) (gerror* (gio-cleanup-info-gerror-pointer gio-info)) (callback-id (without-interrupts ;don't leak callback IDs (lambda () - (let* ((alien (gobject-alien gstream)) - (id (make-open-finish-callback alien queue gerror*))) - (set-gio-cleanup-info-pending-op! gio-info 'OPEN) + (let ((id (make-callback (gobject-alien gstream) queue gerror*))) + (set-gio-cleanup-info-pending-op! gio-info operation) (set-gio-cleanup-info-callback-id! gio-info id) id))))) (let retry () - (C-call "g_file_read_async" - (gobject-alien gfile) - (gio-priority gstream) - (gobject-alien (gio-cleanup-info-gcancellable gio-info)) - (C-callback "async_ready") - callback-id) + (callout (gobject-alien gfile) + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) + (C-callback "async_ready") + callback-id) (let ((value (thread-queue/dequeue! queue))) (cond ((eq? value #t) (set-gio-cleanup-info-pending-op! gio-info #f) @@ -580,11 +588,7 @@ USA. (lambda () (de-register-c-callback callback-id) (set-gio-cleanup-info-callback-id! gio-info #f) - (let ((info (g-input-stream-cleanup-info gstream))) - (set-g-input-stream-cleanup-info-read-id! - info (make-read-finish-callback queue gerror*)) - (set-g-input-stream-cleanup-info-skip-id! - info (make-skip-finish-callback queue gerror*))))) + (setup gstream queue gerror*))) gstream) ((equal? value "The specified location is not mounted") (gfile-mount gfile) @@ -607,6 +611,13 @@ USA. (%trace ";open-finish-callback "alien" "queue"\n") (%queue! queue #t)))))) +(define (setup-input gstream queue gerror*) + (let ((info (g-input-stream-cleanup-info gstream))) + (set-g-input-stream-cleanup-info-read-id! + info (make-read-finish-callback queue gerror*)) + (set-g-input-stream-cleanup-info-skip-id! + info (make-skip-finish-callback queue gerror*)))) + (define-class ()) @@ -617,12 +628,14 @@ USA. (define (gfile-append-to gfile . flags) (let ((flags* (->gfile-create-flags flags))) - (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))) + (gfile-open gfile 'APPEND-TO + make-g-output-stream + (named-lambda (append-to-callout + gfile* priority gcancellable* callback id) + (C-call "g_file_append_to_async" + gfile* flags* priority gcancellable* callback id)) + make-append-to-finish-callback + setup-output))) (define (->gfile-create-flags flags) (reduce-left fix:or 0 (map ->gfile-create-flag flags))) @@ -638,33 +651,54 @@ USA. (C-callback (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)))) + (g-output-stream-finish alien queue gerror* 'APPEND-TO)))) + +(define (g-output-stream-finish alien queue gerror* op) + (if (alien-null? alien) + (let ((message (%gerror-message gerror*))) + (%trace ";"op"-finish-callback "message" "queue"\n") + (%queue! queue message)) + (begin + (%trace ";"op"-finish-callback "alien" "queue"\n") + (%queue! queue #t)))) + +(define (setup-output gstream queue gerror*) + (let ((info (g-output-stream-cleanup-info gstream))) + (set-g-output-stream-cleanup-info-write-id! + info (make-write-finish-callback queue gerror*)) + (set-g-output-stream-cleanup-info-flush-id! + info (make-flush-finish-callback queue gerror*)))) (define (gfile-create gfile . flags) (let ((flags* (->gfile-create-flags flags))) - (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))) + (gfile-open gfile 'CREATE + make-g-output-stream + (named-lambda (create-callout + gfile* priority gcancellable* callback id) + (C-call "g_file_create_async" + gfile* flags* priority gcancellable* callback id)) + make-create-finish-callback + setup-output))) (define (make-create-finish-callback alien queue gerror*) (C-callback (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)))) + (g-output-stream-finish alien queue gerror* 'CREATE)))) (define (gfile-replace gfile etag backup? . flags) (let ((etag (->gfile-etag etag)) (make-backups (if backup? 1 0)) (flags* (->gfile-create-flags flags))) - (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))) + (gfile-open gfile 'REPLACE + make-g-output-stream + (named-lambda (replace-callout + gfile* priority gcancellable* callback id) + (C-call "g_file_replace_async" + gfile* etag make-backups flags* + priority gcancellable* callback id)) + make-replace-finish-callback + setup-output))) (define-integrable (->gfile-etag etag) (cond ((and (alien? etag) (eq? (alien/ctype etag) '|GFile etag|)) @@ -678,58 +712,7 @@ USA. (C-callback (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-write gfile op callout make-callback) - (let* ((gstream (make-g-output-stream)) - (gio-info (gio-cleanup-info gstream)) - (queue (gio-queue gstream)) - (gerror* (gio-cleanup-info-gerror-pointer gio-info)) - (callback-id - (without-interrupts ;don't leak callback IDs - (lambda () - (let* ((alien (gobject-alien gstream)) - (id (make-callback alien queue gerror*))) - (set-gio-cleanup-info-pending-op! gio-info op) - (set-gio-cleanup-info-callback-id! gio-info id) - id))))) - (let retry () - (callout (gobject-alien gfile) - (gio-priority gstream) - (gobject-alien (gio-cleanup-info-gcancellable gio-info)) - (C-callback "async_ready") - callback-id) - (let ((value (thread-queue/dequeue! queue))) - (cond ((or (eq? value #t) - (equal? value "Location is already mounted")) - (set-gio-cleanup-info-pending-op! gio-info #f) - (without-interrupts - (lambda () - (de-register-c-callback callback-id) - (set-gio-cleanup-info-callback-id! gio-info #f) - (let ((info (g-output-stream-cleanup-info gstream))) - (set-g-output-stream-cleanup-info-write-id! - info (make-write-finish-callback queue gerror*)) - (set-g-output-stream-cleanup-info-flush-id! - info (make-flush-finish-callback queue gerror*))))) - gstream) - ((equal? value "The specified location is not mounted") - (gfile-mount gfile) - (retry)) - ((string? value) - (set-gio-cleanup-info-pending-op! gio-info 'ERROR) - (error (string-append (gfile-uri gfile)":") value)) - (else - (error "Unexpected value from:" queue gstream))))))) - -(define-integrable-operator (g-output-stream-finish alien queue gerror* op) - (if (alien-null? alien) - (let ((message (%gerror-message gerror*))) - (%trace ";"op"-finish-callback "message" "queue"\n") - (%queue! queue message)) - (begin - (%trace ";"op"-finish-callback "alien" "queue"\n") - (%queue! queue #t)))) + (g-output-stream-finish alien queue gerror* 'REPLACE)))) (define-class ( (constructor ())) ()) @@ -855,6 +838,7 @@ USA. (define-class ( (constructor ())) () + ;; Nascent gfile-enumerator-cleanup. Just a GList at the mo'. (ginfos define accessor initializer (lambda () (make-alien '|GList|)))) @@ -892,48 +876,25 @@ USA. (define (gfile-enumerate-children gfile attributes follow-symlinks?) (guarantee-string attributes 'gfile-enumerate-children) - (let* ((genum (make-gfile-enumerator)) - (gio-info (gio-cleanup-info genum)) - (queue (gio-queue genum)) - (gerror* (gio-cleanup-info-gerror-pointer gio-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-gio-cleanup-info-pending-op! gio-info 'OPEN) - (set-gio-cleanup-info-callback-id! gio-info id) - id))))) - (let retry () - (C-call "g_file_enumerate_children_async" - (gobject-alien gfile) - attributes - (if follow-symlinks? - (C-enum "G_FILE_QUERY_INFO_NONE") - (C-enum "G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS")) - (gio-priority genum) - (gobject-alien (gio-cleanup-info-gcancellable gio-info)) - (C-callback "async_ready") - callback-id) - (let ((value (thread-queue/dequeue! queue))) - (cond ((eq? value #t) - (set-gio-cleanup-info-pending-op! gio-info #f) - (without-interrupts - (lambda () - (de-register-c-callback callback-id) - (set-gio-cleanup-info-callback-id! - gio-info - (make-next-files-finish-callback - (gfile-enumerator-ginfos genum) queue gerror*)))) - genum) - ((equal? value "The specified location is not mounted") - (gfile-mount gfile) - (retry)) - ((string? value) - (set-gio-cleanup-info-pending-op! gio-info 'ERROR) - (error (string-append (gfile-uri gfile) ":") value)) - (else - (error "Unexpected value from:" queue genum))))))) + (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 + (if follow-symlinks? + (C-enum "G_FILE_QUERY_INFO_NONE") + (C-enum "G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS")) + priority gcancellable* callback id)) + make-enumerator-finish-callback + setup-enumerator)) + +(define (setup-enumerator genum queue gerror*) + (let ((info (gio-cleanup-info genum))) + (set-gio-cleanup-info-callback-id! + info (make-next-files-finish-callback + (gfile-enumerator-ginfos genum) queue gerror*)))) (define (make-enumerator-finish-callback alien queue gerror*) (C-callback -- 2.25.1