(named-lambda (g-stream-sink/write-bytes buffer start end)
(g-output-stream-write gstream buffer start end)))))
\f
-(define-class <g-stream>
- ;; Abstract -- slots common to <g-input-stream>s and <g-output-stream>s.
+(define-class <gio>
(<gobject>)
- (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 <g-stream> so
-;;; that the latter can be GCed while the -info stays with a
-;;; gc-cleanup thunk.
-
-(define-class (<g-input-stream> (constructor ()))
- (<g-stream>)
- (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 <gio> 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, <opname>, CLOSED or ERROR. The first one
+ ; means "idle" and the last two are more
+ ; permanent states than "op"s. <opname> 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 <g-input-stream>))
+(define-method initialize-instance ((object <gio>))
(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)
(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
(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)
((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 <g-stream>
+ (<gio>)
+ (buffer define standard initializer (lambda () (malloc buffer-size 'uchar)))
+ (buffer-size define standard initializer (lambda () buffer-size)))
+
+(define buffer-size #x1000)
+
+(define-class (<g-input-stream> (constructor ()))
+ (<g-stream>)
+ (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 <g-input-stream>))
+ (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)
(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*)
(%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*)
\f
(define-class (<g-output-stream> (constructor ()))
(<g-stream>)
- (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 <g-output-stream>))
(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*)
(%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*)
(%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*)
(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*)
(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)
(%queue! queue #t))))
\f
(define-class (<gfile-info> (constructor ()))
- (<gobject>)
-
- (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
+ (<gio>))
(define-method initialize-instance ((object <gfile-info>))
(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)
(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*)
(else (error "Unexpected GFileAttributeType:" type)))))
\f
(define-class (<gfile-enumerator> (constructor ()))
- (<gobject>)
-
- (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
+ (<gio>)
+ (ginfos
+ define accessor initializer (lambda () (make-alien '|GList|))))
(define-method initialize-instance ((object <gfile-enumerator>))
(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)
(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*)
(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")
(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
(%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*)
projects / mit-scheme.git / commitdiff