diff options
Diffstat (limited to '')
-rwxr-xr-x | tests/run-tests.scm | 9 | ||||
-rw-r--r-- | tests/test/let-env.scm | 48 | ||||
-rw-r--r-- | tests/test/srfi-41-util.scm | 20 | ||||
-rw-r--r-- | tests/test/util.scm | 379 | ||||
-rw-r--r-- | tests/test/uuid.scm | 13 | ||||
-rw-r--r-- | tests/test/xdg-basedir.scm | 58 | ||||
-rwxr-xr-x | tests/validate-html/run-validator.scm | 8 |
7 files changed, 520 insertions, 15 deletions
diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 6c6ff95a..4b6d2773 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -1,9 +1,8 @@ #!/usr/bin/env bash # -*- mode: scheme; geiser-scheme-implementation: guile -*- -here=$(dirname $(realpath $0)) - -. "$(dirname "$here")/env" +root=$(dirname "$(dirname "$(realpath "$0")")") +eval "$(env __PRINT_ENVIRONMENT=1 ${root}/calp)" if [ "$DEBUG" = '' ]; then exec $GUILE -s "$0" "$@" @@ -12,6 +11,10 @@ else fi !# +(unless (getenv "CALP_TEST_ENVIRONMENT") + (format (current-error-port) "Not running in test environment, abandoning~%") + (exit 1)) + (format #t "current-filename = ~s~%" (current-filename)) (define here (dirname (current-filename))) diff --git a/tests/test/let-env.scm b/tests/test/let-env.scm new file mode 100644 index 00000000..a989776a --- /dev/null +++ b/tests/test/let-env.scm @@ -0,0 +1,48 @@ +(define-module (test let-env) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module ((guile) :select (setenv getenv)) + :use-module ((hnh util env) :select (let-env))) + +(setenv "CALP_TEST_ENV" "1") + +(test-equal + "Ensure we have set value beforehand" + "1" + (getenv "CALP_TEST_ENV")) + +(let-env + ((CALP_TEST_ENV "2")) + (test-equal + "Test our local override" + "2" + (getenv "CALP_TEST_ENV"))) + +(test-equal + "Test that we have returned" + "1" + (getenv "CALP_TEST_ENV")) + +(catch 'test-error + (lambda () + (let-env + ((CALP_TEST_ENV "2")) + (test-equal + "Test our local override again" + "2" + (getenv "CALP_TEST_ENV")) + (throw 'test-error))) + list) + +(test-equal + "Test restoration after non-local exit" + "1" + (getenv "CALP_TEST_ENV")) + + +(test-group "Unsetting environment" + (setenv "TEST" "A") + (let-env ((TEST #f)) + (test-assert (not (getenv "TEST")))) + (test-equal "A" (getenv "TEST"))) diff --git a/tests/test/srfi-41-util.scm b/tests/test/srfi-41-util.scm index ff0e3cce..9a753b03 100644 --- a/tests/test/srfi-41-util.scm +++ b/tests/test/srfi-41-util.scm @@ -8,6 +8,7 @@ :use-module (srfi srfi-88) :use-module (srfi srfi-41 util) :use-module (srfi srfi-41) + :use-module ((srfi srfi-1) :select (circular-list)) :use-module ((ice-9 sandbox) :select (call-with-time-limit))) (test-equal "Finite stream" @@ -86,3 +87,22 @@ (test-equal "time limited stream" '(1 2 3) (stream->list strm)))) + + +(test-group "stream-split-by" + (let ((hello-chars-stream (stream-unfold + car + (const #t) + cdr + (apply circular-list + (string->list "Hello "))))) + (test-equal "Check that test list looks as expected" + (string->list "Hello Hell") + (stream->list 10 hello-chars-stream)) + (test-equal "Check that it splits correctly" + '("Hello " "Hello " "Hello ") + (stream->list + 3 + (stream-map list->string + (stream-split-by (lambda (c) (char=? c #\space)) + hello-chars-stream)))))) diff --git a/tests/test/util.scm b/tests/test/util.scm new file mode 100644 index 00000000..bdd6e98e --- /dev/null +++ b/tests/test/util.scm @@ -0,0 +1,379 @@ +;;; Commentary: +;; Checks some prodecuders from (hnh util) +;;; Code: + +(define-module (test util) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (srfi srfi-1) + :use-module (hnh util) + :use-module (hnh util env) + :use-module ((hnh util path) + :select (path-append + path-split + file-hidden? + realpath + relative-to + filename-extension))) + +(test-group "Conditionals" + (test-equal "when" + 1 (when #t 1)) + + (test-equal "'() when #f" + '() (when #f 1)) + + (test-equal "unless" + 1 (unless #f 1)) + + (test-equal "'() unless #t" + '() (unless #t 1)) + + (test-equal "awhen it" + '(3 4 5) + (awhen (memv 2 '(1 2 3 4 5)) + (cdr it))) + + (test-equal "awhen not" + '() + (awhen (memv 0 '(1 2 3 4 5)) + (cdr it)))) + +(test-group "for" + (test-equal "for simple" + (iota 10) + (for x in (iota 10) + x)) + + (test-equal "for matching" + (iota 12) + (for (x c) in (zip (iota 12) (string->list "Hello, World")) + x)) + + (test-equal "for with improper list elements" + `(3 7) + (for (a . b) in '((1 . 2) (3 . 4)) + (+ a b))) + + (test-equal "for with longer improper list elements" + '(1 2 4) + (for (a b . c) in '((1 -1 . 1) (2 -2 . 2) (4 -4 . 4)) + (* c (+ 1 a b)))) + + (test-equal "for break" + 'x + (for x in (iota 10) + (break 'x) + (test-assert "This should never happen" #f))) + + (test-equal "for continue" + '(x #f 2) + (for x in (iota 3) + (case x + ((0) + (continue 'x) + (test-assert "Continue with value failed" #f)) + ((1) + (continue) + (test-assert "Continue without value failed" #f)) + (else x))))) + +(test-equal "procedure label" + 120 + ((label factorial (lambda (n) + (if (zero? n) + 1 (* n (factorial (1- n)))))) + 5)) + +;; we can't test if sort*! destroys the list, since its only /allowed/ to do it, +;; not required. +(test-equal "sort*!" + '("a" "Hello" "Assparagus") + (sort*! '("Hello" "a" "Assparagus") + < string-length)) + +(test-assert "not equal" + (!= 1 2)) + +(test-equal "Take to" + '() (take-to '() 5)) + +(test-equal "Enumerate" + '((0 #\H) (1 #\e) (2 #\l) (3 #\l) (4 #\o) (5 #\,) (6 #\space) (7 #\W) (8 #\o) (9 #\r) (10 #\l) (11 #\d) (12 #\!)) + (enumerate (string->list "Hello, World!"))) + +(test-equal "unval first" + 1 + ((unval (lambda () (values 1 2 3))))) + +(test-equal "unval other" + 2 + ((unval car+cdr 1) + (cons 1 2))) + +(test-group "Flatten" + (test-equal "flatten already flat" + (iota 10) + (flatten (iota 10))) + + (test-equal "flatten really deep" + '(1) + (flatten '(((((((((((((((1))))))))))))))))) + + (test-equal "flatten mixed" + '(1 2 3 4 5) + (flatten '((((((1(((((2((((3))))))4))))))))5)))) + +;; TODO test let-lazy + +(test-group "map/dotted" + (test-equal "map/dotted without dot" + '(1 2 3 4) + (map/dotted 1+ '(0 1 2 3))) + + (test-equal "map/dotted with dot" + '(1 2 3 . 4) + (map/dotted 1+ '(0 1 2 . 3))) + + (test-equal "map/dotted direct value" + 1 (map/dotted 1+ 0))) + + +(test-group "Arrows" + (test-equal "->" 9 (-> 1 (+ 2) (* 3))) + (test-equal "-> order dependant" -1 (-> 1 (- 2))) + (test-equal "->> order dependant" 1 (->> 1 (- 2)))) + +;; TODO set and set-> + +;; TODO and=>> + +(test-equal "Group" + '((0 1) (2 3) (4 5) (6 7) (8 9)) + (group (iota 10) 2)) + +;; TODO test failure when grouping isn't possible? + +(test-group "Associations" + (test-equal "assoc-ref-all" '(1 3) (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a)) + (test-equal "assq-ref-all" '(1 3) (assq-ref-all '((a . 1) (b . 2) (a . 3)) 'a)) + (test-equal "assv-ref-all "'(1 3) (assv-ref-all '((a . 1) (b . 2) (a . 3)) 'a)) + + ;; TODO assq-limit ? + + (test-equal "assq merge" + '((k 2 1) (v 2)) + (assq-merge '((k 1) (v 2)) '((k 2)))) + + (test-equal "kvlist->assq" + '((a . 1) (b . 2)) + (kvlist->assq '(a: 1 b: 2))) + + + (test-equal "kvlist->assq repeated key" + '((a . 1) (b . 2) (a . 3)) + (kvlist->assq '(a: 1 b: 2 a: 3)))) + +(test-equal "vector-last" + 1 (vector-last #(0 2 3 1))) + +;; TODO test catch* + +(test-equal + "Filter sorted" + '(3 4 5) + (filter-sorted (lambda (x) (<= 3 x 5)) (iota 10))) + +(test-equal + "set/r! = single" + #f + (let ((x #t)) (set/r! x = not))) + +(test-error + 'syntax-error + (test-read-eval-string "(set/r! x err not)")) + +(test-group "Find extremes" + (call-with-values + (lambda () (find-min (iota 10))) + (lambda (extreme rest) + (test-equal "Found correct minimum" 0 extreme) + (test-equal + "Removed \"something\" from the set" + 9 + (length rest)))) + + (call-with-values + (lambda () + (find-max + '("Hello" "Test" "Something long") + string-length)) + (lambda (extreme rest) + (test-equal + "Found the longest string" + "Something long" + extreme) + (test-equal "Removed the string" 2 (length rest)) + (test-assert + "Other members left 1" + (member "Hello" rest)) + (test-assert + "Other members left 2" + (member "Test" rest)))) + + (test-error 'wrong-type-arg (find-extreme '()))) + +(test-group "Span upto" + (call-with-values + (lambda () + (span-upto + 2 + char-numeric? + (string->list "123456"))) + (lambda (head tail) + (test-equal '(#\1 #\2) head) + (test-equal '(#\3 #\4 #\5 #\6) tail))) + + (call-with-values + (lambda () + (span-upto + 2 + char-numeric? + (string->list "H123456"))) + (lambda (head tail) + (test-equal '() head) + (test-equal '(#\H #\1 #\2 #\3 #\4 #\5 #\6) tail)))) + +(test-group "Begin1" + (let ((value #f)) + (test-equal + "begin1 return value" + "Hello" + (begin1 "Hello" (set! value "World"))) + (test-equal "begin1 side effects" "World" value)) + + (let ((x 1)) + (test-eqv "begin1 set! after return" + 1 (begin1 x (set! x 10))) + (test-eqv "Updates value" + 10 x))) + +(test-equal 0 (iterate 1- zero? 10)) + +(test-equal "5" (->string 5)) + +(test-equal "5" (->string "5")) + +(test-group "Path operations" + (test-equal + "no slashes" + "home/user" + (path-append "home" "user")) + + (test-equal + "no slashes, absolute" + "/home/user" + (path-append "" "home" "user")) + + (test-equal + "slashes in one component, absolute" + "/home/user" + (path-append "" "/home/" "user")) + + (test-equal + "slashes in one component, absolute due to first" + "/home/user" + (path-append "/home/" "user")) + + (test-equal + "Slashes in both" + "home/user" + (path-append "home/" "/user")) + + (test-equal "root" "/" (path-append "")) + + (test-equal + '("usr" "lib" "test") + (path-split "usr/lib/test")) + + (test-equal + '("usr" "lib" "test") + (path-split "usr/lib/test/")) + + (test-equal + '("" "usr" "lib" "test") + (path-split "/usr/lib/test")) + + (test-equal + '("" "usr" "lib" "test") + (path-split "//usr////lib/test")) + + (test-assert (file-hidden? ".just-filename")) + (test-assert (file-hidden? "/path/to/.hidden")) + (test-assert (not (file-hidden? "/visible/.in/hidden"))) + (test-assert (not (file-hidden? ""))) + + ;; TODO test realpath with .. and similar + + (test-equal "Realpath for path fragment" + "/home/hugo" + (with-working-directory + "/home" + (lambda () (realpath "hugo")))) + + (test-equal "Realpath for already absolute path" + "/home/hugo" + (with-working-directory + "/tmp" + (lambda () (realpath "/home/hugo")))) + + + (test-group "Relative to" + + (test-group "With relative child" + (test-equal "/some/path" (relative-to "/some" "path"))) + + ;; Relative parent just adds (getcwd) to start of parent, + ;; but this is "hard" to test. + ;; (test-group "With relative parent") + + (test-group "With absolute child" + (test-error 'misc-error (relative-to "" "/some/path")) + (test-equal "some/path" (relative-to "/" "/some/path")) + (test-group "Without trailing slashes" + (test-equal "path" (relative-to "/some" "/some/path")) + (test-equal "../path" (relative-to "/some" "/other/path"))) + (test-group "With trailing slashes" + (test-equal "path" (relative-to "/some" "/some/path/")) + (test-equal "../path" (relative-to "/some" "/other/path/")))) + + (test-equal "/a/b" (relative-to "/a/b/c" "/a/b")) + + ) + + + (test-equal "Extension of simple file" + "txt" (filename-extension "file.txt")) + + (test-equal "Extension of file with directory" + "txt" (filename-extension "/direcotry/file.txt")) + + (test-equal "Extension of file with multiple" + "gz" (filename-extension "filename.tar.gz")) + + (test-equal "Filename extension when none is present" + "" (filename-extension "filename")) + + (test-equal "Filename extension when none is present, but directory has" + "" (filename-extension "config.d/filename")) + + (test-equal "Filename extension of directory" + "d" (filename-extension "config.d/")) + + + (test-equal "Extension of hidden file" + "sh" (filename-extension ".bashrc.sh")) + + (test-equal "Extension of hidden file without extension" + "bashrc" (filename-extension ".bashrc"))) diff --git a/tests/test/uuid.scm b/tests/test/uuid.scm index b73db5f4..1cedb59e 100644 --- a/tests/test/uuid.scm +++ b/tests/test/uuid.scm @@ -6,13 +6,6 @@ (test-equal "UUIDv4 fixed seed" - (let ((version (version))) - (cond ((string=? version "2.2.7") - "d19c9347-9a85-4432-a876-5fb9c0d24d2b") - ((string=? version "3.0.9") - "d19c9347-9a85-4432-a876-5fb9c0d24d2b") - (else - "Randomness isn't stable between guile versions"))) - (begin - (parameterize ((seed (seed->random-state 0))) - (uuid-v4)))) + "d19c9347-9a85-4432-a876-5fb9c0d24d2b" + (parameterize ((seed (seed->random-state 0))) + (uuid-v4))) diff --git a/tests/test/xdg-basedir.scm b/tests/test/xdg-basedir.scm new file mode 100644 index 00000000..682c1347 --- /dev/null +++ b/tests/test/xdg-basedir.scm @@ -0,0 +1,58 @@ +(define-module (test xdg-basedir) + :use-module (srfi srfi-64) + :use-module ((xdg basedir) :prefix xdg-) + :use-module (srfi srfi-88) + :use-module ((hnh util env) :select (let-env)) + ) + + +(let-env ((HOME "/home/user") + (XDG_DATA_HOME #f) + (XDG_CONFIG_HOME #f) + (XDG_STATE_HOME #f) + (XDG_DATA_DIRS #f) + (XDG_CONFIG_DIRS #f) + (XDG_CACHE_HOME #f) + (XDG_RUNTIME_DIR #f)) + (test-group "Defaults" + (test-equal "XDG_DATA_HOME" "/home/user/.local/share" + (xdg-data-home)) + (test-equal "XDG_CONFIG_HOME" "/home/user/.config" + (xdg-config-home)) + (test-equal "XDG_STATE_HOME" "/home/user/.local/state" + (xdg-state-home)) + (test-equal "XDG_DATA_DIRS" (xdg-data-dirs) + '("/usr/local/share" "/usr/share")) + (test-equal "XDG_CONFIG_DIRS" '("/etc/xdg") + (xdg-config-dirs)) + (test-equal "XDG_CACHE_HOME" "/home/user/.cache" + (xdg-cache-home)) + (let ((warning + (with-error-to-string + (lambda () + (test-equal "XDG_RUNTIME_DIR" + "/tmp" (xdg-runtime-dir)))))) + (test-assert "The warning actually contains something" + (< 0 (string-length warning))))) + + (test-group "Custom values" + (let-env ((XDG_DATA_HOME "/a")) + (test-equal "XDG_DATA_HOME" "/a" (xdg-data-home))) + (let-env ((XDG_CONFIG_HOME "/b")) + (test-equal "XDG_CONFIG_HOME" "/b" (xdg-config-home))) + (let-env ((XDG_STATE_HOME "/c")) + (test-equal "XDG_STATE_HOME" "/c" (xdg-state-home))) + (let-env ((XDG_DATA_DIRS "/d:/e")) + (test-equal "XDG_DATA_DIRS" '("/d" "/e") (xdg-data-dirs))) + (let-env ((XDG_CONFIG_DIRS "/f:/g")) + (test-equal "XDG_CONFIG_DIRS" '("/f" "/g") (xdg-config-dirs))) + (let-env ((XDG_CACHE_HOME "/h")) + (test-equal "XDG_CACHE_HOME" "/h" (xdg-cache-home))) + (let ((warning + (with-error-to-string + (lambda () + (let-env ((XDG_RUNTIME_DIR "/i")) + (test-equal "XDG_RUNTIME_DIR" "/i" (xdg-runtime-dir))))))) + (test-assert "No error was emitted" + (string-null? warning))))) + diff --git a/tests/validate-html/run-validator.scm b/tests/validate-html/run-validator.scm index 0c4ee0bc..b363e3ea 100755 --- a/tests/validate-html/run-validator.scm +++ b/tests/validate-html/run-validator.scm @@ -1,12 +1,16 @@ #!/usr/bin/bash # -*- mode: scheme; geiser-scheme-implementation: guile -*- -here=$(dirname $(realpath $0)) +root=$(dirname "$(dirname "$(dirname "$(realpath "$0")")")") -. "$(dirname "$(dirname "$here")")/env" +eval "$(env __PRINT_ENVIRONMENT=1 ${root}/calp)" exec $GUILE -e main -s "$0" -- "$@" !# +(unless (getenv "CALP_TEST_ENVIRONMENT") + (format (current-error-port) "Not running in test environment, abandoning~%") + (exit 1)) + (use-modules (sxml simple) ((sxml xpath) :select (sxpath)) (sxml match) |