From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Wed, 27 Jul 2011 19:41:02 +0000 (-0700)
Subject: Added test-gtk, test-gfile-operations.scm.
X-Git-Tag: mit-scheme-pucked-9.2.12~661
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e500172f39f1262594392bcc187371250beb18e0;p=mit-scheme.git

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

diff --git a/src/Makefile.in b/src/Makefile.in
index 0d31c7384..97986f428 100644
--- 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 9d04953fb..dfe60718a 100644
--- 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
index 000000000..e92edbcb0
--- /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.
+
+(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 490789781..d57b82704 100644
--- 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
index 000000000..ac155776f
--- /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