From 0a1585516f0d7d645fbd3b91b32c2adb187b0f9e Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 22 Jun 2011 09:35:28 -0700 Subject: [PATCH] Implemented open-input-gfile using the GIO library. --- src/gtk/compile.scm | 1 + src/gtk/gio.scm | 257 ++++++++++++++++++++++++++++++++++++++++++++ src/gtk/gtk.pkg | 12 +++ 3 files changed, 270 insertions(+) create mode 100644 src/gtk/gio.scm diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm index 8b095feed..186646aa0 100644 --- a/src/gtk/compile.scm +++ b/src/gtk/compile.scm @@ -17,6 +17,7 @@ ;; ------------ ----------------------- --------------- 'dependencies '(("gobject" "gtk-const.bin") + ("gio" "gtk-const.bin") ("pango" "gtk-const.bin") ("gtk-object" "gtk-const.bin") ("scm-widget" "gtk-const.bin") diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm new file mode 100644 index 000000000..ffd48ab36 --- /dev/null +++ b/src/gtk/gio.scm @@ -0,0 +1,257 @@ +#| -*-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 ( (constructor () (uri))) + () + (uri define accessor)) + +(define-method initialize-instance ((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 ( (constructor ())) + ()) + +(define-method initialize-instance ((gcancel )) + (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 ( (constructor ())) + ()) + +(define-method initialize-instance ((stream )) + (call-next-method stream) + (let ((alien (gobject-alien stream))) + (set-alien/ctype! alien '|GFileInputStream|))) + +(define (gfile-read gfile) + ;; Returns a . + (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 ( (constructor ())) + ()) + +(define-method initialize-instance ((stream )) + (call-next-method stream) + (let ((alien (gobject-alien stream))) + (set-alien/ctype! alien '|GFileInputStream|))) + +(define (gfile-open-readwrite gfile) + ;; Returns a . + (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 diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index b5416a63e..8983e1742 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -52,6 +52,18 @@ USA. gdk-window-process-updates)) +(define-package (gtk gio) + (parent (gtk)) + (files "gio") + ;;(depends-on "gtk-const.bin") + (import (runtime ffi) + %set-alien/address!) + (import (runtime generic-i/o-port) + make-gsource + allocate-buffer-bytes) + (export (gtk) + open-input-gfile)) + (define-package (gtk pango) (parent (gtk)) (files "pango") -- 2.25.1