From: Matt Birkholz Date: Fri, 13 Jul 2012 02:07:46 +0000 (-0700) Subject: gtk: Run gtk/test-gtk.scm which now punts if DISPLAY is not set. X-Git-Tag: mit-scheme-pucked-9.2.12~585 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4affd1c02f83b5f5bf4e005759c7f4f9836c9294;p=mit-scheme.git gtk: Run gtk/test-gtk.scm which now punts if DISPLAY is not set. --- diff --git a/tests/check.scm b/tests/check.scm index 7d436ed57..74c71cf23 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -47,11 +47,11 @@ USA. "runtime/test-floenv" "runtime/test-hash-table" "runtime/test-integer-bits" - "runtime/test-process" +; "runtime/test-process" "runtime/test-regsexp" ("runtime/test-wttree" (runtime wt-tree)) - "ffi/test-ffi" - ;;"gtk/test-gtk" ;Requires a DISPLAY at the mo'. + "ffi/test-ffi.scm" + "gtk/test-gtk.scm" )) (with-working-directory-pathname diff --git a/tests/gtk/test-gfile-operations.scm b/tests/gtk/gtk-tests.scm similarity index 60% rename from tests/gtk/test-gfile-operations.scm rename to tests/gtk/gtk-tests.scm index ccf79e319..b85aa6c80 100644 --- a/tests/gtk/test-gfile-operations.scm +++ b/tests/gtk/gtk-tests.scm @@ -1,6 +1,9 @@ #| -*-Scheme-*- -Copyright (C) 2011 Matthew Birkholz +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, 2012 Massachusetts Institute + of Technology This file is part of MIT/GNU Scheme. @@ -21,8 +24,29 @@ USA. |# -;;;; Test gfile operations. +;;;; Test procedures for the gtks. +;;; GIO tests. + +(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 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/") stringsimple-namestring - (access ->simple-namestring (->environment '(gtk gio)))) \ No newline at end of file + (access ->simple-namestring (->environment '(gtk gio)))) + +;;; Gtk tests. + +(define (await-closed-demos) + (gtk-time-slice-window! #t) + (hello) + (make-gtk-event-viewer-demo) + (make-fix-layout-demo) + (make-pole-zero) + (let loop () + (if (not (null? (access toplevel-windows + (->environment '(gtk gtk-object))))) + (begin + (sleep-current-thread 1000) + (loop))))) \ No newline at end of file diff --git a/tests/gtk/test-gtk.scm b/tests/gtk/test-gtk.scm index ac155776f..bd8f9fb43 100644 --- a/tests/gtk/test-gtk.scm +++ b/tests/gtk/test-gtk.scm @@ -1,37 +1,64 @@ ;;;-*-Scheme-*- -(load-option 'Gtk) +(define gcp) +(define gls) +(define ls) +(define await-closed-demos) +(define registered-callback-count) +(define malloced-aliens) +(define (main) + (let ((new (extend-top-level-environment (->environment '(gtk)))) + (ffi (->environment '(runtime ffi)))) + (with-working-directory-pathname "gtk/" + (lambda () + (compile-file "gtk-tests" '() new) + (load "gtk-tests" new))) + (load "../src/gtk/hello.scm" new) + (set! gcp (access gcp new)) + (set! gls (access gls new)) + (set! ls (access ls new)) + (set! await-closed-demos (access await-closed-demos new)) + (set! registered-callback-count + (access registered-callback-count ffi)) + (set! malloced-aliens (access malloced-aliens ffi))) -(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 'gio-copy + (let ((cwd (directory-pathname (current-load-pathname)))) + (named-lambda (gio-copy-test) + (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) + 'EXPRESSION (list 'GCP file1 file2)))))))) -(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-test 'gio-list + (let ((cwd (directory-pathname (current-load-pathname)))) + (named-lambda (gio-list-test) + (with-working-directory-pathname cwd + (lambda () + (let ((native (sort (ls "../runtime/") stringenvironment '(gtk)))) + (define-test 'gtk-demos + (lambda () + (await-closed-demos) + (gc-flip))) -(define-test 'gio-copy test-copy-integrity) + (define-test 'gtk-demos.callbacks + (lambda () + (assert-= (car (registered-callback-count)) + 0 + 'EXPRESSION '(REGISTERED-CALLBACK-COUNT)))) -(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/") stringenvironment '(gtk)))) -(define ls (access ls (->environment '(gtk)))) - -(define-test 'gio-list test-child-enumeration) \ No newline at end of file +(if (not (warn-errors? (lambda () (load-option 'gtk)))) + (main)) \ No newline at end of file