From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Fri, 12 Aug 2011 18:21:54 +0000 (-0700)
Subject: Factored gfile-open out of -read, -open-write and -enumerate-children.
X-Git-Tag: mit-scheme-pucked-9.2.12~645
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bc56160529adc6afa9ad47fafff5bd063b70e02d;p=mit-scheme.git
Factored gfile-open out of -read, -open-write and -enumerate-children.
---
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 <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))))
(define-class (<gfile-info> (constructor ()))
(<gio>))
@@ -855,6 +838,7 @@ USA.
(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