From: Matt Birkholz Date: Thu, 11 Aug 2011 04:52:59 +0000 (-0700) Subject: Added global export gdirectory-read. X-Git-Tag: mit-scheme-pucked-9.2.12~646 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=45b6cfb8a7c01a304aa089a75c53494bf22cbf05;p=mit-scheme.git Added global export gdirectory-read. Moved directory reading code from tests/gtk/test-gport-operations.scm to src/gtk/gio.scm. Defined a procedure to convert strings and pathnames into absolute URIs and used it in the 3 global exports. --- diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm index d8973fab7..6a95d7e52 100644 --- a/src/gtk/gio.scm +++ b/src/gtk/gio.scm @@ -25,13 +25,34 @@ USA. ;;; package: (gtk gio) (define (open-input-gfile uri) - (let* ((gfile (make-gfile uri)) + (let* ((uri* (->uri* uri 'open-input-gfile)) + (gfile (make-gfile (uri->string uri*))) (gstream (gfile-read gfile)) (port (make-generic-i/o-port (make-g-stream-source gstream) #f))) ;;(port/set-coding port 'ISO-8859-1) ;;(port/set-line-ending port 'NEWLINE) + (gobject-unref! gfile) port)) +(define (->uri* object caller) + (let ((uri* (->uri object caller))) + (if (uri-absolute? uri*) + uri* + (merge-uris (->simple-namestring object) + "file:///")))) + +(define-integrable (->simple-namestring pathname) + (->namestring (->simple-pathname pathname))) + +(define (->simple-pathname pathname) + (let loop ((simpler (pathname-simplify + (merge-pathnames pathname (working-directory-pathname)))) + (count 1)) + (let ((again (pathname-simplify simpler))) + (cond ((fix:> count 100) (error "Could not simplify:" pathname)) + ((pathname=? again simpler) again) + (else (loop again (fix:1+ count))))))) + (define (make-g-stream-source gstream) ;; Not unlike make-non-channel-port-source in genio.scm. (let ((port #f) @@ -56,11 +77,13 @@ USA. (g-input-stream-read gstream buffer start end))))) (define (open-output-gfile uri) - (let* ((gfile (make-gfile uri)) + (let* ((uri* (->uri* uri 'open-output-gfile)) + (gfile (make-gfile (uri->string uri*))) (gstream (gfile-replace gfile #f #t 'private)) (port (make-generic-i/o-port #f (make-g-stream-sink gstream)))) ;;(port/set-coding port 'ISO-8859-1) ;;(port/set-line-ending port 'NEWLINE) + (gobject-unref! gfile) port)) (define (make-g-stream-sink gstream) @@ -83,6 +106,30 @@ USA. value))) (named-lambda (g-stream-sink/write-bytes buffer start end) (g-output-stream-write gstream buffer start end))))) + +(define (gdirectory-read uri) + (let* ((uri* (->uri* uri 'gdirectory-read)) + (gfile (make-gfile (uri->string uri*))) + (names + (map (lambda (ginfo) + (let ((name (gfile-info-get-attribute-value + ginfo "standard::name"))) + (gobject-unref! ginfo) + name)) + (gfile-children gfile "standard::name")))) + (gobject-unref! gfile) + names)) + +(define (gfile-children gfile attributes) + (let ((genum (gfile-enumerate-children gfile attributes #f))) + (let loop ((ginfos '())) + (let ((next (gfile-enumerator-next-files genum 100))) + (if (null? next) + (begin + (gfile-enumerator-close genum) + (gobject-unref! genum) + ginfos) + (loop (append! ginfos next))))))) (define-class () @@ -695,8 +742,8 @@ USA. (named-lambda (ginfo-cleanup) (cleanup-gio gio-info))) -(define (gfile-query-info gfile pattern follow-symlinks?) - (guarantee-string pattern 'gfile-query-info) +(define (gfile-query-info gfile attributes follow-symlinks?) + (guarantee-string attributes 'gfile-query-info) (let* ((ginfo (make-gfile-info)) (gio-info (gio-cleanup-info ginfo)) (queue (gio-queue ginfo)) @@ -712,7 +759,7 @@ USA. (let retry () (C-call "g_file_query_info_async" (gobject-alien gfile) - pattern + attributes (if follow-symlinks? (C-enum "G_FILE_QUERY_INFO_NONE") (C-enum "G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS")) @@ -843,8 +890,8 @@ USA. (alien-null! glist)) (loop)))))) -(define (gfile-enumerate-children gfile pattern follow-symlinks?) - (guarantee-string pattern 'gfile-enumerate-children) +(define (gfile-enumerate-children gfile attributes follow-symlinks?) + (guarantee-string attributes 'gfile-enumerate-children) (let* ((genum (make-gfile-enumerator)) (gio-info (gio-cleanup-info genum)) (queue (gio-queue genum)) @@ -860,7 +907,7 @@ USA. (let retry () (C-call "g_file_enumerate_children_async" (gobject-alien gfile) - pattern + attributes (if follow-symlinks? (C-enum "G_FILE_QUERY_INFO_NONE") (C-enum "G_FILE_QUERY_INFO_NOFOLLOW_SYMLINKS")) diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index e6e64f10f..d6215366c 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -69,7 +69,8 @@ USA. maybe-yield-gtk) (export () open-input-gfile - open-output-gfile) + open-output-gfile + gdirectory-read) (export (gtk) diff --git a/tests/gtk/test-gfile-operations.scm b/tests/gtk/test-gfile-operations.scm index e92edbcb0..ccf79e319 100644 --- a/tests/gtk/test-gfile-operations.scm +++ b/tests/gtk/test-gfile-operations.scm @@ -24,8 +24,8 @@ USA. ;;;; Test gfile operations. (define (gcp src dst) - (let ((gsrc (open-input-gfile (->file-uri-string src))) - (gdst (open-output-gfile (->file-uri-string dst)))) + (let ((gsrc (open-input-gfile src)) + (gdst (open-output-gfile dst))) (let loop () (let ((line (read-line gsrc))) (if (eof-object? line) @@ -56,40 +56,12 @@ USA. (loop))))))) (define (ls pathname) - (delete! ".." - (delete! "." - (map file-namestring - (directory-read (->simple-namestring pathname)))))) + (let ((names (map file-namestring + (directory-read (->simple-namestring pathname))))) + (sort (delete! ".." (delete! "." names)) stringfile-uri-string uri))) - (genum (gfile-enumerate-children gfile "standard::name" #f))) - (let loop () - (let ((ginfos (gfile-enumerator-next-files genum 5))) - (if (null? ginfos) - (begin - (gfile-enumerator-close genum) - '()) - (map* (loop) - (lambda (ginfo) - (let ((name - (gfile-info-get-attribute-value ginfo - "standard::name"))) - (gobject-unref! ginfo) - name)) - ginfos)))))) - -(define-integrable (->file-uri-string pathname) - (string-append "file://" (->simple-namestring pathname))) - -(define-integrable (->simple-namestring pathname) - (->namestring (->simple-pathname pathname))) + (sort (gdirectory-read uri) stringsimple-pathname pathname) - (let loop ((simpler (pathname-simplify - (merge-pathnames pathname (working-directory-pathname)))) - (count 1)) - (let ((again (pathname-simplify simpler))) - (cond ((fix:> count 100) (error "Could not simplify:" pathname)) - ((pathname=? again simpler) again) - (else (loop again (fix:1+ count))))))) \ No newline at end of file +(define ->simple-namestring + (access ->simple-namestring (->environment '(gtk gio)))) \ No newline at end of file