Added test-gtk, test-gfile-operations.scm.

diff --git a/src/Makefile.in b/src/Makefile.in
index 0d31c7384e8651244c71a95df120b6ce29a09434..97986f42804878d0dbca7f8c4d3432572fcff8da 100644 (file)
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -76,7 +76,7 @@ all: @ALL_TARGET@
 
 check:
        ./microcode/scheme --library lib --batch-mode \
-         --load ../tests/check.scm --eval '(%exit)'
+         --load ../tests/check.scm </dev/null
 
 all-native: compile-microcode
        @$(top_srcdir)/etc/compile.sh "$(MIT_SCHEME_EXE)" --batch-mode

diff --git a/tests/check.scm b/tests/check.scm
index 9d04953fb6b36dfc5df6c8b677a3c602a514565d..dfe60718a0654cab4f953b0fa6d43fa082057e0a 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -51,6 +51,7 @@ USA.
     "runtime/test-regsexp"
     ("runtime/test-wttree" (runtime wt-tree))
     "ffi/test-ffi"
+    "gtk/test-gtk"
     ))
 
 (with-working-directory-pathname

diff --git a/tests/gtk/test-gfile-operations.scm b/tests/gtk/test-gfile-operations.scm
new file mode 100644 (file)
index 0000000..e92edbc
--- /dev/null
+++ b/tests/gtk/test-gfile-operations.scm
@@ -0,0 +1,95 @@
+#| -*-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.
+
+|#
+
+;;;; 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 loop ()
+      (let ((line (read-line gsrc)))
+       (if (eof-object? line)
+           (begin
+             ;; Close the streams OR NOT, e.g. to test GCing of
+             ;; abandoned (quiet) ports.  Testing GCing of a port
+             ;; with an operation pending would be... useful, and
+             ;; tricky.
+             (close-input-port gsrc)
+             (close-output-port gdst))
+           (begin
+             (write-string line gdst) (newline gdst)
+             (loop)))))))
+
+(define (gcat uri)
+  (let ((gstream (open-input-gfile uri)))
+    (let loop ()
+      (let ((line (read-line gstream)))
+       (if (eof-object? line)
+           (begin
+             ;; Close the gstream OR NOT, e.g. to test GCing of
+             ;; abandoned (quiet) ports.  Testing GCing of a port
+             ;; with an operation pending would be... useful, and
+             ;; tricky.
+             (close-input-port gstream))
+           (begin
+             (write-string line) (newline)
+             (loop)))))))
+
+(define (ls pathname)
+  (delete! ".."
+          (delete! "."
+                   (map file-namestring
+                        (directory-read (->simple-namestring pathname))))))
+
+(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)))
+
+(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

diff --git a/tests/gtk/test-gport-performance.scm b/tests/gtk/test-gport-performance.scm
index 49078978106e863bcd85be6dc0bedda507b689e3..d57b8270403e43aa02727fd58f8bbcd532b51522 100644 (file)
--- a/tests/gtk/test-gport-performance.scm
+++ b/tests/gtk/test-gport-performance.scm
@@ -1,9 +1,6 @@
 #| -*-Scheme-*-
 
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
-    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009, 2010, 2011 Massachusetts Institute of
-    Technology
+Copyright (C) 2011  Matthew Birkholz
 
 This file is part of MIT/GNU Scheme.
 
@@ -124,12 +121,14 @@ USA.
               (loop (cdr lines)))))))))
 
 (define (call-with-input-gfile pathname receiver)
-  (let* ((port ((access open-input-gfile (->environment '(gtk)))
-               (string-append "file://" (->simple-namestring pathname))))
+  (let* ((port (open-input-gfile (->file-uri-string pathname)))
         (value (receiver port)))
     (close-input-port port)
     value))
 
+(define-integrable (->file-uri-string pathname)
+  (string-append "file://" (->simple-namestring pathname)))
+
 (define-integrable (->simple-namestring pathname)
   (->namestring (->simple-pathname pathname)))
 
@@ -150,9 +149,7 @@ USA.
 (define (call-with-tmp-output-gfile receiver)
   (call-with-temporary-file-pathname
    (lambda (pathname)
-     (let* ((port ((access open-output-gfile (->environment '(gtk)))
-                  (string-append "file://"
-                                 (->simple-namestring pathname))))
+     (let* ((port (open-output-gfile (->file-uri-string pathname)))
            (value (receiver port)))
        (close-output-port port)
        value))))

diff --git a/tests/gtk/test-gtk.scm b/tests/gtk/test-gtk.scm
new file mode 100644 (file)
index 0000000..ac15577
--- /dev/null
+++ b/tests/gtk/test-gtk.scm
@@ -0,0 +1,37 @@
+;;;-*-Scheme-*-
+
+(load-option 'Gtk)
+
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+  (lambda ()
+    (let ((env (->environment '(gtk))))
+      (compile-file "test-gfile-operations" '() env)
+      (load "test-gfile-operations" env))))
+
+(define test-copy-integrity
+  (let ((cwd (directory-pathname (current-load-pathname))))
+    (named-lambda (test-copy-integrity)
+      (with-working-directory-pathname cwd
+       (lambda ()
+         (let ((file1 "../../src/README.txt")
+               (file2 "test-copy-1.txt"))
+           (gcp file1 file2)
+           (assert-equal (md5-file file2) (md5-file file1))))))))
+
+(define gcp (access gcp (->environment '(gtk))))
+
+(define-test 'gio-copy test-copy-integrity)
+
+(define test-child-enumeration
+  (let ((cwd (directory-pathname (current-load-pathname))))
+    (named-lambda (test-child-enumeration)
+      (with-working-directory-pathname cwd
+       (lambda ()
+         (let ((native (sort (ls "../runtime/") string<?))
+               (gio (sort (gls "../runtime/") string<?)))
+           (assert-equal gio native)))))))
+
+(define gls (access gls (->environment '(gtk))))
+(define ls (access ls (->environment '(gtk))))
+
+(define-test 'gio-list test-child-enumeration)
\ No newline at end of file