(make-alien '(* |GError|)))
(define-structure g-input-stream-cancel-info
- pending-op ; #f, OPEN, READ, SKIP, CLOSE or ERROR.
+ 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
gcancellable ; a GCancellable alien
- gerror-pointer ; null or malloced GError* that MAY ref. a GError
+ gerror-pointer ; a (* GError) alien
- ;; To avoid registering read or skip finish callbacks for every read
- ;; or skip (a LOT of registering/deregistering!), the open operation
+ ;; 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
(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))
+ (add-gc-cleanup object (make-g-input-stream-cleanup info))
(C-call "g_malloc0" gerror* (C-sizeof "*"))
(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))
- (gcancellable (g-input-stream-cancel-info-gcancellable info)))
- (if (and pending-op (not (eq? pending-op 'ERROR)))
- (C-call "g_cancellable_cancel" gcancellable))
- (cleanup-g-input-stream info))))
+ (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)
(if (syntax-match? '(IDENTIFIER SYMBOL SYMBOL) (cdr form))
(let ((info (close-syntax (cadr form) environment))
- (i/o (caddr form))
+ (type-name (caddr form))
(slot (cadddr form)))
- (let ((accessor (symbol ' G- i/o '-STREAM-CANCEL-INFO- slot))
- (modifier (symbol 'SET-G- i/o '-STREAM-CANCEL-INFO- slot '!)))
+ (let ((accessor (close-syntax
+ (symbol type-name '-CANCEL-INFO- slot)
+ environment))
+ (modifier (close-syntax
+ (symbol 'SET- type-name '-CANCEL-INFO- slot '!)
+ environment)))
`(LET ((ID (,accessor ,info)))
(IF ID
(BEGIN
(define (cleanup-g-input-stream info)
;; For gc-cleanup. Run without-interrupts.
- (cleanup-callback-id info input callback-id)
- (cleanup-callback-id info input read-id)
- (cleanup-callback-id info input skip-id)
- (cleanup-gerror-pointer (g-input-stream-cancel-info-gerror-pointer info))
- (gobject-unref! (g-input-stream-cancel-info-gcancellable info)))
+ (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*)
(if (not (alien-null? gerror*))
(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)))
- (if (not callback-id) (error "Not open:" gstream))
- (if (g-input-stream-cancel-info-pending-op info)
- (error "Operation pending:" gstream))
+ (let ((pending-op (g-input-stream-cancel-info-pending-op info)))
+ (if (memq pending-op '(#f ERROR CLOSED))
+ (error "Operation pending:" gstream))
+ (if pending-op
+ (error "Not open:" gstream)))
(let* ((count (fix:- end start))
(async-buffer (ensure-buffer gstream count)))
(set-g-input-stream-cancel-info-pending-op! info 'READ)
buffer*))
buffer)))
-(define (make-g-input-stream-read-finish-callback queue gerror*)
+(define (make-read-finish-callback queue gerror*)
(C-callback
- (named-lambda (g-input-stream-read-finish-callback source result)
+ (named-lambda (read-finish-callback source result)
(let ((bytes (C-call "g_input_stream_read_finish" source result gerror*)))
(if (fix:= bytes -1)
(let ((message (%gerror-message gerror*)))
- (%trace ";g-input-stream-read-finish-callback "message" "queue"\n")
+ (%trace ";read-finish-callback "message" "queue"\n")
(%queue! queue message))
(begin
- (%trace ";g-input-stream-read-finish-callback "bytes" "queue"\n")
+ (%trace ";read-finish-callback "bytes" "queue"\n")
(%queue! queue bytes)))))))
(define-integrable-operator (%gerror-message pointer)
(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)))
- (if (not callback-id) (error "Not open:" gstream))
- (if (g-input-stream-cancel-info-pending-op info)
- (error "Operation pending:" gstream))
+ (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)
(C-call "g_input_stream_skip_async"
(gobject-alien gstream)
(set-g-input-stream-cancel-info-pending-op! info #f)
value)))))
-(define (make-g-input-stream-skip-finish-callback queue gerror*)
+(define (make-skip-finish-callback queue gerror*)
(C-callback
- (named-lambda (g-input-stream-skip-finish-callback source result)
+ (named-lambda (skip-finish-callback source result)
(let ((bytes (C-call "g_input_stream_skip_finish" source result gerror*)))
(if (fix:= bytes -1)
(let ((message (%gerror-message gerror*)))
- (%trace ";g-input-stream-skip-finish-callback "message" "queue"\n")
+ (%trace ";skip-finish-callback "message" "queue"\n")
(%queue! queue message))
(begin
- (%trace ";g-input-stream-skip-finish-callback "bytes" "queue"\n")
+ (%trace ";skip-finish-callback "bytes" "queue"\n")
(%queue! queue bytes)))))))
(define (g-input-stream-close 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)))
- (if (not read-id) (error "Not open:" gstream))
- (if (g-input-stream-cancel-info-pending-op info) (error "Operation pending:" gstream))
+ (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 ((callback-id
(without-interrupts ;don't leak callback IDs
(lambda ()
- (let ((id (make-g-input-stream-close-finish-callback
- queue gerror*)))
+ (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)
id)))))
(set-g-input-stream-cancel-info-pending-op! info 'ERROR)
(error "Error in g-input-stream-close:" gstream value))
(begin
- (set-g-input-stream-cancel-info-pending-op! info #f)
+ (set-g-input-stream-cancel-info-pending-op! info 'CLOSED)
(without-interrupts
(lambda ()
(cleanup-g-input-stream info)))
value))))))
-(define (make-g-input-stream-close-finish-callback queue gerror*)
+(define (make-input-close-finish-callback queue gerror*)
(C-callback
- (named-lambda (g-input-stream-close-finish-callback source result)
+ (named-lambda (input-close-finish-callback source result)
(if (fix:zero?
(C-call "g_input_stream_close_finish" source result gerror*))
(let ((message (%gerror-message gerror*)))
- (%trace ";g-input-stream-close-finish-callback "message" "queue"\n")
+ (%trace ";input-close-finish-callback "message" "queue"\n")
(%queue! queue message))
(begin
- (%trace ";g-input-stream-close-finish-callback #t "queue"\n")
+ (%trace ";input-close-finish-callback #t "queue"\n")
(%queue! queue #t))))))
\f
(define-class (<g-output-stream> (constructor ()))
#f #f (make-gcancellable) (make-alien '(* |GError|)) #f #f))))
(define-structure g-output-stream-cancel-info
- pending-op ; #f, OPEN, WRITE, FLUSH, CLOSE or ERROR.
+ 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 ; null or malloced GError* that MAY ref. a GError
+ 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
(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))
+ (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)
(named-lambda (g-output-stream-cleanup)
- (let ((pending-op (g-output-stream-cancel-info-pending-op info))
- (gcancellable (g-output-stream-cancel-info-gcancellable info)))
- (if (and pending-op (not (eq? pending-op 'ERROR)))
- (C-call "g_cancellable_cancel" gcancellable))
- (cleanup-g-output-stream info))))
+ (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)
;; For gc-cleanup. Run without-interrupts.
- (cleanup-callback-id info output callback-id)
- (cleanup-callback-id info output write-id)
- (cleanup-callback-id info output flush-id)
- (cleanup-gerror-pointer (g-output-stream-cancel-info-gerror-pointer info))
- (gobject-unref! (g-output-stream-cancel-info-gcancellable info)))
+ (cleanup-callback-id info g-output-stream callback-id)
+ (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)))
(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)))
- (if (not callback-id) (error "Not open:" gstream))
- (if (g-output-stream-cancel-info-pending-op info)
- (error "Operation pending:" gstream))
+ (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* ((count (fix:- end start))
(async-buffer (ensure-buffer gstream count)))
(set-g-output-stream-cancel-info-pending-op! info 'WRITE)
(set-g-input-stream-cancel-info-pending-op! info #f)
value))))))
-(define (make-g-output-stream-write-finish-callback queue gerror*)
+(define (make-write-finish-callback queue gerror*)
(C-callback
- (named-lambda (g-output-stream-write-finish-callback source result)
+ (named-lambda (write-finish-callback source result)
(let ((bytes
(C-call "g_output_stream_write_finish" source result gerror*)))
(if (fix:= bytes -1)
(let ((message (%gerror-message gerror*)))
- (%trace ";g-output-stream-write-finish-callback "message
- " "queue"\n")
+ (%trace ";write-finish-callback "message" "queue"\n")
(%queue! queue message))
(begin
- (%trace ";g-output-stream-write-finish-callback "bytes" "queue"\n")
+ (%trace ";write-finish-callback "bytes" "queue"\n")
(%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)))
- (if (not callback-id) (error "Not open:" gstream))
- (if (g-output-stream-cancel-info-pending-op info)
- (error "Operation pending:" gstream))
- (set-g-output-stream-cancel-info-pending-op! info 'WRITE)
+ (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)
(C-call "g_output_stream_flush_async"
(gobject-alien gstream)
(g-stream-io-priority gstream)
(set-g-input-stream-cancel-info-pending-op! info #f)
(not (fix:zero? value)))))))
-(define (make-g-output-stream-flush-finish-callback queue gerror*)
+(define (make-flush-finish-callback queue gerror*)
(C-callback
- (named-lambda (g-output-stream-flush-finish-callback source result)
+ (named-lambda (flush-finish-callback source result)
(if (fix:zero?
(C-call "g_output_stream_flush_finish" source result gerror*))
(let ((message (%gerror-message gerror*)))
- (%trace ";g-output-stream-flush-finish-callback "message" "queue"\n")
+ (%trace ";flush-finish-callback "message" "queue"\n")
(%queue! queue message))
(begin
- (%trace ";g-output-stream-flush-finish-callback #t "queue"\n")
+ (%trace ";flush-finish-callback #t "queue"\n")
(%queue! queue #t))))))
(define (g-output-stream-close 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)))
- (if (not write-id) (error "Not open:" gstream))
- (if (g-output-stream-cancel-info-pending-op info)
- (error "Operation pending:" gstream))
+ (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 ((callback-id
(without-interrupts ;don't leak callback IDs
(lambda ()
- (let ((id (make-g-output-stream-close-finish-callback
- queue gerror*)))
+ (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)
id)))))
(set-g-output-stream-cancel-info-pending-op! info 'ERROR)
(error "Error in g-output-stream-close:" gstream value))
(begin
- (set-g-output-stream-cancel-info-pending-op! info #f)
+ (set-g-output-stream-cancel-info-pending-op! info 'CLOSED)
(without-interrupts
(lambda ()
(cleanup-g-output-stream info)))
value))))))
-(define (make-g-output-stream-close-finish-callback queue gerror*)
+(define (make-output-close-finish-callback queue gerror*)
(C-callback
- (named-lambda (g-output-stream-close-finish-callback source result)
+ (named-lambda (output-close-finish-callback source result)
(if (fix:zero?
(C-call "g_output_stream_close_finish" source result gerror*))
(let ((message (%gerror-message gerror*)))
- (%trace ";g-output-stream-close-finish-callback "message" "queue"\n")
+ (%trace ";output-close-finish-callback "message" "queue"\n")
(%queue! queue message))
(begin
- (%trace ";g-output-stream-close-finish-callback #t "queue"\n")
+ (%trace ";output-close-finish-callback #t "queue"\n")
(%queue! queue #t))))))
\f
(define-class <gfile-input-stream>
(without-interrupts ;don't leak callback IDs
(lambda ()
(let* ((alien (gobject-alien gstream))
- (id (make-gfile-read-finish-callback alien queue gerror*)))
+ (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)
id)))))
(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-g-input-stream-read-finish-callback queue gerror*))
+ info (make-read-finish-callback queue gerror*))
(set-g-input-stream-cancel-info-skip-id!
- info (make-g-input-stream-skip-finish-callback queue gerror*))))
+ info (make-skip-finish-callback queue gerror*))))
gstream)))))
-(define (make-gfile-read-finish-callback alien queue gerror*)
+(define (make-open-finish-callback alien queue gerror*)
(C-callback
- (named-lambda (gfile-read-finish-callback source result)
- (let ((bytes (C-call "g_file_read_finish" alien source result gerror*)))
- (if (fix:= bytes -1)
- (let ((message (%gerror-message gerror*)))
- (%trace ";g-file-read-finish-callback \""message"\" "queue"\n")
- (%queue! queue message))
- (begin
- (%trace ";g-file-read-finish-callback "bytes" "queue"\n")
- (%queue! queue bytes)))))))
+ (named-lambda (open-finish-callback source result)
+ (C-call "g_file_read_finish" alien source result gerror*)
+ (if (alien-null? alien)
+ (let ((message (%gerror-message gerror*)))
+ (%trace ";open-finish-callback \""message"\" "queue"\n")
+ (%queue! queue message))
+ (begin
+ (%trace ";open-finish-callback "alien" "queue"\n")
+ (%queue! queue #t))))))
(define-class <gfile-output-stream>
(<g-output-stream>))
(define (gfile-append-to gfile . flags)
(let ((flags* (->gfile-create-flags flags)))
- (gfile-open gfile 'append-to
- (lambda (gfile priority gcancellable callback id)
- (C-call "g_file_append_to_async"
- gfile flags*
- priority gcancellable callback id))
- make-gfile-append-to-finish-callback)))
+ (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)))
(define (->gfile-create-flags flags)
(reduce-left fix:or 0 (map ->gfile-create-flag flags)))
(else (error:wrong-type-argument flag "GFile create flag"
'->GFILE-CREATE-FLAG))))
-(define (make-gfile-append-to-finish-callback alien queue gerror*)
+(define (make-append-to-finish-callback alien queue gerror*)
(C-callback
- (named-lambda (gfile-append-to-finish-callback source result)
+ (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))))
(define (gfile-create gfile . flags)
(let ((flags* (->gfile-create-flags flags)))
- (gfile-open gfile 'create
- (lambda (gfile priority gcancellable callback id)
- (C-call "g_file_create_async"
- gfile flags*
- priority gcancellable callback id))
- make-gfile-create-finish-callback)))
-
-(define (make-gfile-create-finish-callback alien queue gerror*)
+ (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)))
+
+(define (make-create-finish-callback alien queue gerror*)
(C-callback
- (named-lambda (gfile-create-finish-callback source result)
+ (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))))
(let ((etag (->gfile-etag etag))
(make-backups (if backup? 1 0))
(flags* (->gfile-create-flags flags)))
- (gfile-open gfile 'replace
- (lambda (gfile priority gcancellable callback id)
- (C-call "g_file_replace_async"
- gfile etag make-backups flags*
- priority gcancellable callback id))
- make-gfile-replace-finish-callback)))
+ (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)))
(define-integrable (->gfile-etag etag)
(cond ((and (alien? etag) (eq? (alien/ctype etag) '|GFile etag|))
(else
(error:wrong-type-argument etag "GFile etag" '->GFILE-ETAG))))
-(define (make-gfile-replace-finish-callback alien queue gerror*)
+(define (make-replace-finish-callback alien queue gerror*)
(C-callback
- (named-lambda (gfile-replace-finish-callback source result)
+ (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 gfile op callout make-callback)
+(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))
(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-g-output-stream-write-finish-callback queue gerror*))
+ info (make-write-finish-callback queue gerror*))
(set-g-output-stream-cancel-info-flush-id!
- info
- (make-g-output-stream-flush-finish-callback queue gerror*))))
+ info (make-flush-finish-callback queue gerror*))))
gstream)))))
(define-integrable-operator (g-output-stream-finish alien queue gerror* op)
(if (alien-null? alien)
(let ((message (%gerror-message gerror*)))
- (%trace ";g-output-stream-"op"-callback "message" "queue"\n")
+ (%trace ";"op"-finish-callback "message" "queue"\n")
(%queue! queue message))
(begin
- (%trace ";g-output-stream-"op"-callback "alien" "queue"\n")
- (%queue! queue alien))))
+ (%trace ";"op"-finish-callback "alien" "queue"\n")
+ (%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
+
+(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*)))
+
+(define (make-ginfo-cleanup 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))))
+
+(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))
+ (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)
+ id)))))
+ (C-call "g_file_query_info_async"
+ (gobject-alien gfile)
+ pattern
+ (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))
+ (C-callback "async_ready")
+ callback-id)
+ (let ((value (thread-queue/dequeue! queue)))
+ (if (string? value)
+ (begin
+ (set-ginfo-cancel-info-pending-op! info 'ERROR)
+ (error "Error in gfile-query-info:" gfile value))
+ (begin
+ (set-ginfo-cancel-info-pending-op! info 'CLOSED)
+ (without-interrupts
+ (lambda ()
+ (de-register-c-callback callback-id)
+ (set-ginfo-cancel-info-callback-id! info #f)))
+ ginfo)))))
+
+(define (make-query-finish-callback alien queue gerror*)
+ (C-callback
+ (named-lambda (query-finish-callback source result)
+ (C-call "g_file_query_info_finish" alien source result gerror*)
+ (if (alien-null? alien)
+ (let ((message (%gerror-message gerror*)))
+ (%trace ";query-finish-callback "message" "queue"\n")
+ (%queue! queue message))
+ (begin
+ (%trace ";query-finish-callback "alien" "queue"\n")
+ (%queue! queue #t))))))
+
+(define (gfile-info-list-attributes ginfo namespace)
+ (guarantee-string namespace 'gfile-info-list-attributes)
+ (map string->symbol
+ (let ((alien (make-cstringv
+ (lambda (copy)
+ (C-call "g_file_info_list_attributes" copy
+ (gobject-alien ginfo) namespace)))))
+ (let ((strings (peek-cstringv alien)))
+ (free-cstringv alien)
+ strings))))
+
+(define (gfile-info-remove-attribute ginfo name)
+ (guarantee-string name 'gfile-info-remove-attribute)
+ (C-call "g_file_info_remove_attribute" (gobject-alien ginfo) name))
+
+(define (gfile-info-get-attribute-status ginfo name)
+ (let ((code (C-call "g_file_info_get_attribute_status"
+ (gobject-alien ginfo)
+ name)))
+ (cond ((fix:= code (C-enum "G_FILE_ATTRIBUTE_STATUS_UNSET")) 'unset)
+ ((fix:= code (C-enum "G_FILE_ATTRIBUTE_STATUS_SET")) 'set)
+ ((fix:= code (C-enum "G_FILE_ATTRIBUTE_STATUS_ERROR_SETTING"))
+ 'error-setting)
+ (else (error "Unknown GFileAttributeStatus:" code)))))
+
+(define (gfile-info-get-attribute-value ginfo name)
+ (let* ((alien (gobject-alien ginfo))
+ (type (C-call "g_file_info_get_attribute_type" alien name)))
+ (cond ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_INVALID"))
+ #f)
+ ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_STRING"))
+ (c-peek-cstring
+ (C-call "g_file_info_get_attribute_string"
+ (make-alien 'char) alien name)))
+ ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_BYTE_STRING"))
+ (c-peek-cstring
+ (C-call "g_file_info_get_attribute_byte_string"
+ (make-alien 'uchar) alien name)))
+ ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_BOOLEAN"))
+ (not (fix:zero?
+ (C-call "g_file_info_get_attribute_boolean" alien name))))
+ ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_UINT32"))
+ (C-call "g_file_info_get_attribute_uint32" alien name))
+ ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_INT32"))
+ (C-call "g_file_info_get_attribute_int32" alien name))
+ ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_UINT64"))
+ (C-call "g_file_info_get_attribute_uint64" alien name))
+ ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_INT64"))
+ (C-call "g_file_info_get_attribute_int64" alien name))
+ ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_OBJECT"))
+ (C-call "g_file_info_get_attribute_object"
+ (make-alien '|GObject|) alien name))
+ ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_STRINGV"))
+ (peek-cstringv
+ (C-call "g_file_info_get_attribute_stringv"
+ (make-alien '(* (const char))) alien name)))
+ (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
+
+(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*)))
+
+(define (make-gfile-enumerator-cleanup info)
+ (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)
+ ;; 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)))))))
+
+(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))
+ (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)
+ id)))))
+ (C-call "g_file_enumerate_children_async"
+ (gobject-alien gfile)
+ pattern
+ (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))
+ (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)
+ (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)
+ (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*))))
+ genum)))))
+
+(define (make-enumerator-finish-callback alien queue gerror*)
+ (C-callback
+ (named-lambda (enumerator-finish-callback source result)
+ (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")
+ (%queue! queue message))
+ (begin
+ (%trace ";enumerator-finish-callback "alien" "queue"\n")
+ (%queue! queue #t))))))
+
+(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)
+ (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))
+ (C-callback "async_ready")
+ callback-id)
+ (let* ((queue (gfile-enumerator-queue genum))
+ (value (thread-queue/dequeue! queue)))
+ (if (string? value)
+ (begin
+ (set-gfile-enumerator-cancel-info-pending-op! info 'ERROR)
+ (error "Error in gfile-enumerator-next-files:" genum value))
+ (begin
+ (set-gfile-enumerator-cancel-info-pending-op! info #f)
+ (make-ginfos info))))))
+
+(define (make-ginfos info)
+ (let* ((glist (gfile-enumerator-cancel-info-ginfos info))
+ (scan (copy-alien glist))
+ (ginfo (make-alien '|GFileInfo|))
+ (ginfos
+ (let loop ()
+ (if (alien-null? scan)
+ '()
+ (begin
+ (C-> scan "GList data" ginfo)
+ (if (not (alien-null? ginfo))
+ (let ((new (make-gfile-info)))
+ (without-interrupts
+ (lambda ()
+ (copy-alien-address! (gobject-alien new) ginfo)
+ (C->= scan "GList data" 0)))
+ (C-> scan "GList next" scan)
+ (cons new (loop)))
+ (begin
+ (C-> scan "GList next" scan)
+ (loop))))))))
+ (without-interrupts
+ (lambda ()
+ (if (not (alien-null? glist))
+ (begin
+ (C-call "g_list_free" glist)
+ (alien-null! glist)))))
+ ginfos))
+
+(define (make-next-files-finish-callback ginfos queue gerror*)
+ (C-callback
+ (named-lambda (next-files-finish-callback source result)
+ (C-call "g_file_enumerator_next_files_finish" ginfos source result gerror*)
+ (if (and (alien-null? ginfos)
+ (not (alien-null? (C-> gerror* "* GError"))))
+ (let ((message (%gerror-message gerror*)))
+ (%trace ";next-files-finish-callback "message" "queue"\n")
+ (%queue! queue message))
+ (begin
+ (%trace ";next-files-finish-callback #t "queue"\n")
+ (%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 ((callback-id
+ (without-interrupts ;don't leak callback IDs
+ (lambda ()
+ (let ((old (gfile-enumerator-cancel-info-callback-id 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)
+ id)))))
+ (C-call "g_file_enumerator_close_async"
+ (gobject-alien genum)
+ (gfile-enumerator-io-priority genum)
+ (gobject-alien (gfile-enumerator-cancel-info-gcancellable 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)
+ (error "Error in gfile-enumerator-close:" genum value))
+ (begin
+ (set-gfile-enumerator-cancel-info-pending-op! info 'CLOSED)
+ (without-interrupts
+ (lambda ()
+ (cleanup-gfile-enumerator info)))
+ value))))))
+
+(define (make-enumerator-close-finish-callback queue gerror*)
+ (C-callback
+ (named-lambda (enumerator-close-finish-callback source result)
+ (if (fix:zero?
+ (C-call "g_file_enumerator_close_finish" source result gerror*))
+ (let ((message (%gerror-message gerror*)))
+ (%trace ";enumerator-close-finish-callback "message" "queue"\n")
+ (%queue! queue message))
+ (begin
+ (%trace ";enumerator-close-finish-callback #t "queue"\n")
+ (%queue! queue #t))))))
\f
(define-class (<gfile> (constructor (uri)))
(<gobject>)
(define-structure gfile-etag
alien)
+(define (make-cstringv setter)
+ ;; SETTER is applied to an alien that must not escape.
+ (let ((alien (make-alien '(* uchar)))
+ (copy (make-alien '(* uchar))))
+ (add-gc-cleanup alien (make-cstringv-cleanup copy))
+ (setter copy)
+ (copy-alien-address! alien copy)
+ alien))
+
+(define (make-cstringv-cleanup alien)
+ (named-lambda (cstringv-cleanup)
+ (if (not (alien-null? alien))
+ (let ((scan (copy-alien alien))
+ (cstr (make-alien 'uchar)))
+ (let loop ()
+ (C-> scan "* uchar" cstr)
+ (if (not (alien-null? cstr))
+ (begin
+ (C-call "g_free" cstr)
+ (alien-byte-increment! scan (C-sizeof "* uchar"))
+ (loop))))
+ (C-call "g_free" alien)
+ (alien-null! alien)))))
+
+(define (peek-cstringv alien)
+ (let ((scan (copy-alien alien))
+ (cstr (make-alien 'uchar)))
+ (let loop ()
+ (C-> scan "* uchar" cstr)
+ (if (alien-null? cstr)
+ '()
+ (let ((str (c-peek-cstring cstr)))
+ (alien-byte-increment! scan (C-sizeof "* uchar"))
+ (cons str (loop)))))))
+
+(define (free-cstringv alien)
+ (without-interrupts
+ (lambda ()
+ (let ((cleanup (punt-gc-cleanup alien)))
+ (if cleanup (cleanup))
+ (alien-null! alien)))))
+
(define %trace? #f)
(define-syntax %trace
projects / mit-scheme.git / commitdiff