Factored gfile-open out of -read, -open-write and -enumerate-children.

diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm
index 6a95d7e5237b7da88bd25f36cc67afe019e7df97..506af3f11e82212ae8384b13eb15c6206e679e9c 100644 (file)
--- 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*))))
+\f
 (define-class <gfile-output-stream>
     (<g-output-stream>))
 
@@ -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))))
 \f
 (define-class (<gfile-info> (constructor ()))
     (<gio>))
@@ -855,6 +838,7 @@ USA.
 \f
 (define-class (<gfile-enumerator> (constructor ()))
     (<gio>)
+  ;; 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