From 3682d6e0f8268e36eb861b4d79a03aa76994bf96 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 27 Jul 2011 22:18:22 -0700 Subject: [PATCH] Factored out a class. --- src/gtk/gio.scm | 654 +++++++++++++++++++++--------------------------- 1 file changed, 285 insertions(+), 369 deletions(-) diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm index 26a0a4ed0..847bd9608 100644 --- a/src/gtk/gio.scm +++ b/src/gtk/gio.scm @@ -84,77 +84,46 @@ USA. (named-lambda (g-stream-sink/write-bytes buffer start end) (g-output-stream-write gstream buffer start end))))) -(define-class - ;; Abstract -- slots common to s and s. +(define-class () - (io-priority + (priority define standard initial-value 10) (queue define accessor initializer (lambda () (make-thread-queue 1))) - (buffer - define standard initializer (lambda () (malloc buffer-size 'uchar))) - - (buffer-size - define standard initializer (lambda () buffer-size))) - -(define buffer-size #x1000) - -;;; When these streams are GCed, any pending operation must be -;;; cancelled. This ensures that the operation's finish callback will -;;; not be called and can be safely de-registered. The cancel-info -;;; includes the GError *pointer, GCancellable, the finish callback -;;; ids, AND a flag to indicate whether an operation is pending and -;;; thus whether the GCancellable should be used. - -;;; The subclasses' cancel-info is separated from the so -;;; that the latter can be GCed while the -info stays with a -;;; gc-cleanup thunk. - -(define-class ( (constructor ())) - () - (cancel-info - define accessor initializer + (gio-cleanup-info + define accessor accessor gio-cleanup-info initializer (lambda () - (make-g-input-stream-cancel-info - #f #f (make-gcancellable) (make-gerror*) #f #f)))) - -(define-integrable (make-gerror*) - (make-alien '(* |GError|))) - -(define-structure g-input-stream-cancel-info - 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 + (make-gio-cleanup-info + #f #f (make-gcancellable) (make-alien '(* |GError|)))))) + +;;; When a is GCed, any pending operation must be cancelled. +;;; This ensures that the operation's finish callback will not be +;;; called and can be safely de-registered. The gio-cleanup-info +;;; includes the GCancellable, the finish callback id, AND a flag to +;;; indicate whether an operation is pending and thus whether the +;;; GCancellable should be used. It also includes the GError pointer +;;; which, if not null, references a GError that must be freed. + +(define-structure gio-cleanup-info + pending-op ; #f, , CLOSED or ERROR. The first one + ; means "idle" and the last two are more + ; permanent states than "op"s. might be + ; OPEN, READ, SKIP, WRITE, QUERY, NEXT, CLOSE, + ; etc. + callback-id ; #f or op's finish callback ID gcancellable ; a GCancellable alien - gerror-pointer ; a (* GError) alien + gerror-pointer) ; a malloced (* GError) alien - ;; 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 - ) - -(define-method initialize-instance ((object )) +(define-method initialize-instance ((object )) (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)) - (C-call "g_malloc0" gerror* (C-sizeof "*")) + (let* ((gio-info (gio-cleanup-info object)) + (gerror* (gio-cleanup-info-gerror-pointer gio-info))) + (C-call "g_malloc0" gerror* (C-sizeof "* GError")) (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))) - (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) @@ -163,10 +132,10 @@ USA. (type-name (caddr form)) (slot (cadddr form))) (let ((accessor (close-syntax - (symbol type-name '-CANCEL-INFO- slot) + (symbol type-name '-CLEANUP-INFO- slot) environment)) (modifier (close-syntax - (symbol 'SET- type-name '-CANCEL-INFO- slot '!) + (symbol 'SET- type-name '-CLEANUP-INFO- slot '!) environment))) `(LET ((ID (,accessor ,info))) (IF ID @@ -174,15 +143,7 @@ USA. (DE-REGISTER-C-CALLBACK ID) (,modifier ,info #F)))))))))) -(define (cleanup-g-input-stream info) - ;; For gc-cleanup. Run without-interrupts. - (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*) +(define-integrable-operator (cleanup-gerror-pointer gerror*) (if (not (alien-null? gerror*)) (let ((gerror (make-alien '|GError|))) (C-> gerror* "* GError" gerror) @@ -191,34 +152,84 @@ USA. ((ucode-primitive c-free 1) gerror*) (alien-null! gerror*)))) +(define-integrable-operator (cleanup-gio gio-info) + (let ((pending-op (gio-cleanup-info-pending-op gio-info))) + (if (not (memq pending-op '(#f ERROR CLOSED))) + (C-call "g_cancellable_cancel" + (gobject-alien (gio-cleanup-info-gcancellable gio-info))))) + (cleanup-callback-id gio-info gio callback-id) + (gobject-unref! (gio-cleanup-info-gcancellable gio-info)) + (cleanup-gerror-pointer (gio-cleanup-info-gerror-pointer gio-info))) + +(define-integrable (guarantee-gio-idle gio) + (let* ((gio-info (gio-cleanup-info gio)) + (pending-op (gio-cleanup-info-pending-op gio-info))) + (if (not (memq pending-op '(#f ERROR CLOSED))) + (error "Operation pending:" gio)) + (if pending-op + (error "Not open:" gio)))) + +(define-class + () + (buffer define standard initializer (lambda () (malloc buffer-size 'uchar))) + (buffer-size define standard initializer (lambda () buffer-size))) + +(define buffer-size #x1000) + +(define-class ( (constructor ())) + () + (cleanup-info + define accessor initializer (lambda () + (make-g-input-stream-cleanup-info #f #f)))) + +(define-structure g-input-stream-cleanup-info + ;; 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 + +(define-method initialize-instance ((object )) + (call-next-method object) + (add-gc-cleanup object (make-g-input-stream-cleanup + (gio-cleanup-info object) + (g-input-stream-cleanup-info object)))) + +(define (make-g-input-stream-cleanup gio-info info) + (named-lambda (g-input-stream-cleanup) + (cleanup-g-input-stream gio-info info))) + +(define (cleanup-g-input-stream gio-info info) + ;; For gc-cleanup. Run without-interrupts. + (cleanup-gio gio-info) + (cleanup-callback-id info g-input-stream read-id) + (cleanup-callback-id info g-input-stream skip-id)) + (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))) - (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* ((gio-info (gio-cleanup-info gstream)) + (info (g-input-stream-cleanup-info gstream)) + (callback-id (g-input-stream-cleanup-info-read-id info))) + (guarantee-gio-idle gstream) (let* ((count (fix:- end start)) (async-buffer (ensure-buffer gstream count))) - (set-g-input-stream-cancel-info-pending-op! info 'READ) + (set-gio-cleanup-info-pending-op! gio-info 'READ) (C-call "g_input_stream_read_async" (gobject-alien gstream) async-buffer count - (g-stream-io-priority gstream) - (gobject-alien (g-input-stream-cancel-info-gcancellable info)) + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) (C-callback "async_ready") callback-id) - (let* ((queue (g-stream-queue gstream)) + (let* ((queue (gio-queue gstream)) (value (thread-queue/dequeue! queue))) (if (string? value) (begin - (set-g-input-stream-cancel-info-pending-op! info 'ERROR) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) (error "Error reading:" gstream value)) (begin (c-peek-bytes async-buffer 0 value buffer start) - (set-g-input-stream-cancel-info-pending-op! info #f) + (set-gio-cleanup-info-pending-op! gio-info #f) value)))))) (define-integrable (ensure-buffer gstream count) @@ -264,29 +275,26 @@ USA. (maybe-yield-gtk)) (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))) - (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) + (let* ((gio-info (gio-cleanup-info gstream)) + (info (g-input-stream-cleanup-info gstream)) + (callback-id (g-input-stream-cleanup-info-skip-id info))) + (guarantee-gio-idle gstream) + (set-gio-cleanup-info-pending-op! gio-info 'SKIP) (C-call "g_input_stream_skip_async" - (gobject-alien gstream) - count - (g-stream-io-priority gstream) - (gobject-alien (g-input-stream-cancel-info-gcancellable info)) - (C-callback "async_ready") - callback-id) - (let* ((queue (g-stream-queue gstream)) + (gobject-alien gstream) + count + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) + (C-callback "async_ready") + callback-id) + (let* ((queue (gio-queue gstream)) (value (thread-queue/dequeue! queue))) (if (string? value) (begin - (set-g-input-stream-cancel-info-pending-op! info 'ERROR) - (error "Error reading:" gstream value)) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) + (error "Error skipping:" gstream value)) (begin - (set-g-input-stream-cancel-info-pending-op! info #f) + (set-gio-cleanup-info-pending-op! gio-info #f) value))))) (define (make-skip-finish-callback queue gerror*) @@ -302,38 +310,34 @@ USA. (%queue! queue bytes))))))) (define (g-input-stream-close gstream) - (let* ((info (g-input-stream-cancel-info gstream)) - (queue (g-stream-queue gstream)) - (gerror* (g-input-stream-cancel-info-gerror-pointer info)) - (read-id (g-input-stream-cancel-info-read-id info))) - (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* ((gio-info (gio-cleanup-info gstream)) + (queue (gio-queue gstream)) + (gerror* (gio-cleanup-info-gerror-pointer gio-info))) + (guarantee-gio-idle gstream) (let ((callback-id (without-interrupts ;don't leak callback IDs (lambda () (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) + (set-gio-cleanup-info-pending-op! gio-info 'CLOSE) + (set-gio-cleanup-info-callback-id! gio-info id) id))))) (C-call "g_input_stream_close_async" (gobject-alien gstream) - (g-stream-io-priority gstream) - (gobject-alien (g-input-stream-cancel-info-gcancellable info)) + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) (C-callback "async_ready") callback-id) (let ((value (thread-queue/dequeue! queue))) (if (string? value) (begin - (set-g-input-stream-cancel-info-pending-op! info 'ERROR) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) (error "Error in g-input-stream-close:" gstream value)) (begin - (set-g-input-stream-cancel-info-pending-op! info 'CLOSED) + (set-gio-cleanup-info-pending-op! gio-info 'CLOSED) (without-interrupts (lambda () - (cleanup-g-input-stream info))) + (cleanup-g-input-stream + gio-info (g-input-stream-cleanup-info gstream)))) value)))))) (define (make-input-close-finish-callback queue gerror*) @@ -350,79 +354,58 @@ USA. (define-class ( (constructor ())) () - (cancel-info - define accessor initializer - (lambda () - (make-g-output-stream-cancel-info - #f #f (make-gcancellable) (make-alien '(* |GError|)) #f #f)))) - -(define-structure g-output-stream-cancel-info - 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 ; a (* GError) alien - - ;; To avoid registering write or flush finish callbacks for every - ;; write or flush (a LOT of registering/deregistering!), the open - ;; operation (i.e. gfile-write) registers them in advance. + (cleanup-info + define accessor initializer (lambda () + (make-g-output-stream-cleanup-info #f #f)))) + +(define-structure g-output-stream-cleanup-info + ;; To avoid registering a write or flush finish callback for every + ;; write or flush (a LOT of de/registering!), the open operation + ;; (i.e. gfile-replace) registers them in advance. write-id ; #f or the write finish callback ID - flush-id ; #f or the flush finish callback ID - ) + flush-id) ; #f or the flush finish callback ID (define-method initialize-instance ((object )) (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)) - ((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) + (add-gc-cleanup object (make-g-output-stream-cleanup + (gio-cleanup-info object) + (g-output-stream-cleanup-info object)))) + +(define (make-g-output-stream-cleanup gio-info info) (named-lambda (g-output-stream-cleanup) - (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) + (cleanup-g-output-stream gio-info info))) + +(define (cleanup-g-output-stream gio-info info) ;; For gc-cleanup. Run without-interrupts. - (cleanup-callback-id info g-output-stream callback-id) + (cleanup-gio gio-info) (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))) + (cleanup-callback-id info g-output-stream flush-id)) (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))) - (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* ((gio-info (gio-cleanup-info gstream)) + (info (g-output-stream-cleanup-info gstream)) + (callback-id (g-output-stream-cleanup-info-write-id info))) + (guarantee-gio-idle gstream) (let* ((count (fix:- end start)) (async-buffer (ensure-buffer gstream count))) - (set-g-output-stream-cancel-info-pending-op! info 'WRITE) + (set-gio-cleanup-info-pending-op! gio-info 'WRITE) (c-poke-bytes async-buffer 0 count buffer start) (C-call "g_output_stream_write_async" (gobject-alien gstream) async-buffer count - (g-stream-io-priority gstream) - (gobject-alien (g-output-stream-cancel-info-gcancellable info)) + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) (C-callback "async_ready") callback-id) - (let* ((queue (g-stream-queue gstream)) + (let* ((queue (gio-queue gstream)) (value (thread-queue/dequeue! queue))) (if (string? value) (begin - (set-g-output-stream-cancel-info-pending-op! info 'ERROR) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) (error "Error writing:" gstream value)) (begin - (set-g-input-stream-cancel-info-pending-op! info #f) + (set-gio-cleanup-info-pending-op! gio-info #f) value)))))) (define (make-write-finish-callback queue gerror*) @@ -439,28 +422,25 @@ USA. (%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))) - (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) + (let* ((gio-info (gio-cleanup-info gstream)) + (info (g-output-stream-cleanup-info gstream)) + (callback-id (g-output-stream-cleanup-info-flush-id info))) + (guarantee-gio-idle gstream) + (set-gio-cleanup-info-pending-op! gio-info 'FLUSH) (C-call "g_output_stream_flush_async" (gobject-alien gstream) - (g-stream-io-priority gstream) - (gobject-alien (g-output-stream-cancel-info-gcancellable info)) + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) (C-callback "async_ready") callback-id) - (let* ((queue (g-stream-queue gstream)) + (let* ((queue (gio-queue gstream)) (value (thread-queue/dequeue! queue))) (if (string? value) (begin - (set-g-output-stream-cancel-info-pending-op! info 'ERROR) - (error "Error writing:" gstream value)) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) + (error "Error flushing:" gstream value)) (begin - (set-g-input-stream-cancel-info-pending-op! info #f) + (set-gio-cleanup-info-pending-op! gio-info #f) (not (fix:zero? value))))))) (define (make-flush-finish-callback queue gerror*) @@ -476,38 +456,34 @@ USA. (%queue! queue #t)))))) (define (g-output-stream-close gstream) - (let* ((info (g-output-stream-cancel-info gstream)) - (queue (g-stream-queue gstream)) - (gerror* (g-output-stream-cancel-info-gerror-pointer info)) - (write-id (g-output-stream-cancel-info-write-id info))) - (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* ((gio-info (gio-cleanup-info gstream)) + (queue (gio-queue gstream)) + (gerror* (gio-cleanup-info-gerror-pointer gio-info))) + (guarantee-gio-idle gstream) (let ((callback-id (without-interrupts ;don't leak callback IDs (lambda () (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) + (set-gio-cleanup-info-pending-op! gio-info 'CLOSE) + (set-gio-cleanup-info-callback-id! gio-info id) id))))) (C-call "g_output_stream_close_async" (gobject-alien gstream) - (g-stream-io-priority gstream) - (gobject-alien (g-output-stream-cancel-info-gcancellable info)) + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) (C-callback "async_ready") callback-id) (let ((value (thread-queue/dequeue! queue))) (if (string? value) (begin - (set-g-output-stream-cancel-info-pending-op! info 'ERROR) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) (error "Error in g-output-stream-close:" gstream value)) (begin - (set-g-output-stream-cancel-info-pending-op! info 'CLOSED) + (set-gio-cleanup-info-pending-op! gio-info 'CLOSED) (without-interrupts (lambda () - (cleanup-g-output-stream info))) + (cleanup-g-output-stream + gio-info (g-output-stream-cleanup-info gstream)))) value)))))) (define (make-output-close-finish-callback queue gerror*) @@ -532,38 +508,39 @@ USA. (define (gfile-read gfile) (let* ((gstream (make-g-input-stream)) - (info (g-input-stream-cancel-info gstream)) - (queue (g-stream-queue gstream)) - (gerror* (g-input-stream-cancel-info-gerror-pointer info)) + (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-g-input-stream-cancel-info-pending-op! info 'OPEN) - (set-g-input-stream-cancel-info-callback-id! info id) + (set-gio-cleanup-info-pending-op! gio-info 'OPEN) + (set-gio-cleanup-info-callback-id! gio-info id) id))))) (C-call "g_file_read_async" (gobject-alien gfile) - (g-stream-io-priority gstream) - (gobject-alien (g-input-stream-cancel-info-gcancellable info)) + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) (C-callback "async_ready") callback-id) (let ((value (thread-queue/dequeue! queue))) (if (string? value) (begin - (set-g-input-stream-cancel-info-pending-op! info 'ERROR) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) (error "Error in gfile-read:" gfile value)) (begin - (set-g-input-stream-cancel-info-pending-op! info #f) + (set-gio-cleanup-info-pending-op! gio-info #f) (without-interrupts (lambda () (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-read-finish-callback queue gerror*)) - (set-g-input-stream-cancel-info-skip-id! - info (make-skip-finish-callback queue gerror*)))) + (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*))))) gstream))))) (define (make-open-finish-callback alien queue gerror*) @@ -653,37 +630,38 @@ USA. (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)) - (queue (g-stream-queue 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-callback alien queue gerror*))) - (set-g-output-stream-cancel-info-pending-op! info op) - (set-g-output-stream-cancel-info-callback-id! info id) + (set-gio-cleanup-info-pending-op! gio-info op) + (set-gio-cleanup-info-callback-id! gio-info id) id))))) (callout (gobject-alien gfile) - (g-stream-io-priority gstream) - (gobject-alien (g-output-stream-cancel-info-gcancellable info)) + (gio-priority gstream) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) (C-callback "async_ready") callback-id) (let ((value (thread-queue/dequeue! queue))) (if (string? value) (begin - (set-g-output-stream-cancel-info-pending-op! info 'ERROR) - (error value gfile)) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) + (error (string "Error in gfile-" op ":") gfile value)) (begin - (set-g-output-stream-cancel-info-pending-op! info #f) + (set-gio-cleanup-info-pending-op! gio-info #f) (without-interrupts (lambda () (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-write-finish-callback queue gerror*)) - (set-g-output-stream-cancel-info-flush-id! - info (make-flush-finish-callback queue gerror*)))) + (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))))) (define-integrable-operator (g-output-stream-finish alien queue gerror* op) @@ -696,57 +674,29 @@ USA. (%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*))) + (add-gc-cleanup object (make-ginfo-cleanup (gio-cleanup-info object)))) -(define (make-ginfo-cleanup info) +(define (make-ginfo-cleanup gio-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)))) + (cleanup-gio gio-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)) + (gio-info (gio-cleanup-info ginfo)) + (queue (gio-queue ginfo)) + (gerror* (gio-cleanup-info-gerror-pointer gio-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) + (set-gio-cleanup-info-pending-op! gio-info 'QUERY) + (set-gio-cleanup-info-callback-id! gio-info id) id))))) (C-call "g_file_query_info_async" (gobject-alien gfile) @@ -754,21 +704,20 @@ USA. (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)) + (gio-priority ginfo) + (gobject-alien (gio-cleanup-info-gcancellable gio-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) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) (error "Error in gfile-query-info:" gfile value)) (begin - (set-ginfo-cancel-info-pending-op! info 'CLOSED) + (set-gio-cleanup-info-pending-op! gio-info 'CLOSED) (without-interrupts (lambda () - (de-register-c-callback callback-id) - (set-ginfo-cancel-info-callback-id! info #f))) + (cleanup-gio gio-info))) ginfo))))) (define (make-query-finish-callback alien queue gerror*) @@ -842,82 +791,55 @@ USA. (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 + () + (ginfos + define accessor initializer (lambda () (make-alien '|GList|)))) (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*))) + (add-gc-cleanup object (make-gfile-enumerator-cleanup + (gio-cleanup-info object) + (gfile-enumerator-ginfos object)))) -(define (make-gfile-enumerator-cleanup info) +(define (make-gfile-enumerator-cleanup gio-info ginfos) (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) + (cleanup-gfile-enumerator gio-info ginfos))) + +(define (cleanup-gfile-enumerator gio-info ginfos) ;; 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))))))) + (cleanup-gio gio-info) + (cleanup-ginfos ginfos)) + +(define (cleanup-ginfos glist) + (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)) + (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-gfile-enumerator-cancel-info-pending-op! info 'OPEN) - (set-gfile-enumerator-cancel-info-callback-id! info id) + (set-gio-cleanup-info-pending-op! gio-info 'OPEN) + (set-gio-cleanup-info-callback-id! gio-info id) id))))) (C-call "g_file_enumerate_children_async" (gobject-alien gfile) @@ -925,22 +847,23 @@ USA. (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)) + (gio-priority genum) + (gobject-alien (gio-cleanup-info-gcancellable gio-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) + (set-gio-cleanup-info-pending-op! gio-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) + (begin + (set-gio-cleanup-info-pending-op! gio-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*)))) + (set-gio-cleanup-info-callback-id! + gio-info (make-next-files-finish-callback + (gfile-enumerator-ginfos genum) queue gerror*)))) genum))))) (define (make-enumerator-finish-callback alien queue gerror*) @@ -949,7 +872,7 @@ USA. (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") + (%trace ";enumerator-finish-callback \""message"\" "queue"\n") (%queue! queue message)) (begin (%trace ";enumerator-finish-callback "alien" "queue"\n") @@ -957,33 +880,29 @@ USA. (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) + (let* ((gio-info (gio-cleanup-info genum)) + (callback-id (gio-cleanup-info-callback-id gio-info))) + (guarantee-gio-idle genum) + (set-gio-cleanup-info-pending-op! gio-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)) + (gio-priority genum) + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) (C-callback "async_ready") callback-id) - (let* ((queue (gfile-enumerator-queue genum)) + (let* ((queue (gio-queue genum)) (value (thread-queue/dequeue! queue))) (if (string? value) (begin - (set-gfile-enumerator-cancel-info-pending-op! info 'ERROR) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) (error "Error in gfile-enumerator-next-files:" genum value)) (begin - (set-gfile-enumerator-cancel-info-pending-op! info #f) - (make-ginfos info)))))) + (set-gio-cleanup-info-pending-op! gio-info #f) + (make-ginfos genum)))))) -(define (make-ginfos info) - (let* ((glist (gfile-enumerator-cancel-info-ginfos info)) +(define (make-ginfos genum) + (let* ((glist (gfile-enumerator-ginfos genum)) (scan (copy-alien glist)) (ginfo (make-alien '|GFileInfo|)) (ginfos @@ -1025,39 +944,36 @@ USA. (%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* ((gio-info (gio-cleanup-info genum)) + (ginfos (gfile-enumerator-ginfos genum)) + (queue (gio-queue genum)) + (gerror* (gio-cleanup-info-gerror-pointer gio-info))) + (guarantee-gio-idle genum) (let ((callback-id (without-interrupts ;don't leak callback IDs (lambda () - (let ((old (gfile-enumerator-cancel-info-callback-id info))) + (let ((old (gio-cleanup-info-callback-id gio-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) + (set-gio-cleanup-info-pending-op! gio-info 'CLOSE) + (set-gio-cleanup-info-callback-id! gio-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)) + (gio-priority genum) + (gobject-alien (gio-cleanup-info-gcancellable gio-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) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) (error "Error in gfile-enumerator-close:" genum value)) (begin - (set-gfile-enumerator-cancel-info-pending-op! info 'CLOSED) + (set-gio-cleanup-info-pending-op! gio-info 'CLOSED) (without-interrupts (lambda () - (cleanup-gfile-enumerator info))) + (cleanup-gfile-enumerator gio-info ginfos))) value)))))) (define (make-enumerator-close-finish-callback queue gerror*) -- 2.25.1