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 d8973fab76c69a52c88155f79e7b7c8882f6f32f..6a95d7e5237b7da88bd25f36cc67afe019e7df97 100644 (file)
--- 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)))))))
 \f
 (define-class <gio>
     (<gobject>)
@@ -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 e6e64f10f473f5586932456241afc9cfa8276e5e..d6215366c2247fd3f5ba05cf20be4eaa5e5d72fe 100644 (file)
--- 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)
          <g-stream>
          <g-input-stream>

diff --git a/tests/gtk/test-gfile-operations.scm b/tests/gtk/test-gfile-operations.scm
index e92edbcb029f23be78a71b25d8d648af25541b85..ccf79e3199242512d03fb30e04df1d3765847299 100644 (file)
--- a/tests/gtk/test-gfile-operations.scm
+++ b/tests/gtk/test-gfile-operations.scm
@@ -24,8 +24,8 @@ USA.
 ;;;; Test gfile operations.
 \f
 (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)) string<?)))
 
 (define (gls uri)
-  (let* ((gfile (make-gfile (->file-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) string<?))
 
-(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)))))))
\ No newline at end of file
+(define ->simple-namestring
+  (access ->simple-namestring (->environment '(gtk gio))))
\ No newline at end of file