Merge pull request #730 from vyzo/rip-run-tests

RIP std/run-tests.ss

.github/workflows/ci.yml

@@ -65,4 +65,4 @@ jobs:
         run: |
           export GERBIL_HOME=${GITHUB_WORKSPACE}
           export PATH=${GITHUB_WORKSPACE}/bin:$PATH
-          ./src/std/run-tests.ss
+          gxtest src/std/...

src/std/assert-test.ss

@@ -9,18 +9,10 @@
       (def e 'needle)
       (def l ['stack 'of 'hay])
       (check-exception (assert! (member e l))
-                       (lambda (e)
-                         (pregexp-match
-                          (string-append
-                           "Assertion failed \"assert-test.ss\"@\\d+\\.33: \\(member e l\\)\n"
-                           "  e => 'needle\n"
-                           "  l => \\['stack 'of 'hay\\]\n")
-                          (error-message e)))))
+                       (lambda (e) (string-prefix? "Assertion failed" (error-message e))))
 
     (test-case "test assert! on keyword functions"
       (assert! (true 0 a: 1))
       (check-exception (assert! (false 0 a: 1))
                        (lambda (e)
-                         (pregexp-match
-                          "Assertion failed \"assert-test.ss\"@\\d+\\.33: \\(false 0 a: 1\\)\n"
-                          (error-message e)))))))
+                         (string-prefix? "Assertion failed" (error-message e))))))))

src/std/build-deps

@@ -213,6 +213,7 @@
    std/sugar))
  (std/stxutil "stxutil" (gerbil/core std/format))
  (std/foreign "foreign" (gerbil/core std/stxutil))
+ (std/foreign-test-support "foreign-test-support" (gerbil/core std/foreign))
  (std/generic/macros
   "generic/macros"
   (gerbil/core std/generic/dispatch std/stxutil))
@@ -699,9 +700,6 @@
  (std/test
   "test"
   (gerbil/core gerbil/gambit std/error std/format std/misc/list std/sugar))
- (std/foreign-test
-  "foreign-test"
-  (gerbil/core gerbil/gambit std/foreign std/test))
  (std/misc/uuid
   "misc/uuid"
   (gerbil/core

src/std/build-spec.ss

@@ -6,7 +6,7 @@
     "interactive"
     "foreign"
     ;; tests for :std/foreign
-    "foreign-test"
+    "foreign-test-support"
     "format"
     "pregexp"
     "sort"

src/std/crypto-test.ss

@@ -11,17 +11,18 @@
         :gerbil/compiler)
 (export crypto-test)
 
-(def here (current-directory))
+(defsyntax (source-file stx)
+  (##container->path (##locat-container (stx-source stx))))
+
+(def here (path-directory (source-file)))
 
 (def crypto-test
   (test-suite "test :std/crypto"
     (test-case "static compilation with libcrypto"
-      (def top (path-normalize (path-expand "../.." here)))
-      (def src-dir (path-expand "src" top))
-      (def test-dir (path-expand "test" top))
-      (create-directory* test-dir)
+      (def test-dir "/tmp/test.out")
       (def src (path-expand "crypto/digest-test.ss" here))
       (def exe (path-expand "digest-test.exe" test-dir))
+      (create-directory* test-dir)
       (compile-file
        src [invoke-gsc: #t optimize: #f verbose: #f debug: #f static: #t output-dir: test-dir
             gsc-options: ["-cc-options" (cppflags "libcrypto" "")

src/std/crypto/digest-test.ss

@@ -61,6 +61,7 @@
 
 ;; For the purpose of testing: gxc -exe -static digest-test.ss
 (def (main . _)
+  (set-test-verbose! #f)
   (run-tests! digest-test)
   (test-report-summary!)
   (exit (case (test-result) ((OK) 0) (else 1))))

src/std/db/leveldb-test.ss

@@ -1,46 +1,53 @@
 ;;; -*- Gerbil -*-
 ;;; (C) vyzo at hackzen.org
 ;;; :std/db/leveldb unit-test
-(import :std/test
-        :std/db/leveldb
-        :std/format
-        :gerbil/gambit/random)
+(import :std/build-config)
+(cond-expand
+  (config-have-leveldb
+   (import :std/test
+           :std/db/leveldb
+           :std/os/temporaries)
 
-(export leveldb-test)
-(def leveldb-test
-  (test-suite "test :std/db/leveldb library"
-    (def db (leveldb-open (format "/tmp/test.db.~a" (random-integer (expt 2 32)))))
-    (test-case "test put/get/delete"
-      (leveldb-put db "abc" "this-is-abc")
-      (leveldb-put db "def" "this-is-def")
-      (check (bytes->string (leveldb-get db "abc")) => "this-is-abc")
-      (check (bytes->string (leveldb-get db "def")) => "this-is-def")
-      (leveldb-delete db "abc")
-      (check (leveldb-get db "abc") => #f)
-      (leveldb-delete db "def")
-      (check (leveldb-get db "def") => #f))
+   (export leveldb-test test-setup! test-cleanup!)
 
-    (test-case "test write batch"
-      (def wb (leveldb-writebatch))
-      (leveldb-writebatch-put wb "abc" "this-is-abc")
-      (leveldb-writebatch-put wb "def" "this-is-def")
-      (leveldb-write db wb)
-      (check (bytes->string (leveldb-get db "abc")) => "this-is-abc")
-      (check (bytes->string (leveldb-get db "def")) => "this-is-def"))
+   (def db #f)
+   (def (test-setup!)
+     (let (tmp (make-temporary-file-name "test.db"))
+       (set! db (leveldb-open tmp))))
+   (def (test-cleanup!)
+     (leveldb-close db))
 
-    (test-case "test iterators"
-      (def itor (leveldb-iterator db))
-      (check (leveldb-iterator-valid? itor) => #f)
-      (leveldb-iterator-seek-first itor)
-      (check (leveldb-iterator-valid? itor) => #t)
-      (check (bytes->string (leveldb-iterator-key itor)) => "abc")
-      (check (bytes->string (leveldb-iterator-value itor)) => "this-is-abc")
-      (leveldb-iterator-next itor)
-      (check (leveldb-iterator-valid? itor) => #t)
-      (check (bytes->string (leveldb-iterator-key itor)) => "def")
-      (check (bytes->string (leveldb-iterator-value itor)) => "this-is-def")
-      (leveldb-iterator-next itor)
-      (check (leveldb-iterator-valid? itor) => #f)
-      (leveldb-iterator-close itor))
+   (def leveldb-test
+     (test-suite "test :std/db/leveldb library"
+       (test-case "test put/get/delete"
+         (leveldb-put db "abc" "this-is-abc")
+         (leveldb-put db "def" "this-is-def")
+         (check (bytes->string (leveldb-get db "abc")) => "this-is-abc")
+         (check (bytes->string (leveldb-get db "def")) => "this-is-def")
+         (leveldb-delete db "abc")
+         (check (leveldb-get db "abc") => #f)
+         (leveldb-delete db "def")
+         (check (leveldb-get db "def") => #f))
 
-    (leveldb-close db)))
+       (test-case "test write batch"
+         (def wb (leveldb-writebatch))
+         (leveldb-writebatch-put wb "abc" "this-is-abc")
+         (leveldb-writebatch-put wb "def" "this-is-def")
+         (leveldb-write db wb)
+         (check (bytes->string (leveldb-get db "abc")) => "this-is-abc")
+         (check (bytes->string (leveldb-get db "def")) => "this-is-def"))
+
+       (test-case "test iterators"
+         (def itor (leveldb-iterator db))
+         (check (leveldb-iterator-valid? itor) => #f)
+         (leveldb-iterator-seek-first itor)
+         (check (leveldb-iterator-valid? itor) => #t)
+         (check (bytes->string (leveldb-iterator-key itor)) => "abc")
+         (check (bytes->string (leveldb-iterator-value itor)) => "this-is-abc")
+         (leveldb-iterator-next itor)
+         (check (leveldb-iterator-valid? itor) => #t)
+         (check (bytes->string (leveldb-iterator-key itor)) => "def")
+         (check (bytes->string (leveldb-iterator-value itor)) => "this-is-def")
+         (leveldb-iterator-next itor)
+         (check (leveldb-iterator-valid? itor) => #f)
+         (leveldb-iterator-close itor))))))

src/std/db/lmdb-test.ss

@@ -1,41 +1,53 @@
 ;;; -*- Gerbil -*-
 ;;; (C) vyzo at hackzen.org
 ;;; :std/db/lmdb unit-test
-(import :std/test
-        :std/db/lmdb
-        :std/db/_lmdb
-        :gerbil/gambit/random
-        :std/format)
+(import :std/build-config)
+(cond-expand
+  (config-have-lmdb
+   (import :std/test
+           :std/db/lmdb
+           :std/db/_lmdb
+           :std/os/temporaries)
+   (export lmdb-test test-setup! test-cleanup!)
 
-(export lmdb-test)
-(def lmdb-test
-  (test-suite "test :std/db/lmdb library"
-    (def env (lmdb-open (format "/tmp/test.db.~a" (random-integer (expt 2 32)))))
-    (def db (lmdb-open-db env "test"))
-    (test-case "test put txn"
-      (let (txn (lmdb-txn-begin env))
-        (lmdb-put txn db "hello" "world")
-        (lmdb-put txn db "hello2" "world2")
-        (check (bytes->string (lmdb-get txn db "hello")) => "world")
-        (check (bytes->string (lmdb-get txn db "hello2")) => "world2")
-        (lmdb-txn-commit txn)))
-    (test-case "test get"
-      (let (txn (lmdb-txn-begin env))
-        (check (bytes->string (lmdb-get txn db "hello")) => "world")
-        (check (bytes->string (lmdb-get txn db "hello2")) => "world2")
-        (lmdb-txn-commit txn)))
-    (test-case "test cursors"
-      (let* ((txn (lmdb-txn-begin env))
-             (cursor (lmdb-cursor-open txn db))
-             (entries
-              (let lp ((next (lmdb-cursor-get cursor MDB_FIRST)) (vals []))
-                (match next
-                  ((values key val)
-                   (lp (lmdb-cursor-get cursor MDB_NEXT) (cons (cons (bytes->string key)
-                                                                     (bytes->string val))
-                                                               vals)))
-                  (#f (reverse vals))))))
-        (check (length entries) => 2)
-        (check (cdr (assoc "hello" entries)) => "world")
-        (check (cdr (assoc "hello2" entries)) => "world2")
-        (lmdb-txn-commit txn)))))
+   (def env #f)
+   (def db #f)
+
+   (def (test-setup!)
+     (let (tmp (make-temporary-file-name "test.db"))
+       (set! env (lmdb-open tmp))
+       (set! db (lmdb-open-db env "test"))))
+
+   (def (test-cleanup!)
+     (lmdb-close-db db)
+     (lmdb-close env))
+
+   (def lmdb-test
+     (test-suite "test :std/db/lmdb library"
+       (test-case "test put txn"
+         (let (txn (lmdb-txn-begin env))
+           (lmdb-put txn db "hello" "world")
+           (lmdb-put txn db "hello2" "world2")
+           (check (bytes->string (lmdb-get txn db "hello")) => "world")
+           (check (bytes->string (lmdb-get txn db "hello2")) => "world2")
+           (lmdb-txn-commit txn)))
+       (test-case "test get"
+         (let (txn (lmdb-txn-begin env))
+           (check (bytes->string (lmdb-get txn db "hello")) => "world")
+           (check (bytes->string (lmdb-get txn db "hello2")) => "world2")
+           (lmdb-txn-commit txn)))
+       (test-case "test cursors"
+         (let* ((txn (lmdb-txn-begin env))
+                (cursor (lmdb-cursor-open txn db))
+                (entries
+                 (let lp ((next (lmdb-cursor-get cursor MDB_FIRST)) (vals []))
+                   (match next
+                     ((values key val)
+                      (lp (lmdb-cursor-get cursor MDB_NEXT) (cons (cons (bytes->string key)
+                                                                        (bytes->string val))
+                                                                  vals)))
+                     (#f (reverse vals))))))
+           (check (length entries) => 2)
+           (check (cdr (assoc "hello" entries)) => "world")
+           (check (cdr (assoc "hello2" entries)) => "world2")
+           (lmdb-txn-commit txn)))))))

src/std/db/mysql-test.ss

@@ -1,69 +1,73 @@
 ;;; -*- Gerbil -*-
 ;;; (C) vyzo at hackzen.org
 ;;; :std/db/mysql unit-test
-(import :std/test
-        :std/db/dbi
-        :std/db/mysql)
-(export mysql-test)
-(def mysql-test
-  (test-suite "test :std/db/mysql"
-    (def db (sql-connect mysql-connect host: "localhost" user: "test" passwd: "test" db: "test"))
+(import :std/build-config)
+(cond-expand
+  ((and config-have-mysql enable-mysql-test)
+   (import :std/test
+           :std/db/dbi
+           :std/db/mysql)
+   (export mysql-test test-setup! test-cleanup!)
 
-    (test-case "prepare tables"
-      (with-catch void (cut sql-eval db "DROP TABLE Users"))
-      (with-catch void (cut sql-eval db "DROP TABLE HitCount"))
+   (def db #f)
+   (def (test-setup!)
+     (set! db (sql-connect mysql-connect host: "localhost" user: "test" passwd: "test" db: "test"))
+     (with-catch void (cut sql-eval db "DROP TABLE Users"))
+     (with-catch void (cut sql-eval db "DROP TABLE HitCount")))
+   (def (test-cleanup!)
+     (with-catch void (cut sql-eval db "DROP TABLE Users"))
+     (with-catch void (cut sql-eval db "DROP TABLE HitCount"))
+     (sql-close db))
 
-      (let (stmt (sql-prepare db "CREATE TABLE Users (FirstName VARCHAR(20), LastName VARCHAR(20), Secret VARCHAR(20))"))
-        (check (sql-exec stmt) => #!void)
-        (sql-finalize stmt))
+   (def mysql-test
+     (test-suite "test :std/db/mysql"
+       (test-case "prepare tables"
+         (let (stmt (sql-prepare db "CREATE TABLE Users (FirstName VARCHAR(20), LastName VARCHAR(20), Secret VARCHAR(20))"))
+           (check (sql-exec stmt) => #!void)
+           (sql-finalize stmt))
 
-      (let (stmt (sql-prepare db "INSERT INTO Users (FirstName, LastName, Secret) VALUES (?, ?, ?)"))
-        (sql-bind stmt "John" "Smith" "very secret")
-        (check (sql-exec stmt) => #!void)
-        (sql-reset stmt)
-        (sql-clear stmt)
-        (sql-bind stmt "Marc" "Smith" "oh so secret")
-        (check (sql-exec stmt) => #!void)
-        (sql-bind stmt "Minnie" "Smith" #f)
-        (check (sql-exec stmt) => #!void)
-        (sql-finalize stmt))
+         (let (stmt (sql-prepare db "INSERT INTO Users (FirstName, LastName, Secret) VALUES (?, ?, ?)"))
+           (sql-bind stmt "John" "Smith" "very secret")
+           (check (sql-exec stmt) => #!void)
+           (sql-reset stmt)
+           (sql-clear stmt)
+           (sql-bind stmt "Marc" "Smith" "oh so secret")
+           (check (sql-exec stmt) => #!void)
+           (sql-bind stmt "Minnie" "Smith" #f)
+           (check (sql-exec stmt) => #!void)
+           (sql-finalize stmt))
 
-      (let (stmt (sql-prepare db "CREATE TABLE HitCount (User VARCHAR(20), Hits INTEGER)"))
-        (check (sql-exec stmt) => #!void)
-        (sql-finalize stmt))
+         (let (stmt (sql-prepare db "CREATE TABLE HitCount (User VARCHAR(20), Hits INTEGER)"))
+           (check (sql-exec stmt) => #!void)
+           (sql-finalize stmt))
 
-      (let (stmt (sql-prepare db "INSERT INTO HitCount (User,Hits) VALUES (?, ?)"))
-        (sql-bind stmt "john" 20)
-        (check (sql-exec stmt) => #!void)
-        (sql-finalize stmt)))
+         (let (stmt (sql-prepare db "INSERT INTO HitCount (User,Hits) VALUES (?, ?)"))
+           (sql-bind stmt "john" 20)
+           (check (sql-exec stmt) => #!void)
+           (sql-finalize stmt)))
 
-    (test-case "read and modify table"
+       (test-case "read and modify table"
+         (let (stmt (sql-prepare db "SELECT * FROM Users"))
+           (check (sql-query stmt) => '(#("John" "Smith" "very secret")
+                                        #("Marc" "Smith" "oh so secret")
+                                        #("Minnie" "Smith" #f))))
 
-      (let (stmt (sql-prepare db "SELECT * FROM Users"))
-        (check (sql-query stmt) => '(#("John" "Smith" "very secret")
-                                      #("Marc" "Smith" "oh so secret")
-                                      #("Minnie" "Smith" #f))))
+         (let (stmt (sql-prepare db "SELECT * FROM Users WHERE FirstName = ?"))
+           (sql-bind stmt "John")
+           (check (sql-query stmt) => '(#("John" "Smith" "very secret")))
+           (sql-finalize stmt))
 
-      (let (stmt (sql-prepare db "SELECT * FROM Users WHERE FirstName = ?"))
-        (sql-bind stmt "John")
-        (check (sql-query stmt) => '(#("John" "Smith" "very secret")))
-        (sql-finalize stmt))
+         (let (stmt (sql-prepare db "DELETE FROM Users WHERE FirstName = ?"))
+           (sql-bind stmt "Marc")
+           (check (sql-exec stmt) => #!void)
+           (sql-finalize stmt))
 
-      (let (stmt (sql-prepare db "DELETE FROM Users WHERE FirstName = ?"))
-        (sql-bind stmt "Marc")
-        (check (sql-exec stmt) => #!void)
-        (sql-finalize stmt))
+         (let (stmt (sql-prepare db "SELECT * FROM Users"))
+           (check (sql-query stmt) => '(#("John" "Smith" "very secret")
+                                        #("Minnie" "Smith" #f)))
+           (sql-finalize stmt))
 
-      (let (stmt (sql-prepare db "SELECT * FROM Users"))
-        (check (sql-query stmt) => '(#("John" "Smith" "very secret")
-                                      #("Minnie" "Smith" #f)))
-        (sql-finalize stmt))
-
-      (let (stmt (sql-prepare db "SELECT * FROM HitCount"))
-        (check (sql-query stmt) => '(#("john" 20)))
-        (sql-finalize stmt)))
-
-    (with-catch void (cut sql-eval db "DROP TABLE Users"))
-    (with-catch void (cut sql-eval db "DROP TABLE HitCount"))
-
-    (sql-close db)))
+         (let (stmt (sql-prepare db "SELECT * FROM HitCount"))
+           (check (sql-query stmt) => '(#("john" 20)))
+           (sql-finalize stmt)))
+       ))))