--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2011 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; GIO Ports
+;;; package: (glib gio)
+
+(define (open-input-gfile uri)
+ (let* ((gfile (->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)
+ ;;(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)
+ ;;(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.
+ (let ((port #f)
+ (open? #t))
+ (make-gsource
+ (named-lambda (gstream-source/get-channel)
+ #f)
+ (named-lambda (gstream-source/get-port)
+ port)
+ (named-lambda (gstream-source/set-port port*)
+ (set! port port*))
+ (named-lambda (gstream-source/open?)
+ open?)
+ (named-lambda (gstream-source/close)
+ (if open?
+ (let ((value (gstream-input-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)))))
+
+(define (gstream-input-close gstream)
+ (let ((io-priority 10)
+ (q (make-thread-queue 1)))
+ (C-call "g_input_stream_close_async"
+ (gobject-alien gstream)
+ io-priority 0
+ (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)
+ (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)))
+ (<gobject>)
+ (uri define accessor))
+
+(define-method initialize-instance ((gfile <gfile>) uri)
+ (call-next-method gfile)
+ (guarantee-utf8-string uri)
+ (let ((alien (gobject-alien gfile)))
+ (set-alien/ctype! alien '|GFile|)
+ (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>))
+
+(define-method initialize-instance ((gcancel <gcancellable>))
+ (call-next-method gcancel)
+ (let ((alien (gobject-alien gcancel)))
+ (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 (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)
+ ;; 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
projects / mit-scheme.git / commitdiff