|#
;;;; GIO Ports
-;;; package: (glib gio)
+;;; package: (gtk gio)
(define (open-input-gfile uri)
- (let* ((gfile (->gfile uri))
+ (let* ((gfile (make-gfile uri))
(gstream (gfile-read gfile))
(port (fluid-let ((allocate-buffer-bytes allocate-external-string))
- (make-generic-i/o-port (make-gstream-source gstream) #f))))
- (gobject-unref! gfile)
+ (make-generic-i/o-port (make-g-stream-source gstream) #f))))
;;(port/set-coding port 'ISO-8859-1)
;;(port/set-line-ending port 'NEWLINE)
port))
-#;(define (open-i/o-gfile uri)
- (let* ((gfile (->gfile uri))
- (gstream (gfile-open-readwrite gfile))
- (port (make-generic-i/o-port (make-gstream-source gstream)
- (make-gstream-sink gstream))))
- (gobject-unref! gfile)
+(define (make-g-stream-source gstream)
+ ;; Not unlike make-non-channel-port-source in genio.scm.
+ (let ((port #f)
+ (open? #t))
+ (make-gsource
+ (named-lambda (g-stream-source/get-channel)
+ #f)
+ (named-lambda (g-stream-source/get-port)
+ port)
+ (named-lambda (g-stream-source/set-port port*)
+ (set! port port*))
+ (named-lambda (g-stream-source/open?)
+ open?)
+ (named-lambda (g-stream-source/close)
+ (if open?
+ (let ((value (g-input-stream-close gstream)))
+ (set! open? #f)
+ value)))
+ (named-lambda (g-stream-source/has-bytes?)
+ #t)
+ (named-lambda (g-stream-source/read-bytes buffer start end)
+ (g-input-stream-read gstream buffer start end)))))
+
+(define (open-output-gfile uri)
+ (let* ((gfile (make-gfile uri))
+ (gstream (gfile-replace gfile #f #t 'private))
+ (port (fluid-let ((allocate-buffer-bytes allocate-external-string))
+ (make-generic-i/o-port #f (make-g-stream-sink gstream)))))
;;(port/set-coding port 'ISO-8859-1)
;;(port/set-line-ending port 'NEWLINE)
port))
-(define (make-gstream-source gstream)
- ;; Not unlike make-non-channel-port-source in genio.scm.
+(define (make-g-stream-sink gstream)
+ ;; Not unlike make-non-channel-port-sink in genio.scm.
(let ((port #f)
(open? #t))
- (make-gsource
- (named-lambda (gstream-source/get-channel)
+ (make-gsink
+ (named-lambda (g-stream-sink/get-channel)
#f)
- (named-lambda (gstream-source/get-port)
+ (named-lambda (g-stream-sink/get-port)
port)
- (named-lambda (gstream-source/set-port port*)
+ (named-lambda (g-stream-sink/set-port port*)
(set! port port*))
- (named-lambda (gstream-source/open?)
+ (named-lambda (g-stream-sink/open?)
open?)
- (named-lambda (gstream-source/close)
+ (named-lambda (g-stream-sink/close)
(if open?
- (let ((value (gstream-input-close gstream)))
+ (let ((value (g-output-stream-close gstream)))
(set! open? #f)
value)))
- (named-lambda (gstream-source/has-bytes?)
- #t)
- (named-lambda (gstream-source/read-bytes buffer start end)
- (gstream-read gstream buffer start end)))))
+ (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.
+ (<gobject>)
+
+ (io-priority
+ define standard initial-value 10)
+
+ (queue
+ define accessor initializer (lambda () (make-thread-queue 1))))
+
+;;; 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 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 (lambda ()
+ (make-g-input-stream-cancel-info
+ #f #f (make-gcancellable) #f #f))))
+
+(define-structure g-input-stream-cancel-info
+ pending-op ; #f, OPEN, READ, SKIP, CLOSE or ERROR.
+ callback-id ; #f or the open/close finish callback ID
+ gcancellable ; a GCancellable alien
+
+ ;; To avoid registering read or skip finish callbacks for every read
+ ;; or skip (a LOT of registering/deregistering!), 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
+ (g-input-stream-cancel-info object))))
+
+(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))))
+
+(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))
+ (slot (cadddr form)))
+ (let ((accessor (symbol ' G- i/o '-STREAM-CANCEL-INFO- slot))
+ (modifier (symbol 'SET-G- i/o '-STREAM-CANCEL-INFO- slot '!)))
+ `(LET ((ID (,accessor ,info)))
+ (IF ID
+ (BEGIN
+ (DE-REGISTER-C-CALLBACK ID)
+ (,modifier ,info #F))))))))))
+
+(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)
+ (gobject-unref! (g-input-stream-cancel-info-gcancellable info)))
+
+(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* ((count (fix:- end start))
+ (async-buffer (alien-byte-increment! (external-string->alien buffer)
+ start)))
+ (set-g-input-stream-cancel-info-pending-op! 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))
+ (C-callback "async_ready")
+ callback-id)
+ (let* ((queue (g-stream-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))
+ (begin
+ (set-g-input-stream-cancel-info-pending-op! info #f)
+ value))))))
+
+(define (make-g-input-stream-read-finish-callback queue)
+ (C-callback
+ (named-lambda (g-input-stream-read-finish-callback source result)
+ (if-gerror
+ (lambda (gerror)
+ (C-call "g_input_stream_read_finish" source result gerror))
+ (lambda (message)
+ (%trace ";g-input-stream-read-finish-callback "message" "queue"\n")
+ (%queue! queue message))
+ (lambda (value)
+ (%trace ";g-input-stream-read-finish-callback "value" "queue"\n")
+ (%queue! queue value))))))
+
+(define-integrable (%queue! queue value)
+ ;; The GIO finish callbacks use this procedure to queue a value on a
+ ;; g-stream's queue AND signal the main loop if Scheme has become
+ ;; runnable.
+ (thread-queue/queue! queue value)
+ (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)))
+ (if (not callback-id) (error "Not open:" gstream))
+ (if (g-input-stream-cancel-info-pending-op info)
+ (error "Operation pending:" gstream))
+ (set-g-input-stream-cancel-info-pending-op! 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))
+ (value (thread-queue/dequeue! queue)))
+ (if (string? value)
+ (begin
+ (set-g-input-stream-cancel-info-pending-op! info 'ERROR)
+ (error "Error reading:" gstream value))
+ (begin
+ (set-g-input-stream-cancel-info-pending-op! info #f)
+ value)))))
+
+(define (make-g-input-stream-skip-finish-callback queue)
+ (C-callback
+ (named-lambda (g-input-stream-skip-finish-callback source result)
+ (if-gerror
+ (lambda (gerror)
+ (C-call "g_input_stream_skip_finish" source result gerror))
+ (lambda (message)
+ (%trace ";g-input-stream-skip-finish-callback "message" "queue"\n")
+ (%queue! queue message))
+ (lambda (value)
+ (%trace ";g-input-stream-skip-finish-callback "value" "queue"\n")
+ (%queue! queue value))))))
+
+(define (g-input-stream-close gstream)
+ (let* ((info (g-input-stream-cancel-info gstream))
+ (queue (g-stream-queue gstream))
+ (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 ((callback-id
+ (without-interrupts ;don't leak callback IDs
+ (lambda ()
+ (let ((id (make-g-input-stream-close-finish-callback queue)))
+ (set-g-input-stream-cancel-info-pending-op! info 'CLOSE)
+ (set-g-input-stream-cancel-info-callback-id! 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))
+ (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)
+ (error "Error in g-input-stream-close:" gstream value))
+ (begin
+ (set-g-input-stream-cancel-info-pending-op! info #f)
+ (without-interrupts
+ (lambda ()
+ (cleanup-g-input-stream info)))
+ value))))))
+
+(define (make-g-input-stream-close-finish-callback queue)
+ (C-callback
+ (named-lambda (g-input-stream-close-finish-callback source result)
+ (if-gerror
+ (lambda (gerror)
+ (C-call "g_input_stream_close_finish" source result gerror))
+ (lambda (message)
+ (%trace ";g-input-stream-close-finish-callback "message" "queue"\n")
+ (%queue! queue message))
+ (lambda (value)
+ (%trace ";g-input-stream-close-finish-callback "value" "queue"\n")
+ (%queue! queue #t))))))
+\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) #f #f))))
+
+(define-structure g-output-stream-cancel-info
+ pending-op ; #f, OPEN, WRITE, FLUSH, CLOSE or ERROR.
+ callback-id ; #f or the open/close finish callback ID
+ gcancellable ; a GCancellable 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.
+ write-id ; #f or the write finish callback ID
+ flush-id ; #f or the flush finish callback ID
+ )
+
+(define-method initialize-instance ((object <g-output-stream>))
+ (call-next-method object)
+ (add-gc-cleanup object
+ (make-g-output-stream-cleanup
+ (g-output-stream-cancel-info object))))
+
+(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))))
+
+(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)
+ (gobject-unref! (g-output-stream-cancel-info-gcancellable 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* ((count (fix:- end start))
+ (async-buffer (alien-byte-increment! (external-string->alien buffer)
+ start)))
+ (set-g-output-stream-cancel-info-pending-op! info 'WRITE)
+ (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))
+ (C-callback "async_ready")
+ callback-id)
+ (let* ((queue (g-stream-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))
+ (begin
+ (set-g-input-stream-cancel-info-pending-op! info #f)
+ value))))))
+
+(define (make-g-output-stream-write-finish-callback queue)
+ (C-callback
+ (named-lambda (g-output-stream-write-finish-callback source result)
+ (if-gerror
+ (lambda (gerror)
+ (C-call "g_output_stream_write_finish" source result gerror))
+ (lambda (message)
+ (%trace ";g-output-stream-write-finish-callback "message" "queue"\n")
+ (%queue! queue message))
+ (lambda (value)
+ (%trace ";g-output-stream-write-finish-callback "value" "queue"\n")
+ (%queue! queue value))))))
-(define (gstream-input-close gstream)
- (let ((io-priority 10)
- (q (make-thread-queue 1)))
- (C-call "g_input_stream_close_async"
+(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)
+ (C-call "g_output_stream_flush_async"
(gobject-alien gstream)
- io-priority 0
+ (g-stream-io-priority gstream)
+ (gobject-alien (g-output-stream-cancel-info-gcancellable info))
(C-callback "async_ready")
- (C-callback
- (named-lambda (gstream-input-close-finish source result)
- (if (not (alien=? source (gobject-alien gstream))) (warn "Unexpected source in async_ready:" source gstream))
- (if-gerror
- (lambda (gerr)
- (C-call "g_input_stream_close_finish" source result gerr))
- (lambda (message)
- (thread-queue/queue! q message))
- (lambda (value)
- (thread-queue/queue! q value))))))
- (let ((value (thread-queue/dequeue! q)))
- (gobject-unref! gstream)
- (if (string? value) (error value))
- (not (zero? value)))))
-
-(define (gstream-read gstream external-string start end)
- (let ((io-priority 10)
- ;;(gcancel (make-gcancellable))
- (buffer (alien-byte-increment! (external-string->alien external-string)
- start))
- (count (- end start))
- (q (make-thread-queue 1)))
- (C-call "g_input_stream_read_async"
- (gobject-alien gstream) buffer count
- io-priority 0 ;;(gobject-alien gcancel)
+ callback-id)
+ (let* ((queue (g-stream-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))
+ (begin
+ (set-g-input-stream-cancel-info-pending-op! info #f)
+ (not (fix:zero? value)))))))
+
+(define (make-g-output-stream-flush-finish-callback queue)
+ (C-callback
+ (named-lambda (g-output-stream-flush-finish-callback source result)
+ (if-gerror
+ (lambda (gerror)
+ (C-call "g_output_stream_flush_finish" source result gerror))
+ (lambda (message)
+ (%trace ";g-output-stream-flush-finish-callback "message" "queue"\n")
+ (%queue! queue message))
+ (lambda (value)
+ (%trace ";g-output-stream-flush-finish-callback "value" "queue"\n")
+ (%queue! queue value))))))
+
+(define (g-output-stream-close gstream)
+ (let* ((info (g-output-stream-cancel-info gstream))
+ (queue (g-stream-queue gstream))
+ (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 ((callback-id
+ (without-interrupts ;don't leak callback IDs
+ (lambda ()
+ (let ((id (make-g-output-stream-close-finish-callback queue)))
+ (set-g-output-stream-cancel-info-pending-op! info 'CLOSE)
+ (set-g-output-stream-cancel-info-callback-id! 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))
+ (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 "Error in g-output-stream-close:" gstream value))
+ (begin
+ (set-g-output-stream-cancel-info-pending-op! info #f)
+ (without-interrupts
+ (lambda ()
+ (cleanup-g-output-stream info)))
+ value))))))
+
+(define (make-g-output-stream-close-finish-callback queue)
+ (C-callback
+ (named-lambda (g-output-stream-close-finish-callback source result)
+ (if-gerror
+ (lambda (gerror)
+ (C-call "g_output_stream_close_finish" source result gerror))
+ (lambda (message)
+ (%trace ";g-output-stream-close-finish-callback "message" "queue"\n")
+ (%queue! queue message))
+ (lambda (value)
+ (%trace ";g-output-stream-close-finish-callback "value" "queue"\n")
+ (%queue! queue #t))))))
+\f
+(define-class <gfile-input-stream>
+ (<g-input-stream>))
+
+(define-method initialize-instance ((gstream <gfile-input-stream>))
+ (call-next-method gstream)
+ (let ((alien (gobject-alien gstream)))
+ (set-alien/ctype! alien '|GFileInputStream|)))
+
+(define (gfile-read gfile)
+ (let* ((gstream (make-g-input-stream))
+ (info (g-input-stream-cancel-info gstream))
+ (queue (g-stream-queue gstream))
+ (callback-id
+ (without-interrupts ;don't leak callback IDs
+ (lambda ()
+ (let* ((alien (gobject-alien gstream))
+ (id (make-gfile-read-finish-callback alien queue)))
+ (set-g-input-stream-cancel-info-pending-op! info 'OPEN)
+ (set-g-input-stream-cancel-info-callback-id! 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))
(C-callback "async_ready")
- (C-callback
- (named-lambda (gstream-read-finish source result)
- (if (not (alien=? source (gobject-alien gstream))) (warn "Unexpected source in async_ready:" source gstream))
- (if-gerror
- (lambda (gerr)
- (C-call "g_input_stream_read_finish" source result gerr))
- (lambda (message)
- (thread-queue/queue! q message))
- (lambda (value)
- (thread-queue/queue! q value))))))
- (let ((value (thread-queue/dequeue! q)))
- ;; (gobject-unref! gcancel)
- (if (string? value) (error value))
- value)))
-
-(define (external-string->alien string)
- (if (not (external-string? string))
- (error:wrong-type-argument string "an external string" 'EXTERNAL-STRING->ALIEN))
- (let ((a (make-alien '|char|)))
- (%set-alien/address! a (external-string-descriptor string))
- a))
-
-(define-class (<gfile> (constructor () (uri)))
+ callback-id)
+ (let ((value (thread-queue/dequeue! queue)))
+ (if (string? value)
+ (begin
+ (set-g-input-stream-cancel-info-pending-op! info 'ERROR)
+ (error "Error in gfile-read:" gfile value))
+ (begin
+ (set-g-input-stream-cancel-info-pending-op! 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-g-input-stream-read-finish-callback queue))
+ (set-g-input-stream-cancel-info-skip-id!
+ info (make-g-input-stream-skip-finish-callback queue))))
+ gstream)))))
+
+(define (make-gfile-read-finish-callback alien queue)
+ (C-callback
+ (named-lambda (gfile-read-finish-callback source result)
+ (if-gerror
+ (lambda (gerror)
+ (C-call "g_file_read_finish" alien source result gerror))
+ (lambda (message) ;failure
+ (%trace ";g-file-read-finish-callback "message" "queue"\n")
+ (%queue! queue message))
+ (lambda (value) ;success
+ (%trace ";g-file-read-finish-callback "value" "queue"\n")
+ (%queue! queue value))))))
+
+(define-class <gfile-output-stream>
+ (<g-output-stream>))
+
+(define-method initialize-instance ((gstream <gfile-output-stream>))
+ (call-next-method gstream)
+ (let ((alien (gobject-alien gstream)))
+ (set-alien/ctype! alien '|GFileOutputStream|)))
+
+(define (gfile-append-to gfile . flags)
+ (let ((flags* (->gfile-create-flags flags)))
+ (gfile-open gfile
+ (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)))
+
+(define (->gfile-create-flags flags)
+ (reduce-left fix:or 0 (map ->gfile-create-flag flags)))
+
+(define (->gfile-create-flag flag)
+ (case flag
+ ((PRIVATE) (C-enum "G_FILE_CREATE_PRIVATE"))
+ ((REPLACE) (C-enum "G_FILE_CREATE_REPLACE_DESTINATION"))
+ (else (error:wrong-type-argument flag "GFile create flag"
+ '->GFILE-CREATE-FLAG))))
+
+(define (make-gfile-append-to-finish-callback alien queue)
+ (C-callback
+ (named-lambda (gfile-append-to-finish-callback source result)
+ (g-output-stream-callback queue 'append-to
+ (lambda (gerror)
+ (C-call "g_file_append_to_finish"
+ alien source result gerror))))))
+
+(define (gfile-create gfile . flags)
+ (let ((flags* (->gfile-create-flags flags)))
+ (gfile-open gfile
+ (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)
+ (C-callback
+ (named-lambda (gfile-create-finish-callback source result)
+ (g-output-stream-callback queue 'create
+ (lambda (gerror)
+ (C-call "g_file_create_finish"
+ alien source result gerror))))))
+
+(define (gfile-replace gfile etag backup? . flags)
+ (let ((etag (->gfile-etag etag))
+ (make-backups (if backup? 1 0))
+ (flags* (->gfile-create-flags flags)))
+ (gfile-open gfile
+ (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)))
+
+(define-integrable (->gfile-etag etag)
+ (cond ((and (alien? etag) (eq? (alien/ctype etag) '|GFile etag|))
+ etag)
+ ((or (eq? etag #f) (zero? etag))
+ 0)
+ (else
+ (error:wrong-type-argument etag "GFile etag" '->GFILE-ETAG))))
+
+(define (make-gfile-replace-finish-callback alien queue)
+ (C-callback
+ (named-lambda (gfile-replace-finish-callback source result)
+ (g-output-stream-callback queue 'replace
+ (lambda (gerror)
+ (C-call "g_file_replace_finish"
+ alien source result gerror))))))
+
+(define-integrable (gfile-open gfile callout make-callback)
+ (let* ((gstream (make-g-output-stream))
+ (info (g-output-stream-cancel-info gstream))
+ (queue (g-stream-queue gstream))
+ (callback-id
+ (without-interrupts ;don't leak callback IDs
+ (lambda ()
+ (let* ((alien (gobject-alien gstream))
+ (id (make-callback alien queue)))
+ (set-g-output-stream-cancel-info-pending-op! info 'OPEN)
+ (set-g-output-stream-cancel-info-callback-id! info id)
+ id)))))
+ (callout (gobject-alien gfile)
+ (g-stream-io-priority gstream)
+ (gobject-alien (g-output-stream-cancel-info-gcancellable 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))
+ (begin
+ (set-g-output-stream-cancel-info-pending-op! 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-g-output-stream-write-finish-callback queue))
+ (set-g-output-stream-cancel-info-flush-id!
+ info (make-g-output-stream-flush-finish-callback queue))))
+ gstream)))))
+
+(define-integrable (g-output-stream-callback queue op callback)
+ (if-gerror
+ callback
+ (lambda (message) ;failure
+ (%trace ";g-output-stream-"op"-callback "message" "queue"\n")
+ (%queue! queue message))
+ (lambda (value) ;success
+ (%trace ";g-output-stream-"op"-callback "value" "queue"\n")
+ (%queue! queue value))))
+
+(define-integrable (external-string->alien xstr)
+ (let ((alien (make-alien 'uchar)))
+ (%set-alien/address! alien (external-string-descriptor xstr))
+ alien))
+\f
+(define-class (<gfile> (constructor (uri)))
(<gobject>)
(uri define accessor))
-(define-method initialize-instance ((gfile <gfile>) uri)
+(define-method initialize-instance ((gfile <gfile>))
(call-next-method gfile)
- (guarantee-utf8-string uri)
- (let ((alien (gobject-alien gfile)))
+ (let ((alien (gobject-alien gfile))
+ (uri (gfile-uri gfile)))
(set-alien/ctype! alien '|GFile|)
+ (guarantee-utf8-string uri)
(C-call "g_file_new_for_uri" alien uri)
(error-if-null alien "Could not create:" gfile uri)))
-(define (->gfile object)
- (cond ((string? object) (make-gfile object))
- ((pathname? object) (make-gfile (->namestring object)))
- ((gfile? object) object)
- (else (error "Not a GFile, pathname nor string:" object))))
-
(define-class (<gcancellable> (constructor ()))
(<gobject>))
(set-alien/ctype! alien '|GCancellable|)
(C-call "g_cancellable_new" alien)))
-(define (gcancellable-cancel gcancel)
- (C-call "g_cancellable_cancel" (gobject-alien gcancel))
- (gobject-unref! gcancel))
-
-(define (with-gcancellability callout)
- (let ((gcancel (make-gcancellable))
- (in? #f)
- (result #f))
- (dynamic-wind
- (lambda ()
- (if in? (error "Already in!"))
- (set! in? #t))
- (lambda ()
- (set! result (callout gcancel)))
- (lambda ()
- (if (not result)
- (gcancellable-cancel gcancel))
- (gobject-unref! gcancel)))
- result))
-
-(define-class (<gfile-input-stream> (constructor ()))
- (<gobject>))
-
-(define-method initialize-instance ((stream <gfile-input-stream>))
- (call-next-method stream)
- (let ((alien (gobject-alien stream)))
- (set-alien/ctype! alien '|GFileInputStream|)))
-
-(define (gfile-read gfile)
- ;; Returns a <gfile-input-stream>.
- (let ((gstream (make-gfile-input-stream))
- (io-priority 10)
- ;;(gcancel (make-gcancellable))
- (q (make-thread-queue 1)))
- (C-call "g_file_read_async"
- (gobject-alien gfile) io-priority 0 ;;gcancel
- (C-callback "async_ready")
- (C-callback
- (named-lambda (gfile-read-finish source result)
- (if (not (alien=? source (gobject-alien gfile))) (warn "Unexpected source in async_ready:" source gfile))
- (if-gerror
- (lambda (gerr)
- (C-call "g_file_read_finish"
- (gobject-alien gstream)
- source result gerr))
- (lambda (message) ;failure
- (thread-queue/queue! q message))
- (lambda (value) ;success
- (declare (ignore value));;this is void/unspecific
- (thread-queue/queue! q #t))))))
- (let ((message (thread-queue/dequeue! q)))
- (if (string? message) (error message))
- ;;(gobject-unref! gcancel)
- gstream)))
-
-(define-class (<gfile-io-stream> (constructor ()))
- (<gobject>))
-
-(define-method initialize-instance ((stream <gfile-io-stream>))
- (call-next-method stream)
- (let ((alien (gobject-alien stream)))
- (set-alien/ctype! alien '|GFileInputStream|)))
+(define-structure gfile-etag
+ alien)
-(define (gfile-open-readwrite gfile)
- ;; Returns a <gfile-io-stream>.
- (let ((gstream (make-gfile-io-stream))
- (io-priority 10)
- ;;(gcancel (make-gcancellable))
- (q (make-thread-queue 1)))
- (C-call "g_file_open_readwrite_async"
- (gobject-alien gfile) io-priority 0 ;;gcancel
- (C-callback "async_ready")
- (C-callback
- (named-lambda (gfile-open-readwrite-finish source result)
- (if (not (alien=? source (gobject-alien gfile))) (warn "Unexpected source in async_ready:" source gfile))
- (if-gerror
- (lambda (gerr)
- (C-call "g_file_open_readwrite_finish"
- (gobject-alien gstream)
- source result gerr))
- (lambda (message) ;failure
- (thread-queue/queue! q message))
- (lambda (value) ;success
- (declare (ignore value));;this is void/unspecific
- (thread-queue/queue! q #t))))))
- (let ((message (thread-queue/dequeue! q)))
- (if (string? message) (error message))
- ;;(gobject-unref! gcancel)
- gstream)))
-
-(define (if-gerror callout failure success)
+(define-integrable (if-gerror callout failure success)
;; Applies CALLOUT to a *GError. If the pointer is set, tail-
;; applies FAILURE to the GError message, else SUCCESS to CALLOUT's
;; value.
- (let ((gerror-ptr (malloc (C-sizeof "* GError") '(* |GError|))))
- (C->= gerror-ptr "* GError" 0)
- (let* ((value (callout gerror-ptr))
- (gerror (C-> gerror-ptr "* GError")))
- (if (alien-null? gerror)
- (begin
- (free gerror-ptr)
- (success value))
- (let ((message (c-peek-cstring (C-> gerror "GError message"))))
- (C-call "g_error_free" gerror)
- (free gerror-ptr)
- (failure message))))))
\ No newline at end of file
+ (let ((gerror (make-alien '|GError|))
+ (gerror* (make-alien '(* |GError|))))
+ (let ((cleanup (make-gerror-cleanup gerror*)))
+ (add-gc-cleanup gerror cleanup)
+ ((ucode-primitive c-malloc 2) gerror* (c-sizeof "* GError"))
+ (C->= gerror* "* GError" 0)
+ (let ((value (callout gerror*)))
+ (C-> gerror* "* GError" gerror)
+ (if (alien-null? gerror)
+ (begin
+ ((ucode-primitive c-free 1) gerror*)
+ (alien-null! gerror*)
+ (punt-gc-cleanup gerror)
+ (success value))
+ (let ((message (c-peek-cstring (C-> gerror "GError message"))))
+ (cleanup)
+ (punt-gc-cleanup gerror)
+ (alien-null! gerror)
+ (failure message)))))))
+
+(define (make-gerror-cleanup gerror*)
+ (named-lambda (gerror-cleanup)
+ (if (not (alien-null? gerror*))
+ (let ((gerror (C-> gerror* "* GError")))
+ (if (not (alien-null? gerror))
+ (C-call "g_error_free" gerror))
+ ((ucode-primitive c-free 1) gerror*)
+ (alien-null! gerror*)))))
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS)))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff