diff options
Diffstat (limited to 'tests/test')
43 files changed, 0 insertions, 6344 deletions
diff --git a/tests/test/annoying-events.scm b/tests/test/annoying-events.scm deleted file mode 100644 index a6f5e946..00000000 --- a/tests/test/annoying-events.scm +++ /dev/null @@ -1,67 +0,0 @@ -(define-module (test annoying-events) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((srfi srfi-41 util) - :select (filter-sorted-stream)) - :use-module ((srfi srfi-41) - :select (stream - stream->list - stream-filter - stream-take-while)) - :use-module ((vcomponent base) - :select (extract prop)) - :use-module ((vcomponent datetime) :select (event-overlaps?)) - :use-module ((datetime) :select (date date+ date<)) - :use-module ((hnh util) :select (set!)) - :use-module (vcomponent create) - :use-module (vcomponent base)) - - -(define start #2021-11-01) - -(define end (date+ start (date day: 8))) - -(define ev-set - (stream - (vevent ; should be part of the result - summary: "A" - dtstart: #2021-10-01 - dtend: #2021-12-01) - (vevent ; should NOT be part of the result - summary: "B" - dtstart: #2021-10-10 - dtend: #2021-10-11) - (vevent ; should also be part of the result - summary: "C" - dtstart: #2021-11-02 - dtend: #2021-11-03))) - -;; (if (and (date< (prop ev 'DTSTART) start-date) -;; (date<= (prop ev 'DTEND) end-date)) -;; ;; event will be picked, but next event might have -;; (and (date< start-date (prop ev 'DTSTART)) -;; (date< end-date (prop ev 'DTEND))) -;; ;; meaning that it wont be added, stopping filter-sorted-stream -;; ) - -;; The naïve way to get all events in an interval. Misses C due to B being "in the way" - -(test-equal "incorrect handling of non-contigious" - '("A" #; "C") - (map (extract 'SUMMARY) - (stream->list - (filter-sorted-stream - (lambda (ev) (event-overlaps? ev start (date+ start (date day: 8)))) - ev-set)))) - -(test-equal "correct handling of non-contigious" - '("A" "C") - (map (extract 'SUMMARY) - (stream->list - (stream-filter - (lambda (ev) (event-overlaps? ev start end)) - (stream-take-while - (lambda (ev) (date< (prop ev 'DTSTART) end)) - ev-set))))) - - diff --git a/tests/test/base64.scm b/tests/test/base64.scm deleted file mode 100644 index b24d2e8b..00000000 --- a/tests/test/base64.scm +++ /dev/null @@ -1,43 +0,0 @@ -;;; Commentary: -;; Test that Base64 encoding and decoding works -;; Examples from RFC4648 -;;; Code: - -(define-module (test base64) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module (base64)) - -(test-group "Tests from RFC 4648" - (test-group "Decoding tests" - (test-equal "" (base64encode "")) - (test-equal "Zg==" (base64encode "f")) - (test-equal "Zm8=" (base64encode "fo")) - (test-equal "Zm9v" (base64encode "foo")) - (test-equal "Zm9vYg==" (base64encode "foob")) - (test-equal "Zm9vYmE=" (base64encode "fooba")) - (test-equal "Zm9vYmFy" (base64encode "foobar"))) - (test-group "Encoding tests" - (test-equal "" (base64decode "")) - (test-equal "f" (base64decode "Zg==")) - (test-equal "fo" (base64decode "Zm8=")) - (test-equal "foo" (base64decode "Zm9v")) - (test-equal "foob" (base64decode "Zm9vYg==")) - (test-equal "fooba" (base64decode "Zm9vYmE=")) - (test-equal "foobar" (base64decode "Zm9vYmFy")))) - - -;; Other tests - -(test-error "Invalid base64" - 'decoding-error - (base64decode "@@@@")) - -(test-error "To short base64" - 'decoding-error - (base64decode "=")) - -(test-equal "AAECAw==" (bytevector->base64-string #vu8(0 1 2 3))) - -(test-equal #vu8(0 1 2 3) (base64-string->bytevector "AAECAw==")) diff --git a/tests/test/cpp.scm b/tests/test/cpp.scm deleted file mode 100644 index 9c720fde..00000000 --- a/tests/test/cpp.scm +++ /dev/null @@ -1,39 +0,0 @@ -;;; Commentary: -;; Tests my parser for a subset of the C programming language. -;;; Code: - -(define-module (test cpp) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((c lex) :select (lex)) - :use-module ((c parse) :select (parse-lexeme-tree))) - -(define run (compose parse-lexeme-tree lex)) - -(test-equal - '(+ (post-increment (dereference C)) 3) - (run "(*C)++ + 3")) - -(test-equal - '(+ (post-increment (dereference C)) 3) - (run "*C++ + 3")) - -(test-equal - '(post-increment (dereference C)) - (run "*C++")) - -(test-equal - '(+ (post-increment C) (post-increment C)) - (run "C++ + C++")) - -(test-equal - '(+ (pre-increment C) (pre-increment C)) - (run "++C + ++C")) - -(test-equal '(+ 2 (* 2 2)) (run "2 + 2 * 2")) - -(test-equal '(+ (* 2 2) 2) (run "2 * 2 + 2")) - -(test-equal '(+ 2 2 2) (run "2+2+2")) - - diff --git a/tests/test/create.scm b/tests/test/create.scm deleted file mode 100644 index 7cc00419..00000000 --- a/tests/test/create.scm +++ /dev/null @@ -1,66 +0,0 @@ -(define-module (test create) - :use-module ((srfi srfi-1) :select (every)) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((vcomponent create) - :select (vcomponent - with-parameters - as-list)) - :use-module ((vcomponent) - :select (children properties type prop prop* param vline?))) - -;; vevent, vcalendar, vtimezone, standard, and daylight all trivial -;; and therefore not tested - -(test-group "Empty component" - (let ((ev (vcomponent 'TEST))) - (test-equal 'TEST (type ev)) - (test-equal '() (children ev)) - (test-equal '() (properties ev)))) - -(test-group "Component with properties, but no children" - (let ((ev (vcomponent 'TEST - prop: "value"))) - (test-equal '(PROP) (map car (properties ev))) - (test-equal "value" (prop ev 'PROP)))) - -(test-group "Component with children, but no properties" - (let* ((child (vcomponent 'CHILD)) - (ev (vcomponent 'TEST - (list child)))) - (test-equal '() (properties ev)) - (test-equal 1 (length (children ev))) - ; (test-eq child (car (children ev))) - )) - -(test-group "Component with both children and properties" - (let* ((child (vcomponent 'CHILD)) - (ev (vcomponent 'TEST - prop: "VALUE" - (list child)))) - (test-equal '(PROP) (map car (properties ev))) - (test-equal "VALUE" (prop ev 'PROP)) - (test-equal 1 (length (children ev))) - ; (test-eq child (car (children ev))) - )) - -(test-group "Component with no children, where last elements value is a list" - (let ((ev (vcomponent 'TEST prop: (list 1 2 3)))) - (test-equal '() (children ev)) - (test-equal '(PROP) (map car (properties ev))) - (test-equal '(1 2 3) (prop ev 'PROP)))) - -(test-group "With parameters" - (let ((ev (vcomponent 'TEST - prop: (with-parameters param: 1 2)))) - (test-equal 2 (prop ev 'PROP)) - (test-equal '(1) (param (prop* ev 'PROP) 'PARAM)))) - -(test-group "As list" - (let ((ev (vcomponent 'TEST - prop: (as-list (list 1 2 3))))) - (test-equal '(1 2 3) (prop ev 'PROP)) - (test-equal 3 (length (prop* ev 'PROP))) - (test-assert (every vline? (prop* ev 'PROP))))) - -;; (test-group "Parameters and lists" ) diff --git a/tests/test/crypto.scm b/tests/test/crypto.scm deleted file mode 100644 index 0dbf8867..00000000 --- a/tests/test/crypto.scm +++ /dev/null @@ -1,22 +0,0 @@ -(define-module (test crypto) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module ((crypto) :select (sha256 checksum->string))) - -(test-equal "sha256" - #vu8(24 95 141 179 34 113 254 37 245 97 166 252 147 139 46 38 67 6 236 48 78 218 81 128 7 209 118 72 38 56 25 105) - (sha256 "Hello")) - -(test-equal "sha256 string digest" - "185f8db32271fe25f561a6fc938b2e264306ec304eda518007d1764826381969" - (checksum->string (sha256 "Hello"))) - -(let ((port (open-output-string))) - (checksum->string (sha256 "Hello") port) - (test-equal "sha256 string digest to port" - "185f8db32271fe25f561a6fc938b2e264306ec304eda518007d1764826381969" - (get-output-string port))) - -(test-error 'wrong-type-arg - (sha256 'something-which-is-not-a-string-or-bytevector)) diff --git a/tests/test/data-stores/file.scm b/tests/test/data-stores/file.scm deleted file mode 100644 index e69de29b..00000000 --- a/tests/test/data-stores/file.scm +++ /dev/null diff --git a/tests/test/data-stores/sqlite.scm b/tests/test/data-stores/sqlite.scm deleted file mode 100644 index e69de29b..00000000 --- a/tests/test/data-stores/sqlite.scm +++ /dev/null diff --git a/tests/test/data-stores/vdir.scm b/tests/test/data-stores/vdir.scm deleted file mode 100644 index e69de29b..00000000 --- a/tests/test/data-stores/vdir.scm +++ /dev/null diff --git a/tests/test/datetime.scm b/tests/test/datetime.scm deleted file mode 100644 index f73a0ad2..00000000 --- a/tests/test/datetime.scm +++ /dev/null @@ -1,810 +0,0 @@ -(define-module (test datetime) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-71) - :use-module (srfi srfi-88) - :use-module ((srfi srfi-41) - :select (stream->list stream-take)) - :use-module (datetime) - :use-module ((ice-9 format) :select (format)) - :use-module ((ice-9 i18n) :select (make-locale)) - :use-module ((guile) :select (LC_CTYPE LC_TIME))) - -;;; Skipped since the code generating the (expected) error is disabled, due to -;;; optional fields at the end of string. See the (null? str) case is -;;; datetime->string -(test-expect-fail "Premature end of string to parse") - -;;; Global locale objects, to save all tests from creating them -(define en_US (make-locale (list LC_CTYPE LC_TIME) "en_US.UTF-8")) -(define sv_SE (make-locale (list LC_CTYPE LC_TIME) "sv_SE.UTF-8")) - -;;; These tests begin by testing the basic objects, -;;; followed by the string parser. -;;; This to finally test the read syntax, to be able to -;;; us it in the rest of the tests. - -(test-group "Creation of basic objects" - (test-group "Date" - (test-group "Empty date" - (let ((d (date))) - (test-assert "Date creates date objects" (date? d)) - (test-equal "Year is zero" 0 (year d)) - (test-equal "Month is zero" 0 (month d)) - (test-equal "Day is zero" 0 (day d)) - (test-assert "Date-zero? agrees" (date-zero? d)))) - - (test-group "Date with keys" - ;; Implicitly tests that month and day can go above - ;; "regular" bounds - (let ((d (date day: 40 month: 20 year: 10))) - (test-assert "Date creation still works" (date? d)) - (test-equal "Year is stored" 10 (year d)) - (test-equal "Month is stored" 20 (month d)) - (test-equal "Day is stored" 40 (day d)))) - - (test-group "Can't create date with non-integer components" - (test-error "Invalid year" 'wrong-type-arg (date year: #f)) - (test-error "Invalid month" 'wrong-type-arg (date month: #f)) - (test-error "Invalid day" 'wrong-type-arg (date day: #f)))) - - (test-group "Time" - (test-group "Empty time" - (let ((t (time))) - (test-assert "Time creates time objects" (time? t)) - (test-equal "hour is zero" 0 (hour t)) - (test-equal "minute is zero" 0 (minute t)) - (test-equal "second is zero" 0 (second t)) - (test-assert "Time zero agrees" (time-zero? t)))) - - (test-group "Time with keys" - (let ((t (time second: 10 minute: 20 hour: 30))) - (test-assert "Time creation still works" (time? t)) - (test-equal "Hour is stored" 30 (hour t)) - (test-equal "Minute is stored" 20 (minute t)) - (test-equal "Second is stored" 10 (second t)))) - - (test-group "Can't create time with non-integer components" - (test-error "Invalid hour" 'wrong-type-arg (time hour: #f)) - (test-error "Invalid minute" 'wrong-type-arg (time minute: #f)) - (test-error "Invalid second" 'wrong-type-arg (time second: #f)))) - - (test-group "Datetime" - (let () - (test-group "Empty datetime" - (let ((dt (datetime))) - (test-assert "Datetime date is date" (date? (datetime-date dt))) - (test-assert "Datetime date is zero" (date-zero? (datetime-date dt))) - (test-assert "Datetime time is time" (time? (datetime-time dt))) - (test-assert "Datetime time is zero" (time-zero? (datetime-time dt))) - (test-eqv "Defalut timezone is #f" #f (tz dt)))) - - (test-group "Datetime with keys" - (let ((dt (datetime date: (date day: 10) - time: (time minute: 20)))) - (test-equal "Given date is stored" - 10 (day (datetime-date dt))) - (test-equal "Given time is stored" - 20 (minute (datetime-time dt)))) - (test-error "Date must be a date" 'wrong-type-arg (datetime date: 1)) - (test-error "Date must be a date" 'wrong-type-arg (datetime date: (time))) - (test-assert "Date: #f gives still constructs a date" (date? (datetime-date (datetime date: #f)))) - (test-error "Time must be a time" 'wrong-type-arg (datetime time: 1)) - (test-error "Time must be a time" 'wrong-type-arg (datetime time: (date))) - (test-assert "Time: #f gives still constructs a time" (time? (datetime-time (datetime time: #f)))) - - (let ((dt (datetime hour: 20 day: 30))) - (test-equal "Time objects can be implicitly created" 20 (hour (datetime-time dt))) - (test-equal "Date objects can be implicitly created" 30 (day (datetime-date dt)))) - (let ((dt (datetime day: 30 time: (time hour: 20)))) - (test-equal "\"Upper\" and \"lower\" keys can be mixed" - 20 (hour (datetime-time dt))) - (test-equal "\"Upper\" and \"lower\" keys can be mixed" - 30 (day (datetime-date dt)))) - - (let ((dt (datetime hour: 30 time: (time hour: 20)))) - (test-equal "time: has priority over hour: (and the like)" - 20 (hour (datetime-time dt))))) - (let ((dt (datetime day: 30 date: (date day: 20)))) - (test-equal "date: has priority over day: (and the like)" - 20 (day (datetime-date dt))))))) - -;; Before the general parser, since it's a dependency string->datetime. -(test-group "Parse Month" - - (test-equal "Parse full month name" jan (parse-month "January" en_US)) - (test-equal "Parse full weird case" jan (parse-month "jaNuaRy" en_US)) - (test-equal "Parse partial month name" jan (parse-month "Jan" en_US)) - (test-equal "Failing parse of month name" -1 (parse-month "Unknown" en_US)) - (test-equal "Overlap gives earliest month" mar (parse-month "m" en_US)) - - (test-equal "Parse month with different locale" may (parse-month "maj" sv_SE))) - - -(test-group "Parser" - (test-group "Simple individual rules" - (test-group "Year" - (test-equal "~Y year" (datetime year: 2020) (string->datetime "2020" "~Y")) - (test-equal "~Y year single digit" (datetime year: 2) (string->datetime "2" "~Y")) - (test-equal "~Y year leading zero" (datetime year: 2) (string->datetime "02" "~Y")) - (test-error "~Y parses at max four digits" 'misc-error (string->datetime "14411" "~Y"))) - - (test-group "Month" - (test-equal "~m month" (datetime month: 10) (string->datetime "10" "~m")) - (test-equal "~m month single digit" (datetime month: 1) (string->datetime "1" "~m")) - (test-equal "~m month leading zero" (datetime month: 1) (string->datetime "01" "~m")) - (test-error "~m parses at max two digits" 'misc-error (string->datetime "111" "~m"))) - - ;; Extra tests are skipped for these, since they are shared with Month - (test-equal "~d day" (datetime day: 20) (string->datetime "20" "~d")) - (test-equal "~H hour" (datetime hour: 15) (string->datetime "15" "~H")) - (test-equal "~M minute" (datetime minute: 30) (string->datetime "30" "~M")) - (test-equal "~S second" (datetime second: 59) (string->datetime "59" "~S"))) - - - (test-equal "Literal character" (datetime) (string->datetime "T" "T")) - (test-equal "~~ '~'" (datetime) (string->datetime "~" "~~")) - (test-error "Mismatched literal ~" 'misc-error (string->datetime "A" "~~")) - - (test-error "Stray ~ at end of fmt" 'misc-error (string->datetime "~" "~")) - (test-error "Stray ~ in middle of fmt" 'misc-error (string->datetime "~ 1" "~ ~d")) - (test-error "Unknown escape" 'misc-error (string->datetime "10" "~x")) - (test-error "Premature end of string to parse" 'misc-error (string->datetime "" "~Y")) - (test-error "Wrong Literal character" 'misc-error (string->datetime "T" "Z")) - - - ;; Does the parser continue correctly - (test-group "Tokens following each other" - (test-equal "Year indirectly followed by month" - (datetime year: 2020 month: 1) - (string->datetime "2020-01" "~Y-~m")) - ;; Does the parser handle tokens without delimiters, instead going by their max size - (test-equal "Year directly follewed by month" - (datetime year: 2020 month: 1) - (string->datetime "202001" "~Y~m"))) - - - (test-group "Timezone" - (test-equal "~Z 'Z'" - (datetime tz: "UTC") (string->datetime "Z" "~Z")) - (test-equal "~Z Is optional" - (datetime) (string->datetime "" "~Z")) - (test-equal "~Z Is optional with stuff after" - (datetime hour: 20) (string->datetime "20" "~Z~H")) - ;; This was earlier a bug - (test-equal "Zoneinfo is kept while not at end" - (datetime year: 2020 tz: "UTC") - (string->datetime "Z2020" "~Z~Y"))) - - - (test-group "Month by name" - ;; ~b, ~B, and ~h all does the same thing, and exists for symmetry with - ;; datetime->string (where they don't do the exact same thing). Each is used - ;; at least once below to ensure that they all work. - (test-equal "Standalone month, and at end" - (datetime month: 1) - (string->datetime "Jan" "~b" en_US)) - - ;; Separate test from above, since month does the check itself - (test-error "Stray ~ after month" - 'misc-error (string->datetime "Jan" "~b~" en_US)) - - (test-equal "Month with explicit ~ after" - (datetime month: mar) - (string->datetime "M~" "~B~~" en_US)) - - (test-error "Month with other specifier directly after" - 'misc-error (string->datetime "January" "~b~b")) - - (test-equal "Month with other explict char after" - (datetime month: mar) - (string->datetime "Mar|" "~h|" en_US)) - - (test-equal "Locale information is used" - (datetime month: may) - (string->datetime "Maj" "~h" sv_SE))) - - ;; TODO AM/PM string ~p - - (test-group "Complete parses" - (test-equal "Parse complete ISO date" - (datetime year: 2020 month: 3 day: 10) - (string->datetime "2020-03-10" "~Y-~m-~d")) - - (test-equal "Parse complete ISO time" - (datetime hour: 10 minute: 20 second: 30) - (string->datetime "10:20:30" "~H:~M:~S")) - - (test-equal "Parse complete ISO date-time" - (datetime year: 2020 month: 3 day: 10 - hour: 10 minute: 20 second: 30) - (string->datetime "2020-03-10T10:20:30" - "~Y-~m-~dT~H:~M:~S"))) - - (test-group "string->datetime default format-specifier" - (test-equal "Default date-time format-specifier takes ISO date-times" - (datetime year: 2020 month: 3 day: 10 - hour: 10 minute: 20 second: 30) - (string->datetime "2020-03-10T10:20:30")) - - (test-equal "Default date-time format-specifier takes ISO date-times (with zone)" - (datetime year: 2020 month: 3 day: 10 - hour: 10 minute: 20 second: 30 - tz: "UTC") - (string->datetime "2020-03-10T10:20:30Z"))) - - - (test-group "string->time" - (test-assert "String->time returns time objects" - (time? (string->time "10" "~H"))) - - (test-equal "String->time complete parse" - (time hour: 10 minute: 20 second: 30) - (string->time "10:20:30" "~H:~M:~S")) - - (test-equal "String->time complete parse, default format-specifier" - (time hour: 10 minute: 20 second: 30) - (string->time "10:20:30"))) - - (test-group "string->date" - (test-assert "String->date returns time objects" - (date? (string->date "10" "~Y"))) - - (test-equal "String->date complete parse" - (date year: 2020 month: 3 day: 10) - (string->date "2020-03-10" "~Y-~m-~d")) - - (test-equal "String->date complete parse, default format-specifier" - (date year: 2020 month: 3 day: 10) - (string->date "2020-03-10"))) - - (test-group "Pre-specified parsers" - (test-group "ICS (RFC 5545)" - (test-equal "date" - (date year: 2020 month: 10 day: 20) - (parse-ics-date "20201020")) - (test-equal "time" - (time hour: 10 minute: 20 second: 30) - (parse-ics-time "102030")) - (test-equal "datetime" - (datetime year: 2020 month: 10 day: 20 - hour: 10 minute: 20 second: 30) - (parse-ics-datetime "20201020T102030")) - (test-equal "datetime (with zone)" - (datetime year: 2020 month: 10 day: 20 - hour: 10 minute: 20 second: 30 - tz: "UTC") - (parse-ics-datetime "20201020T102030Z"))) - - (test-group "ISO" - (test-equal "date" - (date year: 2020 month: 10 day: 20) - (parse-iso-date "2020-10-20")) - (test-equal "time" - (time hour: 10 minute: 20 second: 30) - (parse-iso-time "10:20:30")) - (test-equal "datetime" - (datetime year: 2020 month: 10 day: 20 - hour: 10 minute: 20 second: 30) - (parse-iso-datetime "2020-10-20T10:20:30"))) - - ;; Parse freeform date - ) - - (test-group "string->date/-time" - (test-equal "Date like gives date" - (date year: 2020 month: 10 day: 20) - (string->date/-time "2020-10-20")) - (test-equal "Time like gives time" - (time hour: 10 minute: 20 second: 30) - (string->date/-time "10:20:30")) - (test-equal "Datetime like gives datetime" - (datetime year: 2020 month: 10 day: 20 - hour: 10 minute: 20 second: 30) - (string->date/-time "2020-10-20T10:20:30")) - - ;; These are disabled since trailing fmt is allowed - ;; (test-error "Bad date-like crashes" - ;; 'misc-error (string->date/-time "2020-10")) - ;; (test-error "Bad time-like crashes" - ;; 'misc-error (string->date/-time "20:10")) - (test-error "Really bad crashes" - 'misc-error (string->date/-time "Hello")) - )) - - -(test-group "Reader extensions" - - ;; All tests have a list variant, to ensure that it plays nice with the rest - ;; of scheme's syntax - - (test-equal "Basic time read syntax" - (time hour: 10 minute: 20 second: 30) - (test-read-eval-string "#10:20:30")) - - (test-equal "Basic time read syntax in list" - (list (time hour: 10 minute: 20 second: 30)) - (test-read-eval-string "(list #10:20:30)")) - - (test-equal "Basic date read syntax" - (date year: 2020 month: 3 day: 10) - (test-read-eval-string "#2020-03-10")) - - (test-equal "Basic date read syntax in list" - (list (date year: 2020 month: 3 day: 10)) - (test-read-eval-string "(list #2020-03-10)")) - - (test-equal "Basic datetime read syntax" - (datetime date: (date year: 2020 month: 3 day: 10) - time: (time hour: 10 minute: 20 second: 30)) - (test-read-eval-string "#2020-03-10T10:20:30")) - - (test-equal "Basic datetime read syntax in list" - (list (datetime date: (date year: 2020 month: 3 day: 10) - time: (time hour: 10 minute: 20 second: 30))) - (test-read-eval-string "(list #2020-03-10T10:20:30)")) - - (test-equal "Basic datetime read syntax with Z" - (datetime date: (date year: 2020 month: 3 day: 10) - time: (time hour: 10 minute: 20 second: 30) - tz: "UTC") - (test-read-eval-string "#2020-03-10T10:20:30Z")) - - (test-equal "Basic datetime read syntax with Z in list" - (list - (datetime date: (date year: 2020 month: 3 day: 10) - time: (time hour: 10 minute: 20 second: 30) - tz: "UTC")) - (test-read-eval-string "(list #2020-03-10T10:20:30Z)")) - ) - - - - -(test-equal "Datetime->unix-time" - 1656005146 (datetime->unix-time #2022-06-23T17:25:46Z)) - -(test-equal "Datetime->unix-time before epoch" - -62167219200 - (datetime->unix-time #0000-01-01T00:00:00Z)) - -(test-equal "unix-time->datetime" #2020-09-13T12:26:40Z - (unix-time->datetime 1600000000)) -(test-equal "unix-time->datetime on epoch" #1970-01-01T00:00:00Z - (unix-time->datetime 0)) -(test-equal "unix-time->datetime before epoch" #1919-04-20T11:33:20Z - (unix-time->datetime -1600000000)) - -;; (unix-time->datetime (expt 2 31)) ; => #2038-01-19T03:14:08Z -;; (unix-time->datetime (1+ (expt 2 31))) ; => #2038-01-19T03:14:09Z -;; (unix-time->datetime (- (expt 2 31))) ; => #1901-12-13T20:45:52Z - - -(test-assert "Current datetime returns a datetime" - (datetime? (current-datetime))) -(test-equal "Current datetime returns with tz: UTC" - "UTC" (tz (current-datetime))) -(test-assert "Current-date returns a date" - (date? (current-date))) - - -;; TODO write these, also, check connection to get-time% -get-datetime -as-date -as-time -as-datetime - -(test-group "Leap years" - (test-assert "Most years are't leap years" (not (leap-year? 1999))) - (test-assert "Except if it's divisible by 4" (leap-year? 2020)) - (test-assert "But not by 100" (not (leap-year? 1900))) - (test-assert "Except if also divisible by 400" (leap-year? 2000))) - -(test-assert "31 days in most month" (days-in-month (date month: jan))) -(test-assert "30 days in some month" (days-in-month (date month: apr))) -(test-assert "28 days in februrary on regular year" - (days-in-month (date month: feb year: 2022))) -(test-assert "29 days in februrary on leap year" - (days-in-month (date month: feb year: 2000))) -(test-error "To low month" 'out-of-range (days-in-month (date month: 0))) -(test-error "To high month" 'out-of-range (days-in-month (date month: 13))) - -(test-equal "365 days in regular year" 365 (days-in-year (date year: 2022))) -(test-equal "366 days in leap year" 366 (days-in-year (date year: 2000))) - -(test-equal "Start of month" #2020-01-01 (start-of-month #2020-01-15)) -(test-equal "End of month" #2000-02-29 (end-of-month #2000-02-01)) - -(test-equal "Start of year" #2020-01-01 (start-of-year #2020-12-31)) -;; Note that end-of-year (apparently) doesn't exist - -(test-group "Date streams" - (test-equal "Day stream" - (list #2020-01-01 #2020-01-02 #2020-01-03 #2020-01-04 #2020-01-05) - (stream->list 5 (day-stream #2020-01-01))) - (test-equal "Week stream" - (list #2020-01-01 #2020-02-01 #2020-03-01 #2020-04-01 #2020-05-01) - (stream->list 5 (month-stream #2020-01-01))) - (test-equal "Month stream" - (list #2020-01-01 #2020-01-08 #2020-01-15 #2020-01-22 #2020-01-29) - (stream->list 5 (week-stream #2020-01-01)))) - -;; See time< tests for more context -(test-group "Min/max" - (test-equal "Time min" - #07:40:50 (time-min #10:20:30 #07:40:50)) - (test-equal "Time max" - #10:20:30 (time-max #10:20:30 #07:40:50)) - - (test-equal "Date min" - #2020-02-02 (date-min #2020-02-02 #2020-03-01)) - (test-equal "Date max" - #2020-03-01 (date-max #2020-02-02 #2020-03-01)) - - (test-equal "Datetime min" - #2020-02-02T10:20:30 (datetime-min #2020-02-02T10:20:30 #2020-03-01T07:40:50)) - (test-equal "Datetime max" - #2020-03-01T07:40:50 (datetime-max #2020-02-02T10:20:30 #2020-03-01T07:40:50))) - -(test-equal "Week day" thu (week-day #2022-06-23)) - -(test-equal "week-1-start" #2019-12-30 (week-1-start #2020-01-01 mon)) - -;; Possibly add case where the end of the year uses next years week numbers -(test-equal "Week number at end of year" 53 (week-number #2008-12-31 sun)) -(test-equal "Week number at start of year" 53 (week-number #2009-01-01 sun)) - -(test-equal #2008-12-28 (date-starting-week 53 (date year: 2008) sun)) -(test-equal #2007-12-30 (date-starting-week 1 (date year: 2008) sun)) - -(test-group "Week day name" - (test-equal "Simple" "Saturday" (week-day-name sat locale: en_US)) - (test-equal "Truncated" "Sa" (week-day-name sat 2 locale: en_US)) - (test-equal "Other locale" "lördag" (week-day-name sat locale: sv_SE)) - (test-equal "Other locale, truncated" "lö" (week-day-name sat 2 locale: sv_SE))) - -;; TODO timespans can be both date, times, and datetimes -;; Check those cases? -(test-group "Overlapping timespans" - ;; A B C D E ¬F - ;; |s1| : |s2| : |s1| : |s2| : : |s1| - ;; | | : | | : | ||s2| : |s1|| | : |s1||s2| : | | - ;; | ||s2| : |s1|| | : | || | : | || | : | || | : - ;; | | : | | : | || | : | || | : | || | : |s2| - ;; | | : | | : | | : | | : : | | - (test-assert "End of S1 overlaps start of S2" - (timespan-overlaps? #10:00:00 #12:00:00 - #11:00:00 #13:00:00)) - (test-assert "Start of S1 overlaps end of S2" - (timespan-overlaps? #11:00:00 #13:00:00 - #10:00:00 #12:00:00)) - (test-assert "S1 complete encompasses S2" - (timespan-overlaps? #10:00:00 #13:00:00 - #11:00:00 #12:00:00)) - (test-assert "S2 complete encompasses S1" - (timespan-overlaps? #11:00:00 #12:00:00 - #10:00:00 #13:00:00)) - (test-assert "S1 is equal to S2" - (timespan-overlaps? #11:00:00 #12:00:00 - #11:00:00 #12:00:00)) - (test-assert "S1 dosesn't overlap S2" - (not - (timespan-overlaps? #10:00:00 #11:00:00 - #12:00:00 #13:00:00))) - (test-assert "If the events only share an instant they don't overlap" - (not - (timespan-overlaps? #10:00:00 #12:00:00 - #12:00:00 #14:00:00)))) - -(test-equal #2022-06-25 (find-first-week-day sat #2022-06-23)) - -(test-group "All weekdays in <>" - (test-equal "month, if starting from beginning of month" - (list #2022-06-03 #2022-06-10 #2022-06-17 #2022-06-24) - (all-wday-in-month fri #2022-06-01)) - - (test-equal "month, if starting from the middle" - (list #2022-06-24) - (all-wday-in-month fri #2022-06-23)) - - (test-equal "year, if starting from the beggining" - (list #2022-01-07 #2022-01-14 #2022-01-21 #2022-01-28 #2022-02-04 #2022-02-11 #2022-02-18 #2022-02-25 #2022-03-04 #2022-03-11 #2022-03-18 #2022-03-25 #2022-04-01 #2022-04-08 #2022-04-15 #2022-04-22 #2022-04-29 #2022-05-06 #2022-05-13 #2022-05-20 #2022-05-27 #2022-06-03 #2022-06-10 #2022-06-17 #2022-06-24 #2022-07-01 #2022-07-08 #2022-07-15 #2022-07-22 #2022-07-29 #2022-08-05 #2022-08-12 #2022-08-19 #2022-08-26 #2022-09-02 #2022-09-09 #2022-09-16 #2022-09-23 #2022-09-30 #2022-10-07 #2022-10-14 #2022-10-21 #2022-10-28 #2022-11-04 #2022-11-11 #2022-11-18 #2022-11-25 #2022-12-02 #2022-12-09 #2022-12-16 #2022-12-23 #2022-12-30) - (all-wday-in-year fri #2022-01-01)) - - (test-equal "year, if starting from the middle" - (list #2022-06-03 #2022-06-10 #2022-06-17 #2022-06-24 #2022-07-01 #2022-07-08 #2022-07-15 #2022-07-22 #2022-07-29 #2022-08-05 #2022-08-12 #2022-08-19 #2022-08-26 #2022-09-02 #2022-09-09 #2022-09-16 #2022-09-23 #2022-09-30 #2022-10-07 #2022-10-14 #2022-10-21 #2022-10-28 #2022-11-04 #2022-11-11 #2022-11-18 #2022-11-25 #2022-12-02 #2022-12-09 #2022-12-16 #2022-12-23 #2022-12-30) - (all-wday-in-year fri #2022-06-01))) - -;; TODO -in-date-range? - -(test-equal "weekday-list" (list wed thu fri sat sun mon tue) (weekday-list wed)) -(test-equal "start of week" #2022-06-20 (start-of-week #2022-06-23 mon)) -(test-equal "end of week" #2022-06-26 (end-of-week #2022-06-23 mon)) - - -(test-group "month-days" - (call-with-values (lambda () (month-days #2022-06-01 mon)) - (lambda (before actual after) - (test-equal "before" (list #2022-05-30 #2022-05-31) before) - (test-equal "actual" (stream->list 30 (day-stream #2022-06-01)) actual) - (test-equal "after" (list #2022-07-01 #2022-07-02 #2022-07-03) after)))) - -(test-group "Days in interval" - (test-equal "Steps from start to end of month" 31 (days-in-interval #2022-01-01 #2022-01-31)) - (test-error "Negative intervals should fail" 'misc-error (days-in-interval #2022-01-01 #2020-01-31))) - -(test-equal "Year day" 191 (year-day #2020-07-09)) - -(test-group "Convertions to decimal time" - (test-group "Time->decimal-hour" - (test-equal "Exact number of hours is whole number" 5.0 (time->decimal-hour (time hour: 5))) - (test-equal "Minutes are \"base\" 60" 5.5 (time->decimal-hour (time hour: 5 minute: 30))) - (test-equal "60 Minutes gives a whole hour" 6.0 (time->decimal-hour (time hour: 5 minute: 60))) - (test-equal "A second is the right length" (/ 1.0 3600) (time->decimal-hour (time second: 1)))) - - (test-group "Datetime->decimal-hour" - (test-equal "Datetimes without dates work as times" - 5.5 (datetime->decimal-hour (datetime hour: 5 minute: 30))) - (test-equal "Full day" 24.0 (datetime->decimal-hour (datetime day: 1))) - (test-error "Can't get length of month without information about which month" - 'misc-error (datetime->decimal-hour (datetime month: 1))) - (test-equal "Can get length of month if we have a month" - (* 31 24.0) (datetime->decimal-hour (datetime month: 1) #2020-01-01)))) - -;; TODO -date-range - -(test-group "To string" - (test-group "Datetime->string" - (test-equal "A letter becomes itself" - "H" (datetime->string (datetime) "H")) - (test-group "Single rules" - (test-equal "~" (datetime->string (datetime) "~~")) - (test-equal "01" (datetime->string (datetime hour: 1) "~H")) - (test-equal " 1" (datetime->string (datetime hour: 1) "~k")) - (test-equal "02" (datetime->string (datetime minute: 2) "~M")) - (test-equal "03" (datetime->string (datetime second: 3) "~S")) - (test-equal "0002" (datetime->string (datetime year: 2) "~Y")) - (test-equal "02" (datetime->string (datetime month: 2) "~m")) - (test-equal "04" (datetime->string (datetime day: 4) "~d")) - (test-equal " 4" (datetime->string (datetime day: 4) "~e")) - (test-equal "1600000000" (datetime->string #2020-09-13T12:26:40Z "~s")) - - (test-equal "2022-10-20" (datetime->string (datetime date: #2022-10-20) "~1")) - (test-equal "10:20:30" (datetime->string (datetime time: #10:20:30) "~3")) - - (test-group "Locale dependant (en_US)" - (test-equal "Saturday" (datetime->string (datetime date: (find-first-week-day sat #2020-01-01)) "~A" en_US)) - (test-equal "Sat" (datetime->string (datetime date: (find-first-week-day sat #2020-01-01)) "~a" en_US)) - (test-equal "January" (datetime->string (datetime date: (date month: 1)) "~B" en_US)) - (test-equal "Jan" (datetime->string (datetime date: (date month: 1)) "~b" en_US))) - - (test-group "Locale dependant (sv_SE)" - (test-equal "lördag" (datetime->string (datetime date: (find-first-week-day sat #2020-01-01)) "~A" sv_SE)) - (test-equal "lör" (datetime->string (datetime date: (find-first-week-day sat #2020-01-01)) "~a" sv_SE)) - (test-equal "januari" (datetime->string (datetime date: (date month: 1)) "~B" sv_SE)) - (test-equal "jan" (datetime->string (datetime date: (date month: 1)) "~b" sv_SE))) - - (test-group "Timezone" - (test-equal "Z" (datetime->string (datetime tz: "UTC") "~Z")) - (test-equal "" (datetime->string (datetime tz: #f) "~Z")) - (test-equal "" (datetime->string (datetime tz: "Anything else") "~Z")))) - - - (test-equal "Default fomat specifier gives ISO-formatted date" - "2006-01-02T15:04:05" (datetime->string #2006-01-02T15:04:05)) - - (test-group "Invalid specifiers" - (test-equal "" (datetime->string (datetime) "~x" allow-unknown?: #t)) - (test-error 'misc-error (datetime->string (datetime) "~x"))) - - (test-group "Print syntax for datatypes" - (test-equal "Date writer" "#2020-01-02" (with-output-to-string (lambda () (write #2020-01-02)))) - (test-equal "Time writer" "#20:30:40" (with-output-to-string (lambda () (write #20:30:40)))) - (test-equal "Datetime writer" "#2020-01-02T20:30:40" (with-output-to-string (lambda () (write #2020-01-02T20:30:40)))) - (test-equal "Datetime writer (with tz)" "#2020-01-02T20:30:40Z" (with-output-to-string (lambda () (write #2020-01-02T20:30:40Z)))))) - - ;; Really basic tests, since these are rather thin wrappers - (test-equal "date->string" "0000-00-00" (date->string (date))) - (test-equal "time->string" "00:00:00" (time->string (time)))) - -(test-group "Equals" - ;; date=?, time=?, and datetime=? are alias to their non-question-mark - ;; alternatives. Using them interchangably below. - (test-group "date" - (test-assert "Zero dates are all equal" - (date=)) - (test-assert "A single date is equal to itself" - (date=? #2020-10-20)) - (test-assert "Two dates are equal to each other" - (date= #2020-10-20 #2020-10-20)) - (test-assert "Two dates which are NOT equal to each other" - (not (date= #2020-10-20 #2020-10-21))) - (test-assert "More than two dates which are all equal" - (date=? #2020-10-20 #2020-10-20 #2020-10-20))) - - (test-group "time" - (test-assert "Zero times are all equal" - (time=)) - (test-assert "A single time is equal to itself" - (time=? #20:30:40)) - (test-assert "Two times are equal to each other" - (time= #20:30:40 #20:30:40)) - (test-assert "Two times which are NOT equal to each other" - (not (time= #20:30:40 #10:30:40))) - (test-assert "More than two times which are all equal" - (time=? #20:30:40 #20:30:40 #20:30:40))) - - (test-group "Datetime" - (test-assert "Zero datetimes \"all\" are equal" - (datetime=)) - (test-assert "A single datetime is equal to itself" - (datetime= (datetime))) - (test-assert "Two equal datetimes are equal" - (datetime= (datetime hour: 1) (datetime hour: 1))) - (test-assert "Two dissimmalar datetimes aren't equal" - (not (datetime= (datetime hour: 1) (datetime hour: 2)))) - - ;; NOTE timezone interactions are non-existant - (test-assert "Two datetimes are equal, regardless of timezone" - (datetime= (datetime) (datetime tz: "Something Else"))) - - (test-assert "Three equal datetimes are equal" - (datetime= (datetime hour: 1) (datetime hour: 1) (datetime hour: 1))))) - -(test-group "Comparisons" - (test-group "Zero arguments" - (test-group "Dates" - (test-assert "zero dates are greater" (date<)) - (test-assert "zero dates are less" (date>))) - (test-group "Times" - (test-assert "zero times are greater" (time<)) - (test-assert "zero times are less" (time>))) - (test-group "Datetimes" - (test-assert "zero datetimes are greater" (datetime<)) - (test-assert "zero datetimes are less" (datetime>)))) - - (test-group "Single argument" - (test-group "Dates" - (test-assert "one date are greater" (date< (date))) - (test-assert "one date are less" (date> (date)))) - (test-group "Times" - (test-assert "one time are greater" (time< (time))) - (test-assert "one time are less" (time> (time)))) - (test-group "Datetimes" - (test-assert "one datetime are greater" (datetime< (datetime))) - (test-assert "one datetime are less" (datetime> (datetime))))) - - - (test-group "Two arguments" - (test-group "Dates" - (test-assert "positive comparison" (date< (date day: 1) (date day: 2))) - (test-assert "negative comparison" (not (date> (date day: 1) (date day: 2))))) - (test-group "Times" - (test-assert "positive comparison" (time< (time hour: 1) (time hour: 2))) - (test-assert "negative comparison" (not (time> (time hour: 1) (time hour: 2))))) - (test-group "Datetimes" - (test-assert "positive comparison" (datetime< (datetime day: 1) (datetime day: 2))) - (test-assert "negative comparison" (not (datetime> (datetime day: 1) (datetime day: 2)))))) - - (test-group "Two arguments" - (test-group "Dates" - (test-assert "positive comparison" - (date< (date day: 1) (date day: 2) (date day: 3))) - (test-assert "negative comparison" - (not (date< (date day: 1) (date day: 2) (date day: 1))))) - (test-group "Times" - (test-assert "positive comparison" - (time< (time hour: 1) (time hour: 2) (time hour: 3))) - (test-assert "negative comparison" - (not (date< (date day: 1) (date day: 2) (date day: 1))))) - (test-group "Datetimes" - (test-assert "positive comparison" - (datetime< (datetime day: 1) (datetime day: 2) (datetime day: 3))) - (test-assert "negative comparison" - (not (datetime< (datetime day: 1) (datetime day: 2) (datetime day: 1))))))) - -;; TODO -date<= -time<= -datetime<= - -;; TODO -date/-time< date/-time<? date/-time<= date/-time<=? -date/-time> date/-time>? date/-time>= date/-time>=? - -(test-group "Arithmetic" - (test-group "Date" - (test-group "Unary application" - (test-equal "Date+ single argument returns itself" (date) (date+ (date))) - (test-equal "Date- single argument returns itself" (date) (date- (date)))) - - (test-group "Simple cases" - (test-group "Days" - (test-equal "Add" #2020-01-06 (date+ #2020-01-01 (date day: 5))) - (test-equal "Remove" #2020-01-01 (date- #2020-01-06 (date day: 5)))) - (test-group "Months" - (test-equal "Add" #2020-06-01 (date+ #2020-01-01 (date month: 5))) - (test-equal "Remove" #2020-01-01 (date- #2020-06-01 (date month: 5)))) - (test-group "Years" - (test-equal "Add" #2022-01-01 (date+ #2020-01-01 (date year: 2))) - (test-equal "Remove" #2020-01-01 (date- #2022-01-01 (date year: 2))))) - - (test-group "Many operands" - (test-equal #2021-02-02 - (date+ #2020-01-01 - (date day: 1) - (date month: 1) - (date year: 1)))) - - (test-group "Overflow" - ;; Years don't overflow, so no need to test - (test-equal "Day overflow" #2022-02-01 (date+ #2022-01-31 (date day: 1))) - (test-equal "Month overflow" #2023-01-01 (date+ #2022-12-01 (date month: 1))) - (test-equal "Date+Month overflow" #2023-01-01 (date+ #2022-12-31 (date day: 1)))) - - ;; NOTE - (test-equal #2020-02-31 (date+ #2020-01-31 (date month: 1))) - ) - - (test-group "Time" - (test-group "Unary application" - (test-equal "Time+ single argument returns itself" (time) (time+ (time))) - (test-equal "Time- single argument returns itself" (time) (time- (time)))) - - (test-group "Simple cases" - (test-group "Seconds" - (test-equal "Add" #20:00:40 (time+ #20:00:00 (time second: 40))) - (test-equal "Remove" #20:00:00 (time- #20:00:40 (time second: 40)))) - (test-group "Minutes" - (test-equal "Add" #20:10:00 (time+ #20:00:00 (time minute: 10))) - (test-equal "Remove" #20:00:00 (time- #20:10:00 (time minute: 10)))) - (test-group "Hours" - (test-equal "Add" #22:00:00 (time+ #20:00:00 (time hour: 2))) - (test-equal "Remove" #20:00:00 (time- #22:00:00 (time hour: 2))))) - - (test-group "Overflowing cases" - (test-group "Addition" - (test-group "Single overflow" - (call-with-values (lambda () (time+ #20:00:00 (time hour: 5))) - (lambda (result overflow) - (test-equal "Time" (time hour: 1) result) - (test-equal "Overflow" 1 overflow)))) - (test-group "Mulitple overflows" - (call-with-values (lambda () (time+ #20:00:00 (time hour: 5) (time hour: 24))) - (lambda (result overflow) - (test-equal "Time" (time hour: 1) result) - (test-equal "Overflow" 2 overflow))))) - - (test-group "Subtraction" - (test-group "Single overflow" - (call-with-values (lambda () (time- #20:00:00 (time hour: 25))) - (lambda (result overflow) - (test-equal "Time" (time hour: 19) result) - (test-equal "Overflow" 1 overflow)))) - (test-group "Mulitple overflows" - (call-with-values (lambda () (time- (time hour: 4) (time hour: 10) (time hour: 24))) - (lambda (result overflow) - (test-equal "Time" (time hour: 18) result) - (test-equal "Overflow" 2 overflow)))))))) - -;; TODO -datetime+ datetime- - -(test-group "Date difference" - (test-assert "The differente between a date and itself is zero" - (date-zero? (date-difference #2022-02-02 #2022-02-02))) - - (test-error "Later date must be first" 'misc-error - (date-difference #2020-01-01 #2021-01-01)) - - (test-error "Negative months are invalid" 'misc-error - (date-difference (date) (date month: -1))) - (test-error "Negative days are invalid" 'misc-error - (date-difference (date) (date day: -1))) - (test-equal "Negative years ARE valid" - (date year: 1) (date-difference (date) (date year: -1)))) - -;; TODO -datetime-difference diff --git a/tests/test/hnh-util-env.scm b/tests/test/hnh-util-env.scm deleted file mode 100644 index c1e0161f..00000000 --- a/tests/test/hnh-util-env.scm +++ /dev/null @@ -1,47 +0,0 @@ -(define-module (test hnh-util-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/hnh-util-lens.scm b/tests/test/hnh-util-lens.scm deleted file mode 100644 index 0508553a..00000000 --- a/tests/test/hnh-util-lens.scm +++ /dev/null @@ -1,59 +0,0 @@ -(define-module (test hnh-util-lens) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module (hnh util lens)) - - -(define first (ref 0)) - -(test-equal '((1)) (first '(((1))))) -(test-equal '((2)) (set '(((1))) (compose-lenses first first) 2)) -(test-equal '(((2))) (set '(((1))) (compose-lenses first first first) 2)) - - -;; (list-change (iota 10) 5 'Hello) -;; => (0 1 2 3 4 Hello 6 7 8 9) - -(test-equal '(1 (10) 3) (set '(1 (2) 3) (compose-lenses (ref 1) (ref 0)) 10)) -(test-equal '(1 (10) 3) (set '(1 (2) 3) (ref 1) (ref 0) 10)) - -;; (set (list (iota 10)) first first 11) - -(define cadr* (compose-lenses cdr* car*)) - -(test-group "Primitive lenses get and set" - (define lst '(1 2 3 4 5)) - (test-equal 1 (car* lst)) - (test-equal '(2 3 4 5) (cdr* lst)) - - (test-equal '(10 2 3 4 5) - (car* lst 10))) - -(test-group "Primitive lens composition" - (define lst '(1 2 3 4 5)) - (test-equal 2 (cadr* lst)) - (test-equal '(1 10 3 4 5) (cadr* lst 10))) - -(test-group "Modify" - (define lst '(1 2 3 4 5)) - (test-equal '(10 2 3 4 5) (modify lst car* * 10)) - (test-equal '(1 20 3 4 5) (modify lst cadr* * 10)) - ) - -(test-group "Modify*" - (define lst '(1 2 3 4 5)) - (test-equal '(1 2 4 4 5) (modify* lst cdr* cdr* car* 1+))) - -;; modify -;; modify* -;; set -;; get - -;; identity-lens -;; compose-lenses -;; lens-compose - -;; ref car* cdr* - -;; each diff --git a/tests/test/hnh-util-path.scm b/tests/test/hnh-util-path.scm deleted file mode 100644 index de4bf8e3..00000000 --- a/tests/test/hnh-util-path.scm +++ /dev/null @@ -1,124 +0,0 @@ -(define-module (test hnh-util-path) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module ((hnh util env) :select (with-working-directory)) - :use-module (hnh util path)) - -(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-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/hnh-util-state-monad.scm b/tests/test/hnh-util-state-monad.scm deleted file mode 100644 index 353c47e9..00000000 --- a/tests/test/hnh-util-state-monad.scm +++ /dev/null @@ -1,120 +0,0 @@ -(define-module (test hnh-util-state-monad) - :use-module (srfi srfi-64) - :use-module (hnh util state-monad)) - - -(call-with-values (lambda () ((return 1) 2)) - (lambda (value state) - (test-equal "Return returns the value unmodified" 1 value) - (test-equal "Return also returns the state as a second value" 2 state))) - -(test-equal "Get returns the current state as primary value, while kepping the state" - '(state state) - (call-with-values (lambda () ((get) 'state)) list)) - -;; Return value of put untested, since it's undefined -(test-equal "Put replaces the old state with a new one, and return old one" - '(old-state new-state) - (call-with-values (lambda () ((put 'new-state) 'old-state)) - list)) - -(test-equal "A simple do is effectively a `values' call" - '(value initial-state) - (call-with-values (lambda () ((do (return 'value)) 'initial-state)) - list)) - -(test-equal "Let statement in do" - '(10 state) - (call-with-values (lambda () ((do x = 10 - (return x)) - 'state)) - list)) - -;; TODO let statement with multiple binds -;; (do let (a b) = (values 10 20) ...) - -(test-equal "Set and get through do, along with <- in do." - '(5 1) - (call-with-values (lambda () ((do old <- (get) - (put (1+ old)) - (return 5)) - 0)) - list)) - - - -(test-equal "<$> Updates stuff before being removed from the monad context" - '(11 10) - (call-with-values (lambda () - ((do x <- (<$> 1+ (get)) - (return x)) - 10)) - list)) - -(test-equal "Sequence should update the state accordingly" - 3 - (call-with-values - (lambda () - ((sequence - (list (mod 1+) - (mod 1+) - (mod 1+))) - 0)) - (lambda (_ st) st))) - -(test-equal "Sequence should also act as map on the primary value" - '((0 1 2) 3) - (call-with-values - (lambda () - ((sequence - (list (mod 1+) - (mod 1+) - (mod 1+))) - 0)) - list)) - -(test-equal "Get returns a single value when only a single value is in the state" - '(1 1) (call-with-values (lambda () ((get) 1)) - list)) - -(test-equal "Get returns a list of values when multiple items are in the state" - '((1 2 3) 1 2 3) - (call-with-values (lambda () ((get) 1 2 3)) - list)) - -(test-equal "Get with multiple values" - '((1 2) 1 2) - (call-with-values (lambda () ((get) 1 2)) - list)) - -(test-equal "Get with multiple values in do" - '((1 2) 1 2) - (call-with-values (lambda () - ((do (a b) <- (get) - (return (list a b))) - 1 2)) - list)) - -((do (put 0) - (with-temp-state - (list 10) - (do a <- (get) - (return (test-equal "Temporary state is set" - 10 a)) - (put 20))) - a <- (get) - (return (test-equal "Pre-temp state is restored" 0 a))) - 'init) - - -;; TODO test for do where the number of implicit arguments changes - -(test-equal "Something" 30 - ((do (with-temp-state - '(10 20) - ;; todo (lift +) - (do (a b) <- (get) - (return (+ a b))))) - 0 1)) - - diff --git a/tests/test/hnh-util.scm b/tests/test/hnh-util.scm deleted file mode 100644 index c4a20443..00000000 --- a/tests/test/hnh-util.scm +++ /dev/null @@ -1,408 +0,0 @@ -;;; Commentary: -;; Checks some prodecuders from (hnh util) -;;; Code: - -(define-module (test hnh-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) - ) - -(define (unreachable) - (throw 'unreachable)) - - -;;; Changed core bindings - -(test-group "set!" - (let ((x 10)) - (set! x 20) - (test-eqv "Regular set! still works" 20 x)) - - (test-group "Multiple set! at once works" - (let ((x 10) (y 20)) - (set! x 20 - y 30) - (test-eqv x 20) - (test-eqv y 30))) - - (test-group "Set! is ordered" - (let ((x 10)) - (set! x 20 - x (* x 2)) - (test-eqv x 40))) - - ;; TODO - ;; (test-group "set! =" - ;; ) - - ) - -;;; Nonscensical to test -;; (test-group "define-syntax" -;; ) - -(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)) - - - -;;; New bindings - -(test-group "aif" - (aif (+ 1 2) - (test-eqv 3 it) - (unreachable)) - - (aif #f - (unreachable) - (test-assert #t))) - - (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-group "print-and-return" - (let ((p (open-output-string))) - (let ((v (with-error-to-port p - (lambda () (print-and-return (+ 1 2)))))) - (test-equal "Printed value" - "3 [(+ 1 2)]\n" (get-output-string p)) - (test-eqv "Returned value" - 3 v)))) - -(test-group "swap" - (test-equal - '(3 2 1) - ((swap list) 1 2 3))) - - -(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-group "string-take-to" - (test-equal "Hello" - (string-take-to "Hello, World!" 5))) - -(test-group "string-first" - (test-eqv #\H (string-first "Hello, World!"))) - -(test-group "string-last" - (test-eqv #\! (string-last "Hello, World!"))) - -(test-group "as-symb" - (test-eq "From string" 'hello (as-symb "hello")) - (test-eq "From symbol" 'hello (as-symb 'hello)) - (test-eq "NOTE that others pass right through" - '() (as-symb '()))) - - -(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 "group-by" - ;; Extra roundabout tests since groups-by doesn't guarantee order of the keys - (test-group "Two simple groups" - (let ((groups (group-by even? (iota 10)))) - (test-assert (lset= eq? '(#f #t) (map car groups))) - (test-assert (lset= = '(0 2 4 6 8) (assq-ref groups #t))) - (test-assert (lset= = '(1 3 5 7 9) (assq-ref groups #f))))) - - (test-group "Identity groups" - (let ((groups (group-by identity (iota 5)))) - (test-assert "Correct keys" - (lset= = (iota 5) (map car groups))) - (test-group "Correct amount in each group" - (for-each (lambda (g) (test-equal 1 (length (cdr g)))) groups)))) - - (test-equal "Null case" - '() - (group-by (lambda _ (unreachable)) '()))) - -(test-group "split-by" - 'TODO) - - - -(test-group "cross-product" - (test-equal "Basic case" - '((1 4) - (1 5) - (1 6) - (2 4) - (2 5) - (2 6) - (3 4) - (3 5) - (3 6)) - (cross-product - '(1 2 3) - '(4 5 6))) - - (test-equal "Single input list" - '((1) (2) (3)) - (cross-product '(1 2 3))) - - (test-equal "More than two" - '((1 3 5) (1 3 6) - (1 4 5) (1 4 6) - (2 3 5) (2 3 6) - (2 4 5) (2 4 6)) - (cross-product - '(1 2) - '(3 4) - '(5 6)))) - -(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=>> - -;; downcase-symbol - - - -;; TODO test failure when grouping isn't possible? -(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" - (test-error 'wrong-type-arg (find-extreme '())) - - (test-group "find-min" - (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))))) - - (test-group "find-max" - (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-group "Span upto" - (test-group "Case 1" - (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)))) - - (test-group "Case 2" - (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-group "->string" - (test-equal "5" (->string 5)) - (test-equal "5" (->string "5"))) diff --git a/tests/test/html/caltable.scm b/tests/test/html/caltable.scm deleted file mode 100644 index fec1ace4..00000000 --- a/tests/test/html/caltable.scm +++ /dev/null @@ -1,108 +0,0 @@ -(define-module (test html caltable) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module (calp html caltable) - :use-module (datetime) - ;; causes translated parts of the generated document to work - :use-module (calp translation) - ) - -;; Not the most robust test, but at least it shows us when we break something -(test-equal "Whole fucking caltable" - `(div (@ (class "small-calendar")) - (div (@ (class "column-head row-head")) ,(G_ "v.")) - (div (@ (class "column-head")) "Må") - (div (@ (class "column-head")) "Ti") - (div (@ (class "column-head")) "On") - (div (@ (class "column-head")) "To") - (div (@ (class "column-head")) "Fr") - (div (@ (class "column-head")) "Lö") - (div (@ (class "column-head")) "Sö") - (div (@ (class "row-head")) 13) - (div (@ (class "row-head")) 14) - (div (@ (class "row-head")) 15) - (div (@ (class "row-head")) 16) - (div (@ (class "row-head")) 17) - (a (@ (class "prev") - (href "2022-03-01.html" "#" "2022-03-28")) - (time (@ (datetime "2022-03-28")) 28)) - (a (@ (class "prev") - (href "2022-03-01.html" "#" "2022-03-29")) - (time (@ (datetime "2022-03-29")) 29)) - (a (@ (class "prev") - (href "2022-03-01.html" "#" "2022-03-30")) - (time (@ (datetime "2022-03-30")) 30)) - (a (@ (class "prev") - (href "2022-03-01.html" "#" "2022-03-31")) - (time (@ (datetime "2022-03-31")) 31)) - (a (@ (href "#" "2022-04-01")) - (time (@ (datetime "2022-04-01")) 1)) - (a (@ (href "#" "2022-04-02")) - (time (@ (datetime "2022-04-02")) 2)) - (a (@ (href "#" "2022-04-03")) - (time (@ (datetime "2022-04-03")) 3)) - (a (@ (href "#" "2022-04-04")) - (time (@ (datetime "2022-04-04")) 4)) - (a (@ (href "#" "2022-04-05")) - (time (@ (datetime "2022-04-05")) 5)) - (a (@ (href "#" "2022-04-06")) - (time (@ (datetime "2022-04-06")) 6)) - (a (@ (href "#" "2022-04-07")) - (time (@ (datetime "2022-04-07")) 7)) - (a (@ (href "#" "2022-04-08")) - (time (@ (datetime "2022-04-08")) 8)) - (a (@ (href "#" "2022-04-09")) - (time (@ (datetime "2022-04-09")) 9)) - (a (@ (href "#" "2022-04-10")) - (time (@ (datetime "2022-04-10")) 10)) - (a (@ (href "#" "2022-04-11")) - (time (@ (datetime "2022-04-11")) 11)) - (a (@ (href "#" "2022-04-12")) - (time (@ (datetime "2022-04-12")) 12)) - (a (@ (href "#" "2022-04-13")) - (time (@ (datetime "2022-04-13")) 13)) - (a (@ (href "#" "2022-04-14")) - (time (@ (datetime "2022-04-14")) 14)) - (a (@ (href "#" "2022-04-15")) - (time (@ (datetime "2022-04-15")) 15)) - (a (@ (href "#" "2022-04-16")) - (time (@ (datetime "2022-04-16")) 16)) - (a (@ (href "#" "2022-04-17")) - (time (@ (datetime "2022-04-17")) 17)) - (a (@ (href "#" "2022-04-18")) - (time (@ (datetime "2022-04-18")) 18)) - (a (@ (href "#" "2022-04-19")) - (time (@ (datetime "2022-04-19")) 19)) - (a (@ (href "#" "2022-04-20")) - (time (@ (datetime "2022-04-20")) 20)) - (a (@ (href "#" "2022-04-21")) - (time (@ (datetime "2022-04-21")) 21)) - (a (@ (href "#" "2022-04-22")) - (time (@ (datetime "2022-04-22")) 22)) - (a (@ (href "#" "2022-04-23")) - (time (@ (datetime "2022-04-23")) 23)) - (a (@ (href "#" "2022-04-24")) - (time (@ (datetime "2022-04-24")) 24)) - (a (@ (href "#" "2022-04-25")) - (time (@ (datetime "2022-04-25")) 25)) - (a (@ (href "#" "2022-04-26")) - (time (@ (datetime "2022-04-26")) 26)) - (a (@ (href "#" "2022-04-27")) - (time (@ (datetime "2022-04-27")) 27)) - (a (@ (href "#" "2022-04-28")) - (time (@ (datetime "2022-04-28")) 28)) - (a (@ (href "#" "2022-04-29")) - (time (@ (datetime "2022-04-29")) 29)) - (a (@ (href "#" "2022-04-30")) - (time (@ (datetime "2022-04-30")) 30)) - (a (@ (class "next") - (href "2022-05-01.html" "#" "2022-05-01")) - (time (@ (datetime "2022-05-01")) 1))) - - (parameterize ((week-start mon)) - (cal-table start-date: #2022-04-01 - end-date: #2022-04-30 - next-start: (lambda (d) (date+ d (date month: 1))) - prev-start: (lambda (d) (date- d (date month: 1)))))) - diff --git a/tests/test/html/component.scm b/tests/test/html/component.scm deleted file mode 100644 index a1fbdfbc..00000000 --- a/tests/test/html/component.scm +++ /dev/null @@ -1,36 +0,0 @@ -(define-module (test html caltable) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module (calp translation) - - :use-module (calp html components) - ) - -(test-equal - '(button (@ (class "btn") (onclick "onclick")) "Body") - (btn onclick: "onclick" "Body")) - -(test-equal "href button, without body" - '(a (@ (class "btn") (href "href"))) - (btn href: "href")) - -(test-error 'wrong-type-arg - (btn href: "a" onclick: "b")) - -(test-equal "btn no specifier, but class" - '(button (@ (class "btn test")) "body") - (btn class: '("test") "body")) - -;; tabset - -(test-equal '(link (@ (type "text/css") (rel "stylesheet") (href "style.css"))) - (include-css "style.css")) - -(test-equal - '(link (@ (type "text/css") (rel "stylesheet") (href "style.css") (class "test"))) - (include-css "style.css" '(class "test"))) - -(test-equal - '(link (@ (type "text/css") (rel "alternate stylesheet") (href "style.css"))) - (include-alt-css "style.css")) diff --git a/tests/test/object.scm b/tests/test/object.scm deleted file mode 100644 index 701c45c0..00000000 --- a/tests/test/object.scm +++ /dev/null @@ -1,80 +0,0 @@ -(define-module (test object) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module (hnh util object) - :use-module ((hnh util) :select (->))) - -(define-type (f) x) - -(test-group "Created procedures" - (test-assert "Constructor" (procedure? f)) - (test-assert "Predicate" (procedure? f?)) - (test-assert "Field access" (procedure? x))) - -;; (f) -;; (f x: 10) -;; (f? (f)) - -(test-equal "Accessors are getters" - 10 (x (f x: 10))) -(test-assert "Accessors update, returning a object of the original type" - (f? (x (f x: 10) 20))) -(test-equal "A get after an update returns the new value" - 20 (-> (f x: 10) - (x 20) - x)) - - -(define-type (g) x) - -(test-assert "Second type can be created" - (g x: 10)) - -(test-assert "Second type isn't first type" - (not (f? (g x: 10)))) - -(test-assert "First type isn't second type" - (not (g? (f x: 10)))) - -;; Tests that the old x gets shadowed -;; (test-equal 10 (x (f x: 10))) -;; (test-equal 10 (x (g x: 10))) - -;; field-level arguments -;; - init: -(define-type (f2) (f2-x default: 0 type: integer?)) -(test-equal 0 (f2-x (f2))) - -;; - type: - -(test-error "Giving an invalid type to the constructor throws an error" - 'wrong-type-arg (f2 f2-x: 'hello)) -(test-error "Giving an invalid type to a setter throws an error" - 'wrong-type-arg (f2-x (f2) 'hello)) -(test-equal "The error includes the name of the field, the expected type, and the given value" - '(f2-x integer? hello) - (catch 'wrong-type-arg (lambda () (f2-x (f2) 'hello)) - (lambda (err proc fmt args data) args))) - -(test-equal "Typed setter updates the value" - (f2 f2-x: 10) (f2-x (f2) 10)) - -;; type-level arguments -;; - constructor: -(define-type (f3 constructor: (lambda (make check) - (lambda* (#:key f3-x f3-y) - (check f3-x f3-y) - (make f3-x f3-y)))) - (f3-x type: integer?) - (f3-y type: string?)) - -(test-assert "Custom constructors create objcets" - (f3? (f3 f3-x: 10 f3-y: "Hello"))) - -(test-error "Bad arguments to custom constructor" - 'wrong-type-arg (f3 f3-x: 'hello f3-y: 'world)) - -;; - printer: -(define-type (f4 printer: (lambda (r p) (display "something" p)))) -(test-equal "something" (with-output-to-string (lambda () (write (f4))))) diff --git a/tests/test/param.scm b/tests/test/param.scm deleted file mode 100644 index 431a8f46..00000000 --- a/tests/test/param.scm +++ /dev/null @@ -1,66 +0,0 @@ -;;; Commentary: -;; Checks that parameters (1) are correctly parsed and stored. -;; (1): 'A', and 'B' in the line "KEY;A=1;B=2:Some text" -;;; Code: - -(define-module (test param) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module ((vcomponent base) - :select (param prop* parameters prop vline?)) - :use-module ((vcomponent formats ical parse) - :select (parse-calendar)) - :use-module ((vcomponent) :select (vcomponent properties set-properties)) - :use-module ((hnh util) :select (sort* set!)) - :use-module ((ice-9 ports) :select (call-with-input-string)) - :use-module ((vcomponent formats xcal output) - :select (vcomponent->sxcal)) - ) - -;; TODO clean up this whole test - -;; TODO possibly change parsing - -(define v - (car - (call-with-input-string - "BEGIN:DUMMY -X-KEY;A=1;B=2:Some text -END:DUMMY" - parse-calendar))) - -(test-equal '("1") (param (prop* v 'X-KEY) 'A)) - -(test-equal '("2") (param (prop* v 'X-KEY) 'B)) - -(test-equal #f (param (prop* v 'X-KEY) 'C)) - - -(test-group "Properties" - (let ((p (properties v))) - (test-assert (list? p)) - (test-eqv 1 (length p)) - (test-eq 'X-KEY (caar p)) - (test-assert (vline? (cadar p))))) - - - -;; TODO possibly move this. -;; Checks that a warning is properly raised for -;; unkonwn keys (without an X-prefix) -(test-error "Ensure parse-calendar warns on unknown keys" - 'warning - (call-with-input-string - "BEGIN:DUMMY -KEY:Some Text -END:DUMMY" - parse-calendar)) - -;; Similar thing happens for sxcal, but during serialization instead -(let ((component (set-properties (vcomponent type: 'DUMMY) - (cons 'KEY "Anything")))) - - (test-error - 'warning - (vcomponent->sxcal component))) diff --git a/tests/test/recurrence-advanced.scm b/tests/test/recurrence-advanced.scm deleted file mode 100644 index c2d71e61..00000000 --- a/tests/test/recurrence-advanced.scm +++ /dev/null @@ -1,1550 +0,0 @@ -;;; Commentary: -;; Tests of recurrence rule generation with focus on correct instances -;; being generated. For tests of basic recurrence functionallity, see -;; recurrence-simple.scm. -;; -;; This file also tests format-recurrence-rule, which checks that human -;; readable representations of the RRULES work. -;; -;; Also contains the tests for EXDATE. -;; -;; Most examples copied from RFC5545, some home written. -;;; Code: - -(define-module (test recurrence-advanced) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((vcomponent recurrence) - :select (make-recur-rule)) - :use-module ((vcomponent recurrence generate) - :select (generate-recurrence-set)) - :use-module ((vcomponent recurrence display) - :select (format-recurrence-rule)) - :use-module ((vcomponent recurrence internal) - :select (count until)) - :use-module ((vcomponent base) - :select (prop prop* extract)) - :use-module (vcomponent create) - :use-module ((datetime) - :select (parse-ics-datetime - datetime - datetime-date - time - date - jan feb mar apr may jun jul aug sep oct nov dec - mon tue wed thu fri sat sun - datetime->string)) - :use-module ((hnh util) :select (-> set!)) - :use-module ((srfi srfi-41) :select (stream->list)) - :use-module ((srfi srfi-88) :select (keyword->string))) - -(test-expect-fail "REC: The third instance into the month of one of Tuesday, Wednesday, or Thursday, for the next 3 months") - -(test-expect-fail "STR: The third instance into the month of one of Tuesday, Wednesday, or Thursday, for the next 3 months") - -(test-expect-fail "REC: The second-to-last weekday of the month") - -(test-expect-fail "STR: The second-to-last weekday of the month") - -;; TODO this test is really slow, figure out why (takes approx. 25s to run) -(test-skip "REC: Every day in January, for 3 years (alt 2)") - -(define (run-test comp) - (test-equal - (string-append "REC: " (prop comp 'SUMMARY)) - (prop comp 'X-SET) - (let ((r (generate-recurrence-set comp))) - (map (extract 'DTSTART) - (if (or (until (prop comp 'RRULE)) - (count (prop comp 'RRULE))) - (stream->list r) - (stream->list 20 r))))) - (test-equal - (string-append "STR: " (prop comp 'SUMMARY)) - (prop comp 'X-SUMMARY) - ;; TODO setting language='en causes messages to be in english, but date - ;; strings still format LC_TIME (which I have set to swedish)... - ;; TODO possibly test with other languages - (format-recurrence-rule (prop comp 'RRULE) 'sv))) - -(map run-test - (list (vevent - summary: - "Daily for 10 occurrences" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'DAILY - count: 10) - x-summary: - "dagligen, totalt 10 gånger" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-03T09:00:00 - #1997-09-04T09:00:00 - #1997-09-05T09:00:00 - #1997-09-06T09:00:00 - #1997-09-07T09:00:00 - #1997-09-08T09:00:00 - #1997-09-09T09:00:00 - #1997-09-10T09:00:00 - #1997-09-11T09:00:00)) - (vevent - summary: - "Daily until December 24, 1997" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'DAILY - until: #1997-12-24T00:00:00Z) - x-summary: - "dagligen, till och med den 24 december, 1997 kl. 0:00" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-03T09:00:00 - #1997-09-04T09:00:00 - #1997-09-05T09:00:00 - #1997-09-06T09:00:00 - #1997-09-07T09:00:00 - #1997-09-08T09:00:00 - #1997-09-09T09:00:00 - #1997-09-10T09:00:00 - #1997-09-11T09:00:00 - #1997-09-12T09:00:00 - #1997-09-13T09:00:00 - #1997-09-14T09:00:00 - #1997-09-15T09:00:00 - #1997-09-16T09:00:00 - #1997-09-17T09:00:00 - #1997-09-18T09:00:00 - #1997-09-19T09:00:00 - #1997-09-20T09:00:00 - #1997-09-21T09:00:00 - #1997-09-22T09:00:00 - #1997-09-23T09:00:00 - #1997-09-24T09:00:00 - #1997-09-25T09:00:00 - #1997-09-26T09:00:00 - #1997-09-27T09:00:00 - #1997-09-28T09:00:00 - #1997-09-29T09:00:00 - #1997-09-30T09:00:00 - #1997-10-01T09:00:00 - #1997-10-02T09:00:00 - #1997-10-03T09:00:00 - #1997-10-04T09:00:00 - #1997-10-05T09:00:00 - #1997-10-06T09:00:00 - #1997-10-07T09:00:00 - #1997-10-08T09:00:00 - #1997-10-09T09:00:00 - #1997-10-10T09:00:00 - #1997-10-11T09:00:00 - #1997-10-12T09:00:00 - #1997-10-13T09:00:00 - #1997-10-14T09:00:00 - #1997-10-15T09:00:00 - #1997-10-16T09:00:00 - #1997-10-17T09:00:00 - #1997-10-18T09:00:00 - #1997-10-19T09:00:00 - #1997-10-20T09:00:00 - #1997-10-21T09:00:00 - #1997-10-22T09:00:00 - #1997-10-23T09:00:00 - #1997-10-24T09:00:00 - #1997-10-25T09:00:00 - #1997-10-26T09:00:00 - #1997-10-27T09:00:00 - #1997-10-28T09:00:00 - #1997-10-29T09:00:00 - #1997-10-30T09:00:00 - #1997-10-31T09:00:00 - #1997-11-01T09:00:00 - #1997-11-02T09:00:00 - #1997-11-03T09:00:00 - #1997-11-04T09:00:00 - #1997-11-05T09:00:00 - #1997-11-06T09:00:00 - #1997-11-07T09:00:00 - #1997-11-08T09:00:00 - #1997-11-09T09:00:00 - #1997-11-10T09:00:00 - #1997-11-11T09:00:00 - #1997-11-12T09:00:00 - #1997-11-13T09:00:00 - #1997-11-14T09:00:00 - #1997-11-15T09:00:00 - #1997-11-16T09:00:00 - #1997-11-17T09:00:00 - #1997-11-18T09:00:00 - #1997-11-19T09:00:00 - #1997-11-20T09:00:00 - #1997-11-21T09:00:00 - #1997-11-22T09:00:00 - #1997-11-23T09:00:00 - #1997-11-24T09:00:00 - #1997-11-25T09:00:00 - #1997-11-26T09:00:00 - #1997-11-27T09:00:00 - #1997-11-28T09:00:00 - #1997-11-29T09:00:00 - #1997-11-30T09:00:00 - #1997-12-01T09:00:00 - #1997-12-02T09:00:00 - #1997-12-03T09:00:00 - #1997-12-04T09:00:00 - #1997-12-05T09:00:00 - #1997-12-06T09:00:00 - #1997-12-07T09:00:00 - #1997-12-08T09:00:00 - #1997-12-09T09:00:00 - #1997-12-10T09:00:00 - #1997-12-11T09:00:00 - #1997-12-12T09:00:00 - #1997-12-13T09:00:00 - #1997-12-14T09:00:00 - #1997-12-15T09:00:00 - #1997-12-16T09:00:00 - #1997-12-17T09:00:00 - #1997-12-18T09:00:00 - #1997-12-19T09:00:00 - #1997-12-20T09:00:00 - #1997-12-21T09:00:00 - #1997-12-22T09:00:00 - #1997-12-23T09:00:00)) - (vevent - summary: - "Every other day - forever" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'DAILY - interval: 2) - x-summary: - "varannan dag" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-04T09:00:00 - #1997-09-06T09:00:00 - #1997-09-08T09:00:00 - #1997-09-10T09:00:00 - #1997-09-12T09:00:00 - #1997-09-14T09:00:00 - #1997-09-16T09:00:00 - #1997-09-18T09:00:00 - #1997-09-20T09:00:00 - #1997-09-22T09:00:00 - #1997-09-24T09:00:00 - #1997-09-26T09:00:00 - #1997-09-28T09:00:00 - #1997-09-30T09:00:00 - #1997-10-02T09:00:00 - #1997-10-04T09:00:00 - #1997-10-06T09:00:00 - #1997-10-08T09:00:00 - #1997-10-10T09:00:00)) - (vevent - summary: - "Every 10 days, 5 occurrences" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'DAILY - interval: 10 - count: 5) - x-summary: - "var tionde dag, totalt 5 gånger" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-12T09:00:00 - #1997-09-22T09:00:00 - #1997-10-02T09:00:00 - #1997-10-12T09:00:00)) - (vevent - summary: - "Every day in January, for 3 years (alt 1)" - dtstart: - #1998-01-01T09:00:00 - rrule: - (make-recur-rule - freq: 'YEARLY - until: #2000-01-31T14:00:00Z - bymonth: (list jan) - byday: (list sun mon tue wed thu fri sat)) - x-summary: - "varje lördag, fredag, torsdag, onsdag, tisdag, måndag & söndag i januari, årligen, till och med den 31 januari, 2000 kl. 14:00" - x-set: - (list #1998-01-01T09:00:00 - #1998-01-02T09:00:00 - #1998-01-03T09:00:00 - #1998-01-04T09:00:00 - #1998-01-05T09:00:00 - #1998-01-06T09:00:00 - #1998-01-07T09:00:00 - #1998-01-08T09:00:00 - #1998-01-09T09:00:00 - #1998-01-10T09:00:00 - #1998-01-11T09:00:00 - #1998-01-12T09:00:00 - #1998-01-13T09:00:00 - #1998-01-14T09:00:00 - #1998-01-15T09:00:00 - #1998-01-16T09:00:00 - #1998-01-17T09:00:00 - #1998-01-18T09:00:00 - #1998-01-19T09:00:00 - #1998-01-20T09:00:00 - #1998-01-21T09:00:00 - #1998-01-22T09:00:00 - #1998-01-23T09:00:00 - #1998-01-24T09:00:00 - #1998-01-25T09:00:00 - #1998-01-26T09:00:00 - #1998-01-27T09:00:00 - #1998-01-28T09:00:00 - #1998-01-29T09:00:00 - #1998-01-30T09:00:00 - #1998-01-31T09:00:00 - #1999-01-01T09:00:00 - #1999-01-02T09:00:00 - #1999-01-03T09:00:00 - #1999-01-04T09:00:00 - #1999-01-05T09:00:00 - #1999-01-06T09:00:00 - #1999-01-07T09:00:00 - #1999-01-08T09:00:00 - #1999-01-09T09:00:00 - #1999-01-10T09:00:00 - #1999-01-11T09:00:00 - #1999-01-12T09:00:00 - #1999-01-13T09:00:00 - #1999-01-14T09:00:00 - #1999-01-15T09:00:00 - #1999-01-16T09:00:00 - #1999-01-17T09:00:00 - #1999-01-18T09:00:00 - #1999-01-19T09:00:00 - #1999-01-20T09:00:00 - #1999-01-21T09:00:00 - #1999-01-22T09:00:00 - #1999-01-23T09:00:00 - #1999-01-24T09:00:00 - #1999-01-25T09:00:00 - #1999-01-26T09:00:00 - #1999-01-27T09:00:00 - #1999-01-28T09:00:00 - #1999-01-29T09:00:00 - #1999-01-30T09:00:00 - #1999-01-31T09:00:00 - #2000-01-01T09:00:00 - #2000-01-02T09:00:00 - #2000-01-03T09:00:00 - #2000-01-04T09:00:00 - #2000-01-05T09:00:00 - #2000-01-06T09:00:00 - #2000-01-07T09:00:00 - #2000-01-08T09:00:00 - #2000-01-09T09:00:00 - #2000-01-10T09:00:00 - #2000-01-11T09:00:00 - #2000-01-12T09:00:00 - #2000-01-13T09:00:00 - #2000-01-14T09:00:00 - #2000-01-15T09:00:00 - #2000-01-16T09:00:00 - #2000-01-17T09:00:00 - #2000-01-18T09:00:00 - #2000-01-19T09:00:00 - #2000-01-20T09:00:00 - #2000-01-21T09:00:00 - #2000-01-22T09:00:00 - #2000-01-23T09:00:00 - #2000-01-24T09:00:00 - #2000-01-25T09:00:00 - #2000-01-26T09:00:00 - #2000-01-27T09:00:00 - #2000-01-28T09:00:00 - #2000-01-29T09:00:00 - #2000-01-30T09:00:00 - #2000-01-31T09:00:00)) - (vevent - summary: - "Every day in January, for 3 years (alt 2)" - dtstart: - #1998-01-01T09:00:00 - rrule: - (make-recur-rule - freq: 'DAILY - until: #2000-01-31T14:00:00Z - bymonth: 1) - x-summary: - "dagligen, till och med den 31 januari, 2000 kl. 14:00" - x-set: - (list #1998-01-01T09:00:00 - #1998-01-02T09:00:00 - #1998-01-03T09:00:00 - #1998-01-04T09:00:00 - #1998-01-05T09:00:00 - #1998-01-06T09:00:00 - #1998-01-07T09:00:00 - #1998-01-08T09:00:00 - #1998-01-09T09:00:00 - #1998-01-10T09:00:00 - #1998-01-11T09:00:00 - #1998-01-12T09:00:00 - #1998-01-13T09:00:00 - #1998-01-14T09:00:00 - #1998-01-15T09:00:00 - #1998-01-16T09:00:00 - #1998-01-17T09:00:00 - #1998-01-18T09:00:00 - #1998-01-19T09:00:00 - #1998-01-20T09:00:00 - #1998-01-21T09:00:00 - #1998-01-22T09:00:00 - #1998-01-23T09:00:00 - #1998-01-24T09:00:00 - #1998-01-25T09:00:00 - #1998-01-26T09:00:00 - #1998-01-27T09:00:00 - #1998-01-28T09:00:00 - #1998-01-29T09:00:00 - #1998-01-30T09:00:00 - #1998-01-31T09:00:00 - #1999-01-01T09:00:00 - #1999-01-02T09:00:00 - #1999-01-03T09:00:00 - #1999-01-04T09:00:00 - #1999-01-05T09:00:00 - #1999-01-06T09:00:00 - #1999-01-07T09:00:00 - #1999-01-08T09:00:00 - #1999-01-09T09:00:00 - #1999-01-10T09:00:00 - #1999-01-11T09:00:00 - #1999-01-12T09:00:00 - #1999-01-13T09:00:00 - #1999-01-14T09:00:00 - #1999-01-15T09:00:00 - #1999-01-16T09:00:00 - #1999-01-17T09:00:00 - #1999-01-18T09:00:00 - #1999-01-19T09:00:00 - #1999-01-20T09:00:00 - #1999-01-21T09:00:00 - #1999-01-22T09:00:00 - #1999-01-23T09:00:00 - #1999-01-24T09:00:00 - #1999-01-25T09:00:00 - #1999-01-26T09:00:00 - #1999-01-27T09:00:00 - #1999-01-28T09:00:00 - #1999-01-29T09:00:00 - #1999-01-30T09:00:00 - #1999-01-31T09:00:00 - #2000-01-01T09:00:00 - #2000-01-02T09:00:00 - #2000-01-03T09:00:00 - #2000-01-04T09:00:00 - #2000-01-05T09:00:00 - #2000-01-06T09:00:00 - #2000-01-07T09:00:00 - #2000-01-08T09:00:00 - #2000-01-09T09:00:00 - #2000-01-10T09:00:00 - #2000-01-11T09:00:00 - #2000-01-12T09:00:00 - #2000-01-13T09:00:00 - #2000-01-14T09:00:00 - #2000-01-15T09:00:00 - #2000-01-16T09:00:00 - #2000-01-17T09:00:00 - #2000-01-18T09:00:00 - #2000-01-19T09:00:00 - #2000-01-20T09:00:00 - #2000-01-21T09:00:00 - #2000-01-22T09:00:00 - #2000-01-23T09:00:00 - #2000-01-24T09:00:00 - #2000-01-25T09:00:00 - #2000-01-26T09:00:00 - #2000-01-27T09:00:00 - #2000-01-28T09:00:00 - #2000-01-29T09:00:00 - #2000-01-30T09:00:00 - #2000-01-31T09:00:00)) - (vevent - summary: - "Weekly for 10 occurrences" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'WEEKLY - count: 10) - x-summary: - "varje vecka, totalt 10 gånger" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-09T09:00:00 - #1997-09-16T09:00:00 - #1997-09-23T09:00:00 - #1997-09-30T09:00:00 - #1997-10-07T09:00:00 - #1997-10-14T09:00:00 - #1997-10-21T09:00:00 - #1997-10-28T09:00:00 - #1997-11-04T09:00:00)) - (vevent - summary: - "Weekly until December 24, 1997" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'WEEKLY - until: #1997-12-24T00:00:00Z) - x-summary: - "varje vecka, till och med den 24 december, 1997 kl. 0:00" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-09T09:00:00 - #1997-09-16T09:00:00 - #1997-09-23T09:00:00 - #1997-09-30T09:00:00 - #1997-10-07T09:00:00 - #1997-10-14T09:00:00 - #1997-10-21T09:00:00 - #1997-10-28T09:00:00 - #1997-11-04T09:00:00 - #1997-11-11T09:00:00 - #1997-11-18T09:00:00 - #1997-11-25T09:00:00 - #1997-12-02T09:00:00 - #1997-12-09T09:00:00 - #1997-12-16T09:00:00 - #1997-12-23T09:00:00)) - (vevent - summary: - "Every other week - forever" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'WEEKLY - interval: 2 - wkst: sun) - x-summary: - "varannan vecka" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-16T09:00:00 - #1997-09-30T09:00:00 - #1997-10-14T09:00:00 - #1997-10-28T09:00:00 - #1997-11-11T09:00:00 - #1997-11-25T09:00:00 - #1997-12-09T09:00:00 - #1997-12-23T09:00:00 - #1998-01-06T09:00:00 - #1998-01-20T09:00:00 - #1998-02-03T09:00:00 - #1998-02-17T09:00:00 - #1998-03-03T09:00:00 - #1998-03-17T09:00:00 - #1998-03-31T09:00:00 - #1998-04-14T09:00:00 - #1998-04-28T09:00:00 - #1998-05-12T09:00:00 - #1998-05-26T09:00:00)) - (vevent - summary: - "Weekly on Tuesday and Thursday for five weeks (alt 1)" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'WEEKLY - until: #1997-10-07T00:00:00Z - wkst: sun - byday: (list tue thu)) - x-summary: - "varje tisdag & torsdag, till och med den 07 oktober, 1997 kl. 0:00" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-04T09:00:00 - #1997-09-09T09:00:00 - #1997-09-11T09:00:00 - #1997-09-16T09:00:00 - #1997-09-18T09:00:00 - #1997-09-23T09:00:00 - #1997-09-25T09:00:00 - #1997-09-30T09:00:00 - #1997-10-02T09:00:00)) - (vevent - summary: - "Weekly on Tuesday and Thursday for five weeks (alt 2)" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'WEEKLY - count: 10 - wkst: sun - byday: (list tue thu)) - x-summary: - "varje tisdag & torsdag, totalt 10 gånger" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-04T09:00:00 - #1997-09-09T09:00:00 - #1997-09-11T09:00:00 - #1997-09-16T09:00:00 - #1997-09-18T09:00:00 - #1997-09-23T09:00:00 - #1997-09-25T09:00:00 - #1997-09-30T09:00:00 - #1997-10-02T09:00:00)) - (vevent - summary: - "Every other week on Monday, Wednesday, and Friday until December 24, 1997, starting on Monday, September 1, 1997:" - dtstart: - #1997-09-01T09:00:00 - rrule: - (make-recur-rule - freq: 'WEEKLY - interval: 2 - until: #1997-12-24T00:00:00Z - wkst: sun - byday: (list mon wed fri)) - x-summary: - "varannan måndag, onsdag & fredag, till och med den 24 december, 1997 kl. 0:00" - x-set: - (list #1997-09-01T09:00:00 - #1997-09-03T09:00:00 - #1997-09-05T09:00:00 - #1997-09-15T09:00:00 - #1997-09-17T09:00:00 - #1997-09-19T09:00:00 - #1997-09-29T09:00:00 - #1997-10-01T09:00:00 - #1997-10-03T09:00:00 - #1997-10-13T09:00:00 - #1997-10-15T09:00:00 - #1997-10-17T09:00:00 - #1997-10-27T09:00:00 - #1997-10-29T09:00:00 - #1997-10-31T09:00:00 - #1997-11-10T09:00:00 - #1997-11-12T09:00:00 - #1997-11-14T09:00:00 - #1997-11-24T09:00:00 - #1997-11-26T09:00:00 - #1997-11-28T09:00:00 - #1997-12-08T09:00:00 - #1997-12-10T09:00:00 - #1997-12-12T09:00:00 - #1997-12-22T09:00:00)) - (vevent - summary: - "Every other week on Tuesday and Thursday, for 8 occurrences" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'WEEKLY - interval: 2 - count: 8 - wkst: sun - byday: (list tue thu)) - x-summary: - "varannan tisdag & torsdag, totalt 8 gånger" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-04T09:00:00 - #1997-09-16T09:00:00 - #1997-09-18T09:00:00 - #1997-09-30T09:00:00 - #1997-10-02T09:00:00 - #1997-10-14T09:00:00 - #1997-10-16T09:00:00)) - (vevent - summary: - "Monthly on the first Friday for 10 occurrences" - dtstart: - #1997-09-05T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - count: 10 - byday: (list (cons 1 fri))) - x-summary: - "första fredagen varje månad, totalt 10 gånger" - x-set: - (list #1997-09-05T09:00:00 - #1997-10-03T09:00:00 - #1997-11-07T09:00:00 - #1997-12-05T09:00:00 - #1998-01-02T09:00:00 - #1998-02-06T09:00:00 - #1998-03-06T09:00:00 - #1998-04-03T09:00:00 - #1998-05-01T09:00:00 - #1998-06-05T09:00:00)) - (vevent - summary: - "Monthly on the first Friday until December 24, 1997" - dtstart: - #1997-09-05T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - until: #1997-12-24T00:00:00Z - byday: (list (cons 1 fri))) - x-summary: - "första fredagen varje månad, till och med den 24 december, 1997 kl. 0:00" - x-set: - (list #1997-09-05T09:00:00 - #1997-10-03T09:00:00 - #1997-11-07T09:00:00 - #1997-12-05T09:00:00)) - (vevent - summary: - "Every other month on the first and last Sunday of the month for 10 occurrences" - dtstart: - #1997-09-07T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - interval: 2 - count: 10 - byday: (list (cons 1 sun) - (cons -1 sun))) - x-summary: - "första söndagen samt sista söndagen varannan månad, totalt 10 gånger" - x-set: - (list #1997-09-07T09:00:00 - #1997-09-28T09:00:00 - #1997-11-02T09:00:00 - #1997-11-30T09:00:00 - #1998-01-04T09:00:00 - #1998-01-25T09:00:00 - #1998-03-01T09:00:00 - #1998-03-29T09:00:00 - #1998-05-03T09:00:00 - #1998-05-31T09:00:00)) - (vevent - summary: - "Monthly on the second-to-last Monday of the month for 6 months" - dtstart: - #1997-09-22T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - count: 6 - byday: (list (cons -2 mon))) - x-summary: - "näst sista måndagen varje månad, totalt 6 gånger" - x-set: - (list #1997-09-22T09:00:00 - #1997-10-20T09:00:00 - #1997-11-17T09:00:00 - #1997-12-22T09:00:00 - #1998-01-19T09:00:00 - #1998-02-16T09:00:00)) - (vevent - summary: - "Monthly on the third-to-the-last day of the month, forever" - dtstart: - #1997-09-28T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - bymonthday: (list -3)) - x-summary: - "den tredje sista varje månad" - x-set: - (list #1997-09-28T09:00:00 - #1997-10-29T09:00:00 - #1997-11-28T09:00:00 - #1997-12-29T09:00:00 - #1998-01-29T09:00:00 - #1998-02-26T09:00:00 - #1998-03-29T09:00:00 - #1998-04-28T09:00:00 - #1998-05-29T09:00:00 - #1998-06-28T09:00:00 - #1998-07-29T09:00:00 - #1998-08-29T09:00:00 - #1998-09-28T09:00:00 - #1998-10-29T09:00:00 - #1998-11-28T09:00:00 - #1998-12-29T09:00:00 - #1999-01-29T09:00:00 - #1999-02-26T09:00:00 - #1999-03-29T09:00:00 - #1999-04-28T09:00:00)) - (vevent - summary: - "Monthly on the 2nd and 15th of the month for 10 occurrences" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - count: 10 - bymonthday: (list 2 15)) - x-summary: - "den andre & femtonde varje månad, totalt 10 gånger" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-15T09:00:00 - #1997-10-02T09:00:00 - #1997-10-15T09:00:00 - #1997-11-02T09:00:00 - #1997-11-15T09:00:00 - #1997-12-02T09:00:00 - #1997-12-15T09:00:00 - #1998-01-02T09:00:00 - #1998-01-15T09:00:00)) - (vevent - summary: - "Monthly on the first and last day of the month for 10 occurrences" - dtstart: - #1997-09-30T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - count: 10 - bymonthday: (list 1 -1)) - x-summary: - "den förste & sista varje månad, totalt 10 gånger" - x-set: - (list #1997-09-30T09:00:00 - #1997-10-01T09:00:00 - #1997-10-31T09:00:00 - #1997-11-01T09:00:00 - #1997-11-30T09:00:00 - #1997-12-01T09:00:00 - #1997-12-31T09:00:00 - #1998-01-01T09:00:00 - #1998-01-31T09:00:00 - #1998-03-01T09:00:00)) - (vevent - summary: - "Every 18 months on the 10th thru 15th of the month for 10 occurrences" - dtstart: - #1997-09-10T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - interval: 18 - count: 10 - bymonthday: (list 10 11 12 13 14 15)) - x-summary: - "den tionde, elfte, tolfte, trettonde, fjortonde & femtonde var artonde månad, totalt 10 gånger" - x-set: - (list #1997-09-10T09:00:00 - #1997-09-11T09:00:00 - #1997-09-12T09:00:00 - #1997-09-13T09:00:00 - #1997-09-14T09:00:00 - #1997-09-15T09:00:00 - #1999-03-10T09:00:00 - #1999-03-11T09:00:00 - #1999-03-12T09:00:00 - #1999-03-13T09:00:00)) - (vevent - summary: - "Every Tuesday, every other month" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - interval: 2 - byday: (list tue)) - x-summary: - "varje tisdag varannan månad" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-09T09:00:00 - #1997-09-16T09:00:00 - #1997-09-23T09:00:00 - #1997-09-30T09:00:00 - #1997-11-04T09:00:00 - #1997-11-11T09:00:00 - #1997-11-18T09:00:00 - #1997-11-25T09:00:00 - #1998-01-06T09:00:00 - #1998-01-13T09:00:00 - #1998-01-20T09:00:00 - #1998-01-27T09:00:00 - #1998-03-03T09:00:00 - #1998-03-10T09:00:00 - #1998-03-17T09:00:00 - #1998-03-24T09:00:00 - #1998-03-31T09:00:00 - #1998-05-05T09:00:00 - #1998-05-12T09:00:00)) - (vevent - summary: - "Yearly in June and July for 10 occurrences:\n: Since none of the BYDAY, BYMONTHDAY, or BYYEARDAY\nonents are specified, the day is gotten from \"DTSTART\"" - dtstart: - #1997-06-10T09:00:00 - rrule: - (make-recur-rule - freq: 'YEARLY - count: 10 - bymonth: (list 6 7)) - x-summary: - "juni & juli, årligen, totalt 10 gånger" - x-set: - (list #1997-06-10T09:00:00 - #1997-07-10T09:00:00 - #1998-06-10T09:00:00 - #1998-07-10T09:00:00 - #1999-06-10T09:00:00 - #1999-07-10T09:00:00 - #2000-06-10T09:00:00 - #2000-07-10T09:00:00 - #2001-06-10T09:00:00 - #2001-07-10T09:00:00)) - (vevent - summary: - "Every other year on January, February, and March for 10 occurrences" - dtstart: - #1997-03-10T09:00:00 - rrule: - (make-recur-rule - freq: 'YEARLY - interval: 2 - count: 10 - bymonth: (list jan feb mar)) - x-summary: - "januari, februari & mars vartannat år, totalt 10 gånger" - x-set: - (list #1997-03-10T09:00:00 - #1999-01-10T09:00:00 - #1999-02-10T09:00:00 - #1999-03-10T09:00:00 - #2001-01-10T09:00:00 - #2001-02-10T09:00:00 - #2001-03-10T09:00:00 - #2003-01-10T09:00:00 - #2003-02-10T09:00:00 - #2003-03-10T09:00:00)) - (vevent - summary: - "Every third year on the 1st, 100th, and 200th day for 10 occurrences" - dtstart: - #1997-01-01T09:00:00 - rrule: - (make-recur-rule - freq: 'YEARLY - interval: 3 - count: 10 - byyearday: (list 1 100 200)) - x-summary: - "dag 1, 100 & 200 vart tredje år, totalt 10 gånger" - x-set: - (list #1997-01-01T09:00:00 - #1997-04-10T09:00:00 - #1997-07-19T09:00:00 - #2000-01-01T09:00:00 - #2000-04-09T09:00:00 - #2000-07-18T09:00:00 - #2003-01-01T09:00:00 - #2003-04-10T09:00:00 - #2003-07-19T09:00:00 - #2006-01-01T09:00:00)) - (vevent - summary: - "Every 20th Monday of the year, forever" - dtstart: - #1997-05-19T09:00:00 - rrule: - (make-recur-rule - freq: 'YEARLY - byday: (list (cons 20 mon))) - x-summary: - "tjugonde måndagen, årligen" - x-set: - (list #1997-05-19T09:00:00 - #1998-05-18T09:00:00 - #1999-05-17T09:00:00 - #2000-05-15T09:00:00 - #2001-05-14T09:00:00 - #2002-05-20T09:00:00 - #2003-05-19T09:00:00 - #2004-05-17T09:00:00 - #2005-05-16T09:00:00 - #2006-05-15T09:00:00 - #2007-05-14T09:00:00 - #2008-05-19T09:00:00 - #2009-05-18T09:00:00 - #2010-05-17T09:00:00 - #2011-05-16T09:00:00 - #2012-05-14T09:00:00 - #2013-05-20T09:00:00 - #2014-05-19T09:00:00 - #2015-05-18T09:00:00 - #2016-05-16T09:00:00)) - (vevent - summary: - "Monday of week number 20 (where the default start of the week is Monday), forever" - dtstart: - #1997-05-12T09:00:00 - rrule: - (make-recur-rule - freq: 'YEARLY - byweekno: (list 20) - byday: (list mon)) - x-summary: - "varje måndag v.20, årligen" - x-set: - (list #1997-05-12T09:00:00 - #1998-05-11T09:00:00 - #1999-05-17T09:00:00 - #2000-05-15T09:00:00 - #2001-05-14T09:00:00 - #2002-05-13T09:00:00 - #2003-05-12T09:00:00 - #2004-05-10T09:00:00 - #2005-05-16T09:00:00 - #2006-05-15T09:00:00 - #2007-05-14T09:00:00 - #2008-05-12T09:00:00 - #2009-05-11T09:00:00 - #2010-05-17T09:00:00 - #2011-05-16T09:00:00 - #2012-05-14T09:00:00 - #2013-05-13T09:00:00 - #2014-05-12T09:00:00 - #2015-05-11T09:00:00 - #2016-05-16T09:00:00)) - (vevent - summary: - "Every Thursday in March, forever" - dtstart: - #1997-03-13T09:00:00 - rrule: - (make-recur-rule - freq: 'YEARLY - bymonth: (list mar) - byday: (list thu)) - x-summary: - "varje torsdag i mars, årligen" - x-set: - (list #1997-03-13T09:00:00 - #1997-03-20T09:00:00 - #1997-03-27T09:00:00 - #1998-03-05T09:00:00 - #1998-03-12T09:00:00 - #1998-03-19T09:00:00 - #1998-03-26T09:00:00 - #1999-03-04T09:00:00 - #1999-03-11T09:00:00 - #1999-03-18T09:00:00 - #1999-03-25T09:00:00 - #2000-03-02T09:00:00 - #2000-03-09T09:00:00 - #2000-03-16T09:00:00 - #2000-03-23T09:00:00 - #2000-03-30T09:00:00 - #2001-03-01T09:00:00 - #2001-03-08T09:00:00 - #2001-03-15T09:00:00 - #2001-03-22T09:00:00)) - (vevent - summary: - "Every Thursday, but only during June, July, and August, forever" - dtstart: - #1997-06-05T09:00:00 - rrule: - (make-recur-rule - freq: 'YEARLY - byday: (list thu) - bymonth: (list 6 7 8)) - x-summary: - "varje torsdag i juni, juli & augusti, årligen" - x-set: - (list #1997-06-05T09:00:00 - #1997-06-12T09:00:00 - #1997-06-19T09:00:00 - #1997-06-26T09:00:00 - #1997-07-03T09:00:00 - #1997-07-10T09:00:00 - #1997-07-17T09:00:00 - #1997-07-24T09:00:00 - #1997-07-31T09:00:00 - #1997-08-07T09:00:00 - #1997-08-14T09:00:00 - #1997-08-21T09:00:00 - #1997-08-28T09:00:00 - #1998-06-04T09:00:00 - #1998-06-11T09:00:00 - #1998-06-18T09:00:00 - #1998-06-25T09:00:00 - #1998-07-02T09:00:00 - #1998-07-09T09:00:00 - #1998-07-16T09:00:00)) - (vevent - summary: - "Every Friday the 13th, forever" - dtstart: - #1997-09-02T09:00:00 - exdate: - (as-list - (list #1997-09-02T09:00:00)) - rrule: - (make-recur-rule - freq: 'MONTHLY - byday: (list fri) - bymonthday: (list 13)) - x-summary: - "varje fredag den trettonde varje månad" - x-set: - (list #1998-02-13T09:00:00 - #1998-03-13T09:00:00 - #1998-11-13T09:00:00 - #1999-08-13T09:00:00 - #2000-10-13T09:00:00 - #2001-04-13T09:00:00 - #2001-07-13T09:00:00 - #2002-09-13T09:00:00 - #2002-12-13T09:00:00 - #2003-06-13T09:00:00 - #2004-02-13T09:00:00 - #2004-08-13T09:00:00 - #2005-05-13T09:00:00 - #2006-01-13T09:00:00 - #2006-10-13T09:00:00 - #2007-04-13T09:00:00 - #2007-07-13T09:00:00 - #2008-06-13T09:00:00 - #2009-02-13T09:00:00 - #2009-03-13T09:00:00)) - (vevent - summary: - "The first Saturday that follows the first Sunday of the month, forever" - dtstart: - #1997-09-13T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - byday: (list sat) - bymonthday: (list 7 8 9 10 11 12 13)) - x-summary: - "varje lördag den sjunde, åttonde, nionde, tionde, elfte, tolfte & trettonde varje månad" - x-set: - (list #1997-09-13T09:00:00 - #1997-10-11T09:00:00 - #1997-11-08T09:00:00 - #1997-12-13T09:00:00 - #1998-01-10T09:00:00 - #1998-02-07T09:00:00 - #1998-03-07T09:00:00 - #1998-04-11T09:00:00 - #1998-05-09T09:00:00 - #1998-06-13T09:00:00 - #1998-07-11T09:00:00 - #1998-08-08T09:00:00 - #1998-09-12T09:00:00 - #1998-10-10T09:00:00 - #1998-11-07T09:00:00 - #1998-12-12T09:00:00 - #1999-01-09T09:00:00 - #1999-02-13T09:00:00 - #1999-03-13T09:00:00 - #1999-04-10T09:00:00)) - (vevent - summary: - "Every 4 years, the first Tuesday after a Monday in November,\nver (U.S. Presidential Election day)" - dtstart: - #1996-11-05T09:00:00 - rrule: - (make-recur-rule - freq: 'YEARLY - interval: 4 - bymonth: (list nov) - byday: (list tue) - bymonthday: (list 2 3 4 5 6 7 8)) - x-summary: - "varje tisdag den andre, tredje, fjärde, femte, sjätte, sjunde eller åttonde i november vart fjärde år" - x-set: - (list #1996-11-05T09:00:00 - #2000-11-07T09:00:00 - #2004-11-02T09:00:00 - #2008-11-04T09:00:00 - #2012-11-06T09:00:00 - #2016-11-08T09:00:00 - #2020-11-03T09:00:00 - #2024-11-05T09:00:00 - #2028-11-07T09:00:00 - #2032-11-02T09:00:00 - #2036-11-04T09:00:00 - #2040-11-06T09:00:00 - #2044-11-08T09:00:00 - #2048-11-03T09:00:00 - #2052-11-05T09:00:00 - #2056-11-07T09:00:00 - #2060-11-02T09:00:00 - #2064-11-04T09:00:00 - #2068-11-06T09:00:00 - #2072-11-08T09:00:00)) - (vevent - summary: - "The third instance into the month of one of Tuesday, Wednesday, or Thursday, for the next 3 months" - dtstart: - #1997-09-04T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - count: 3 - byday: (list tue wed thu) - bysetpos: (list 3)) - x-summary: - "NOT YET IMPLEMENTED" - x-set: - (list #1997-09-04T09:00:00 - #1997-10-07T09:00:00 - #1997-11-06T09:00:00)) - (vevent - summary: - "The second-to-last weekday of the month" - dtstart: - #1997-09-29T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - byday: (list mon tue wed thu fri) - bysetpos: (list -2)) - x-summary: - "NOT YET IMPLEMENTED" - x-set: - (list #1997-09-29T09:00:00 - #1997-10-30T09:00:00 - #1997-11-27T09:00:00 - #1997-12-30T09:00:00 - #1998-01-29T09:00:00)) - (vevent - summary: - "Every 3 hours from 9:00 AM to 5:00 PM on a specific day" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'HOURLY - interval: 3 - until: #1997-09-02T17:00:00Z) - x-summary: - "var tredje timme, till och med den 02 september, 1997 kl. 17:00" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-02T12:00:00 - #1997-09-02T15:00:00)) - (vevent - summary: - "Every 15 minutes for 6 occurrences" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'MINUTELY - interval: 15 - count: 6) - x-summary: - "varje kvart, totalt 6 gånger" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-02T09:15:00 - #1997-09-02T09:30:00 - #1997-09-02T09:45:00 - #1997-09-02T10:00:00 - #1997-09-02T10:15:00)) - (vevent - summary: - "Every hour and a half for 4 occurrences" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'MINUTELY - interval: 90 - count: 4) - x-summary: - "var sjätte kvart, totalt 4 gånger" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-02T10:30:00 - #1997-09-02T12:00:00 - #1997-09-02T13:30:00)) - (vevent - summary: - "Every 20 minutes from 9:00 AM to 4:40 PM every day (alt 1)" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'DAILY - byhour: (list 9 10 11 12 13 14 15 16) - byminute: (list 0 20 40)) - x-summary: - "dagligen kl. 09:00, 09:20, 09:40, 10:00, 10:20, 10:40, 11:00, 11:20, 11:40, 12:00, 12:20, 12:40, 13:00, 13:20, 13:40, 14:00, 14:20, 14:40, 15:00, 15:20, 15:40, 16:00, 16:20 & 16:40" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-02T09:20:00 - #1997-09-02T09:40:00 - #1997-09-02T10:00:00 - #1997-09-02T10:20:00 - #1997-09-02T10:40:00 - #1997-09-02T11:00:00 - #1997-09-02T11:20:00 - #1997-09-02T11:40:00 - #1997-09-02T12:00:00 - #1997-09-02T12:20:00 - #1997-09-02T12:40:00 - #1997-09-02T13:00:00 - #1997-09-02T13:20:00 - #1997-09-02T13:40:00 - #1997-09-02T14:00:00 - #1997-09-02T14:20:00 - #1997-09-02T14:40:00 - #1997-09-02T15:00:00 - #1997-09-02T15:20:00)) - (vevent - summary: - "Every 20 minutes from 9:00 AM to 4:40 PM every day (alt 2)" - dtstart: - #1997-09-02T09:00:00 - rrule: - (make-recur-rule - freq: 'MINUTELY - interval: 20 - byhour: (list 9 10 11 12 13 14 15 16)) - x-summary: - "var tjugonde minut kl. 9, 10, 11, 12, 13, 14, 15 & 16" - x-set: - (list #1997-09-02T09:00:00 - #1997-09-02T09:20:00 - #1997-09-02T09:40:00 - #1997-09-02T10:00:00 - #1997-09-02T10:20:00 - #1997-09-02T10:40:00 - #1997-09-02T11:00:00 - #1997-09-02T11:20:00 - #1997-09-02T11:40:00 - #1997-09-02T12:00:00 - #1997-09-02T12:20:00 - #1997-09-02T12:40:00 - #1997-09-02T13:00:00 - #1997-09-02T13:20:00 - #1997-09-02T13:40:00 - #1997-09-02T14:00:00 - #1997-09-02T14:20:00 - #1997-09-02T14:40:00 - #1997-09-02T15:00:00 - #1997-09-02T15:20:00)) - (vevent - summary: - "An example where the days generated makes a difference because of WKST" - dtstart: - #1997-08-05T09:00:00 - rrule: - (make-recur-rule - freq: 'WEEKLY - interval: 2 - count: 4 - byday: (list tue sun) - wkst: mon) - x-summary: - "varannan tisdag & söndag, totalt 4 gånger" - x-set: - (list #1997-08-05T09:00:00 - #1997-08-10T09:00:00 - #1997-08-19T09:00:00 - #1997-08-24T09:00:00)) - (vevent - summary: - "changing only WKST from MO to SU, yields different results.." - dtstart: - #1997-08-05T09:00:00 - rrule: - (make-recur-rule - freq: 'WEEKLY - interval: 2 - count: 4 - byday: (list tue sun) - wkst: sun) - x-summary: - "varannan tisdag & söndag, totalt 4 gånger" - x-set: - (list #1997-08-05T09:00:00 - #1997-08-17T09:00:00 - #1997-08-19T09:00:00 - #1997-08-31T09:00:00)) - (vevent - summary: - "An example where an invalid date (i.e., February 30) is ignored" - dtstart: - #2007-01-15T09:00:00 - rrule: - (make-recur-rule - freq: 'MONTHLY - bymonthday: (list 15 30) - count: 5) - x-summary: - "den femtonde & tretionde varje månad, totalt 5 gånger" - x-set: - (list #2007-01-15T09:00:00 - #2007-01-30T09:00:00 - #2007-02-15T09:00:00 - #2007-03-15T09:00:00 - #2007-03-30T09:00:00)) - (vevent - summary: - "Every Friday & Wednesday the 13th, forever" - dtstart: - #1997-09-02T09:00:00 - exdate: - (as-list - (list #1997-09-02T09:00:00)) - rrule: - (make-recur-rule - freq: 'MONTHLY - byday: (list fri wed) - bymonthday: (list 13)) - x-summary: - "varje onsdag & fredag den trettonde varje månad" - x-set: - (list #1998-02-13T09:00:00 - #1998-03-13T09:00:00 - #1998-05-13T09:00:00 - #1998-11-13T09:00:00 - #1999-01-13T09:00:00 - #1999-08-13T09:00:00 - #1999-10-13T09:00:00 - #2000-09-13T09:00:00 - #2000-10-13T09:00:00 - #2000-12-13T09:00:00 - #2001-04-13T09:00:00 - #2001-06-13T09:00:00 - #2001-07-13T09:00:00 - #2002-02-13T09:00:00 - #2002-03-13T09:00:00 - #2002-09-13T09:00:00 - #2002-11-13T09:00:00 - #2002-12-13T09:00:00 - #2003-06-13T09:00:00 - #2003-08-13T09:00:00)) - (vevent - summary: - "Monday & Wednesday of week number 20 (where the default start of the week is Monday), forever" - dtstart: - #1997-05-12T09:00:00 - rrule: - (make-recur-rule - freq: 'YEARLY - byweekno: (list 20) - byday: (list mon wed)) - x-summary: - "varje onsdag & måndag v.20, årligen" - x-set: - (list #1997-05-12T09:00:00 - #1997-05-14T09:00:00 - #1998-05-11T09:00:00 - #1998-05-13T09:00:00 - #1999-05-17T09:00:00 - #1999-05-19T09:00:00 - #2000-05-15T09:00:00 - #2000-05-17T09:00:00 - #2001-05-14T09:00:00 - #2001-05-16T09:00:00 - #2002-05-13T09:00:00 - #2002-05-15T09:00:00 - #2003-05-12T09:00:00 - #2003-05-14T09:00:00 - #2004-05-10T09:00:00 - #2004-05-12T09:00:00 - #2005-05-16T09:00:00 - #2005-05-18T09:00:00 - #2006-05-15T09:00:00 - #2006-05-17T09:00:00)) - (vevent - summary: "Each second, for ever" - dtstart: #2020-10-10T10:00:00 - rrule: (make-recur-rule freq: 'SECONDLY) - x-summary: "varje sekund" - x-set: (list #2020-10-10T10:00:00 - #2020-10-10T10:00:01 - #2020-10-10T10:00:02 - #2020-10-10T10:00:03 - #2020-10-10T10:00:04 - #2020-10-10T10:00:05 - #2020-10-10T10:00:06 - #2020-10-10T10:00:07 - #2020-10-10T10:00:08 - #2020-10-10T10:00:09 - #2020-10-10T10:00:10 - #2020-10-10T10:00:11 - #2020-10-10T10:00:12 - #2020-10-10T10:00:13 - #2020-10-10T10:00:14 - #2020-10-10T10:00:15 - #2020-10-10T10:00:16 - #2020-10-10T10:00:17 - #2020-10-10T10:00:18 - #2020-10-10T10:00:19)) - ;; Exdates are applied after rrule's, meaning that less than count - ;; instances may be present. - (vevent - summary: "Exdates are applied AFTER rrule's" - dtstart: #2022-06-10T10:00:00 - rrule: (make-recur-rule freq: 'DAILY count: 5) - exdate: (as-list (list #2022-06-12T10:00:00)) - x-summary: "dagligen, totalt 5 gånger" - x-set: (list #2022-06-10T10:00:00 - #2022-06-11T10:00:00 - ;; #2022-06-12T10:00:00 ; skipped by exdate - #2022-06-13T10:00:00 - #2022-06-14T10:00:00 - )) - (vevent - summary: "RDATE:s add to the recurrence rule" - dtstart: #2022-06-10T10:00:00 - rrule: (make-recur-rule freq: 'DAILY count: 5) - rdate: (as-list (list #2022-06-20T10:00:00)) - x-summary: "dagligen, totalt 5 gånger" - x-set: (list #2022-06-10T10:00:00 - #2022-06-11T10:00:00 - #2022-06-12T10:00:00 - #2022-06-13T10:00:00 - #2022-06-14T10:00:00 - #2022-06-20T10:00:00 ; added by rdate - ) - ) - (vevent - summary: "RDATE:s add to the recurrence rule" - dtstart: #2022-06-10T10:00:00 - rrule: (make-recur-rule freq: 'DAILY count: 5) - exdate: (as-list (list #2022-06-20T10:00:00)) - rdate: (as-list (list #2022-06-20T10:00:00)) - x-summary: "dagligen, totalt 5 gånger" - x-set: (list #2022-06-10T10:00:00 - #2022-06-11T10:00:00 - #2022-06-12T10:00:00 - #2022-06-13T10:00:00 - #2022-06-14T10:00:00 - ;; #2022-06-20T10:00:00 ; added by rdate, removed by exdate - )) - ;; TODO rdate with different timezone than dtstart - ;; TODO rdate with period - )) - - diff --git a/tests/test/recurrence-simple.scm b/tests/test/recurrence-simple.scm deleted file mode 100644 index b0c3bdea..00000000 --- a/tests/test/recurrence-simple.scm +++ /dev/null @@ -1,313 +0,0 @@ -;;; Commentary: -;; Simples tests of recurrence system, ensuring that all parsers and -;; basic generators work. Some more fully-featured tests are here, but -;; most are instead in recurrence-advanced.scm. -;;; Code: - -(define-module (test recurrence-simple) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module ((srfi srfi-41) - :select (stream-take stream-map stream->list stream-car)) - :use-module ((datetime) :select (day-stream mon)) - :use-module ((vcomponent base) :select (extract prop)) - :use-module ((sxml namespaced) :select (sxml->namespaced-sxml)) - :use-module ((calp namespaces) :select (xcal)) - :use-module ((hnh util) :select (->)) - :use-module ((hnh util exceptions) - :select (warnings-are-errors warning-handler)) - :use-module ((vcomponent formats ical parse) - :select (parse-calendar)) - :use-module ((vcomponent formats xcal parse) - :select (sxcal->vcomponent)) - :use-module ((vcomponent recurrence) - :select (parse-recurrence-rule - make-recur-rule - generate-recurrence-set))) - -;; TODO evaluate format for direct events - -;;; Test that basic parsing or recurrence rules work. - -(test-equal (make-recur-rule freq: 'HOURLY wkst: mon interval: 1) - (parse-recurrence-rule "FREQ=HOURLY")) - -(test-equal (make-recur-rule freq: 'HOURLY count: 3 interval: 1 wkst: mon) - (parse-recurrence-rule "FREQ=HOURLY;COUNT=3")) - -;;; Test that recurrence rule parsing fails where appropriate - -(parameterize ((warnings-are-errors #t) - (warning-handler (lambda _ ""))) - (test-error "Invalid FREQ" - 'warning - (parse-recurrence-rule "FREQ=ERR;COUNT=3")) - (test-error "Negative COUNT" - 'warning - (parse-recurrence-rule "FREQ=HOURLY;COUNT=-1")) - (test-error "Invalid COUNT" - 'wrong-type-arg - (parse-recurrence-rule "FREQ=HOURLY;COUNT=err"))) - -;;; Test that basic recurrence works -;;; also see the neighbour test file recurrence.scm for more tests. - -(define ev - (car - (call-with-input-string - "BEGIN:VEVENT -DTSTART;VALUE=DATE:20190302 -RRULE:FREQ=DAILY -END:VEVENT" - parse-calendar))) - -(test-assert "Generate at all" - (stream-car (generate-recurrence-set ev))) - -(test-assert "Generate some" - (stream->list - (stream-take 5 (generate-recurrence-set ev)))) - -(test-equal "Generate First" - (stream->list - 5 - (stream-map - (extract 'DTSTART) - (generate-recurrence-set ev))) - (stream->list 5 (day-stream (prop ev 'DTSTART)))) - -;; We run the exact same thing a secound time, since I had an error with -;; that during development. - -(test-equal "Generate Again" - (stream->list - (stream-take - 5 - (stream-map - (extract 'DTSTART) - (generate-recurrence-set ev)))) - (stream->list - (stream-take 5 (day-stream (prop ev 'DTSTART))))) - -(define ev - (car - (call-with-input-string - "BEGIN:VEVENT -DTSTART:20190302T100000 -RRULE:FREQ=DAILY -END:VEVENT" - parse-calendar))) - -(test-assert "daily 10:00" - (stream-car (generate-recurrence-set ev))) - -(define ev - (car - (call-with-input-string - "BEGIN:VEVENT -DTSTART:20190302T100000 -DTEND:20190302T120000 -RRULE:FREQ=DAILY -END:VEVENT" - parse-calendar))) - -(test-assert "daily 10-12" - (stream-car (generate-recurrence-set ev))) - -(define ev - (car - (call-with-input-string - "BEGIN:VEVENT -DTSTART:20190302T100000 -DTEND:20190302T120000 -RRULE:FREQ=WEEKLY -END:VEVENT" - parse-calendar))) - -(test-assert "weekly 10-12" - (stream-car (generate-recurrence-set ev))) - -(define ev - (car - (call-with-input-string - "BEGIN:VEVENT -DTSTART;TZID=Europe/Stockholm:20190302T100000 -DTEND;TZID=Europe/Stockholm:20190302T120000 -RRULE:FREQ=WEEKLY -END:VEVENT" - parse-calendar))) - -(test-assert "weekly TZ 10-12" - (stream-car (generate-recurrence-set ev))) - -(define ev - (car - (call-with-input-string - "BEGIN:VEVENT -DTSTART;TZID=Europe/Stockholm:20190302T100000 -DTEND;TZID=Europe/Stockholm:20190302T120000 -RRULE:FREQ=WEEKLY -SEQUENCE:1 -END:VEVENT" - parse-calendar))) - -(test-assert "weekly TZ SEQUENCE 10-12" - (stream-car (generate-recurrence-set ev))) - -(define ev - (car - (call-with-input-string - "BEGIN:VEVENT -DTSTART;TZID=Europe/Stockholm:20190302T100000 -RRULE:FREQ=WEEKLY -DTEND;TZID=Europe/Stockholm:20190302T120000 -SEQUENCE:1 -LOCATION:Here -END:VEVENT" - parse-calendar))) - -(test-assert "weekly TZ SEQUENCE LOCATION 10-12" - (stream-car (generate-recurrence-set ev))) - -(define ev - (car - (call-with-input-string - "BEGIN:VEVENT -DTSTART:20180117T170000 -RRULE:FREQ=WEEKLY -LOCATION:~ -END:VEVENT" - parse-calendar))) - -(test-assert "Just location" - (stream-car (generate-recurrence-set ev))) - -(define ev - (car - (call-with-input-string - "BEGIN:VEVENT -DTSTART;TZID=Europe/Stockholm:20180117T170000 -DTEND;TZID=Europe/Stockholm:20180117T200000 -RRULE:FREQ=WEEKLY -END:VEVENT" - parse-calendar))) - -(test-assert "Same times" - (stream-car (generate-recurrence-set ev))) - -(define ev - (car - (call-with-input-string - "BEGIN:VEVENT -DTSTART;TZID=Europe/Stockholm:20180117T170000 -RRULE:FREQ=WEEKLY -DTEND;TZID=Europe/Stockholm:20180117T200000 -SEQUENCE:1 -LOCATION:~ -END:VEVENT" - parse-calendar))) - -;; errer in dtend ? - -(test-assert "Full test" - (stream-car (generate-recurrence-set ev))) - -;;; Tests that exceptions (in the recurrence-id meaning) -;;; in recurrence sets are handled correctly. -;;; TODO Is however far from done. - -(define uid (symbol->string (gensym "areallyuniqueid"))) - -;; TODO standardize vcomponents for tests as xcal, for example: -`(vcalendar - (children - (vevent - (properties - (summary - (text "Changing type on Recurrence-id.")) - (uid (text ,uid)) - (dtstart (date "20090127")))) - (vevent - (properties - (summary - (text "Changing type on Recurrence-id.")) - (uid (text ,uid)) - (dtstart - (params (TZID "Europe/Stockholm")) - (date-time "20100127T120000")) - (recurrence-id (date "20100127")) - (summary - "This instance only has a time component"))))) - -(define ev - (call-with-input-string - (format - #f - "BEGIN:VCALENDAR -BEGIN:VEVENT -SUMMARY:Changing type on Recurrence-id. -UID:~a -DTSTART;VALUE=DATE:20090127 -END:VEVENT -BEGIN:VEVENT -UID:~a -SUMMARY:Changing type on Recurrence-id. -DTSTART;TZID=Europe/Stockholm:20100127T120000 -RECURRENCE-ID;VALUE=DATE:20100127 -SUMMARY:This instance only has a time component -END:VEVENT -END:VCALENDAR" - uid - uid) - parse-calendar)) - -(test-assert "Changing type on Recurrence id." - (stream->list 10 (generate-recurrence-set ev))) - -;;; Earlier I failed to actually parse the recurrence parts, in short, 1 ≠ "1". - -(test-assert "Test that xcal recur rules are parseable" - ((@@ (vcomponent formats xcal parse) handle-value) - 'recur - 'props-are-unused-for-recur - '((freq "WEEKLY") (interval "1") (wkst "MO")))) - -(define ev - (-> '(vevent - (properties - (summary (text "reptest")) - (dtend (date-time "2021-01-13T02:00:00")) - (dtstart (date-time "2021-01-13T01:00:00")) - (uid (text "RNW198S6QANQPV1C4FDNFH6ER1VZX6KXEYNB")) - (rrule (recur (freq "WEEKLY") - (interval "1") - (wkst "MO"))) - (dtstamp (date-time "2021-01-13T01:42:20Z")) - (sequence (integer "0"))) - (components)) - (sxml->namespaced-sxml `((#f . ,xcal))) - sxcal->vcomponent)) - -(test-assert - "Check that recurrence rule commint from xcal also works" - (generate-recurrence-set ev)) - - -;;; TODO test here, for byday parsing, and multiple byday instances in one recur element -;;; TODO which should also test serializing and deserializing to xcal. -;;; For example, the following rules specify every workday - -;; BEGIN:VCALENDAR
-;; PRODID:-//hugo//calp 0.6.1//EN
-;; VERSION:2.0
-;; CALSCALE:GREGORIAN
-;; BEGIN:VEVENT
-;; SUMMARY:Lunch
-;; DTSTART:20211129T133000
-;; DTEND:20211129T150000
-;; LAST-MODIFIED:20211204T220944Z
-;; UID:3d82c73c-6cdb-4799-beba-5f1d20d55347
-;; RRULE:FREQ=DAILY;BYDAY=MO,TU,WE,TH,FR
-;; END:VEVENT
-;; END:VCALENDAR
diff --git a/tests/test/rrule-serialization.scm b/tests/test/rrule-serialization.scm deleted file mode 100644 index e616c5a2..00000000 --- a/tests/test/rrule-serialization.scm +++ /dev/null @@ -1,75 +0,0 @@ -(define-module (test rrule-serialization) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((vcomponent recurrence internal) - :select (recur-rule->rrule-string - recur-rule->rrule-sxml - byday)) - :use-module ((vcomponent recurrence parse) - :select (parse-recurrence-rule)) - :use-module ((ice-9 peg) :select (keyword-flatten))) - -(test-equal - "Parse of week day" - '(#f . 3) - ((@@ (vcomponent recurrence parse) parse-day-spec) - "WE")) - -(test-equal - "Parse of week day with positive offset" - '(1 . 3) - ((@@ (vcomponent recurrence parse) parse-day-spec) - "1WE")) - -(test-equal - "Parse of week day with positive offset (and plus)" - '(2 . 3) - ((@@ (vcomponent recurrence parse) parse-day-spec) - "+2WE")) - -(test-equal - "Parse of week day with negative offset" - '(-3 . 3) - ((@@ (vcomponent recurrence parse) parse-day-spec) - "-3WE")) - - -;; numeric prefixes in the BYDAY list is only valid when -;; FREQ={MONTHLY,YEARLY}, but that should be handled in a -;; later stage since we are just testing the parser here. -;; (p. 41) - - -(define field->string - (@@ (vcomponent recurrence internal) - field->string)) - -(let ((rule (parse-recurrence-rule "BYDAY=MO,TU,WE"))) - (test-equal - "Direct return of parsed value" - "MO,TU,WE" - (field->string 'byday (byday rule))) - (test-equal - "Direct return, but as SXML" - '((byday "MO") (byday "TU") (byday "WE")) - (filter - (lambda (pair) (eq? 'byday (car pair))) - (keyword-flatten - '(interval byday wkst) - (recur-rule->rrule-sxml rule))))) - -(let ((rule (parse-recurrence-rule "BYDAY=+1MO,1TU,-2FR"))) - (test-equal - "Direct return of parsed value" - "1MO,1TU,-2FR" - (field->string 'byday (byday rule))) - (test-equal - "Direct return, but as SXML" - '((byday "1MO") (byday "1TU") (byday "-2FR")) - (filter - (lambda (pair) (eq? 'byday (car pair))) - (keyword-flatten - '(interval byday wkst) - (recur-rule->rrule-sxml rule))))) - - diff --git a/tests/test/server.scm b/tests/test/server.scm deleted file mode 100644 index a6200cb8..00000000 --- a/tests/test/server.scm +++ /dev/null @@ -1,28 +0,0 @@ -;;; Commentary: -;; Tests parse-endpoint-string, used for defining server routes. -;;; Code: - -(define-module (test server) - :use-module (srfi srfi-64) - :use-module (srfi srfi-71) - :use-module (srfi srfi-88) - :use-module ((web http make-routes) - :select (parse-endpoint-string))) - -(test-assert "Check that parsing doesn't crash" - (parse-endpoint-string "/static/:dir/:file")) - -;; Checks that parsing produces correct results -(test-group - "Simple parameters" - (let ((path args (parse-endpoint-string "/static/:dir/:file"))) - (test-equal "Path" "/static/([^/.]+)/([^/.]+)" path) - (test-equal "Parameters" '(dir file) args))) - -;; Checks that parsing with custom regex works -;; along with literal periods. -(test-group - "Custom regex for parameters" - (let ((path args (parse-endpoint-string "/static/:filename{.*}.:ext"))) - (test-equal "Path" "/static/(.*)\\.([^/.]+)" path) - (test-equal "Parameters" '(filename ext) args))) diff --git a/tests/test/srfi-41-util.scm b/tests/test/srfi-41-util.scm deleted file mode 100644 index 9a753b03..00000000 --- a/tests/test/srfi-41-util.scm +++ /dev/null @@ -1,108 +0,0 @@ -;;; Commentary: -;; Tests (srfi srfi-41 util). -;; Currently only tests stream-paginate. -;;; Code: - -(define-module (test srfi-41-util) - :use-module (srfi srfi-64) - :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" - '((0 1 2) (3 4 5) (6 7 8) (9)) - (let ((strm (stream-paginate (stream 0 1 2 3 4 5 6 7 8 9) 3))) - (map stream->list (stream->list strm)))) - -(test-equal "slice of infinite" - '(1000 1001 1002 1003 1004 1005 1006 1007 1008 1009) - (let ((strm (stream-paginate (stream-from 0)))) - (stream->list (stream-ref strm 100)))) - -(define unique-symbol (gensym)) - -(test-equal "time out on infinite 'empty' stream" - unique-symbol - ;; defined outside time limit since creation should always - ;; succeed. Only reference is expected to fail. - (let ((strm (stream-paginate - ;; easy way to get stream which never finds - ;; any elements. - (stream-filter negative? (stream-from 0))))) - (call-with-time-limit - 0.1 - (lambda () (stream-car strm)) - (lambda _ unique-symbol)))) - - - - -(test-equal "stream insert" - '(1 4 5 7 8) - (stream->list (stream-insert < 5 (stream 1 4 7 8)))) - - -(test-equal "Filter sorted stream" - '(4 6 8) - (stream->list (filter-sorted-stream even? (stream 1 3 4 6 8 9 11)))) - -(test-equal "Filter sorted stream (which actually is unsorted)" - '(4 6 8) - (stream->list (filter-sorted-stream even? (stream 1 3 4 6 8 9 11 12)))) - -;; TODO filter-sorted-stream* - -(test-equal - "Get stream interval" - '(5 6 7 8 9) - (stream->list (get-stream-interval (lambda (x) (< 4 x)) - (lambda (x) (< x 10)) - (stream 1 2 3 4 5 6 7 8 9 10 11 12)))) - - - -(test-equal "stream find" 2 (stream-find even? (stream-from 1))) - - -(test-equal - "repeating naturals" - '(1 1 1 2 2 2 3 3 3 4) - (stream->list 10 (repeating-naturals 1 3))) - - -;; sleep will return early if a singal arrives, this just resumes sleeping until -;; the wanted time is hit. -;; Might sleep longer since sleep always returns a whole number of seconds remaining -(define (true-sleep n) - (let loop ((remaining n)) - (unless (zero? remaining) - (loop (sleep remaining))))) - -(test-skip "time limited stream") - -(let ((strm (stream-map (lambda (x) (when (zero? (modulo x 4)) (true-sleep 1)) x) (stream-from 1)))) - (let ((strm (stream-timeslice-limit strm 0.1))) - (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/sxml-namespaced.scm b/tests/test/sxml-namespaced.scm deleted file mode 100644 index 55d52798..00000000 --- a/tests/test/sxml-namespaced.scm +++ /dev/null @@ -1,170 +0,0 @@ -(define-module (test sxml-namespaced) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module (ice-9 match) - :use-module (sxml namespaced) - :use-module (hnh util state-monad) - ) - -;;; TODO tests with attributes - -(define (ns x) - (string->symbol (format #f "http://example.com/~a" x))) - -(define (namespaced-symbol ns symb) - (string->symbol (format #f "~a:~a" ns symb))) - - - -(test-group "XML constructor utility procedure" - (test-equal "3 args" - (make-xml-element 'tagname 'namespace 'attributes) - (xml 'namespace 'tagname 'attributes)) - - (test-equal "2 args" - (make-xml-element 'tagname 'namespace '()) - (xml 'namespace 'tagname)) - - (test-equal "1 args" - (make-xml-element 'tagname #f '()) - (xml 'tagname))) - - - -(test-group "xml->namespaced-sxml" - - (test-equal - `(*TOP* (,(xml 'tag))) - (xml->namespaced-sxml "<tag/>")) - - (test-equal - `(*TOP* (,(xml 'ns1 'tag))) - (xml->namespaced-sxml "<tag xmlns='ns1'/>")) - - (test-equal - `(*TOP* (,(xml 'ns2 'tag))) - (xml->namespaced-sxml "<x:tag xmlns='ns1' xmlns:x='ns2'/>")) - - (test-equal - `(*TOP* (,(xml 'ns2 'tag) - (,(xml 'ns1 'tag)))) - (xml->namespaced-sxml "<x:tag xmlns='ns1' xmlns:x='ns2'><tag/></x:tag>")) - - (test-equal "PI are passed directly" - `(*TOP* ,(make-pi-element 'xml "encoding=\"utf-8\" version=\"1.0\"") - (,(xml 'tag))) - (xml->namespaced-sxml "<?xml encoding=\"utf-8\" version=\"1.0\"?><tag/>")) - - (test-equal "Document with whitespace in it" - `(*TOP* ,(make-pi-element 'xml "") - (,(xml 'root) - " " - (,(xml 'a)) - )) - (xml->namespaced-sxml "<?xml?><root> <a/></root>" - trim-whitespace?: #f)) - - ;; TODO is this expected? xml->sxml discards it. - (test-equal "Whitespace before root is kept" - `(*TOP* ,(make-pi-element 'xml "") - (,(xml 'root))) - (xml->namespaced-sxml "<?xml?> <root/>"))) - - - -;;; NOTE that sxml->namespaced-sxml currently ignores any existing xmlns -;;; attributes, since xml->sxml doesn't have those. -(test-group "sxml->namespaced-sxml" - (test-equal "Simplest" - `(,(xml 'a)) (sxml->namespaced-sxml '(a) '())) - (test-equal "With *TOP*" - `(*TOP* (,(xml 'a))) (sxml->namespaced-sxml '(*TOP* (a)) '())) - (test-equal "Simplest with namespace" - `(,(xml (ns 1) 'a)) - (sxml->namespaced-sxml '(x:a) - `((x . ,(ns 1))))) - (test-equal "With pi" - `(*TOP* ,(make-pi-element 'xml "test") - (,(xml 'a))) - (sxml->namespaced-sxml - `(*TOP* - (*PI* xml "test") - (a)) - '())) - (test-error "With unknown namespace" - 'missing-namespace - (sxml->namespaced-sxml '(x:a) '()))) - - - -(test-group "namespaced-sxml->*" - - ;; /namespaces is the most "primitive" one - (test-group "/namespaces" - (test-group "Without namespaces" - (call-with-values - (lambda () - (namespaced-sxml->sxml/namespaces - `(*TOP* - (,(xml 'a))))) - (lambda (tree namespaces) - (test-equal `(*TOP* (a)) tree) - (test-equal '() namespaces)))) - - (test-group "With namespaces" - (call-with-values - (lambda () - (namespaced-sxml->sxml/namespaces - `(*TOP* - (,(xml (ns 1) 'a) - (,(xml (ns 2) 'a)) - (,(xml 'a)))))) - (lambda (tree nss) - (test-eqv 2 (length nss)) - (test-equal - `(*TOP* - (,(namespaced-symbol (assoc-ref nss (ns 1)) 'a) - (,(namespaced-symbol (assoc-ref nss (ns 2)) 'a)) - (a))) - tree)))) - - (test-group "*PI*" - (call-with-values - (lambda () - (namespaced-sxml->sxml/namespaces - `(*TOP* - ,(make-pi-element 'xml "test") - (,(xml 'a))))) - (lambda (tree namespaces) - (test-equal '() namespaces) - (test-equal `(*TOP* (*PI* xml "test") - (a)) - tree))))) - - (test-group "namespaced-sxml->sxml" - (test-equal "Without namespaces" - '(*TOP* (a (@))) - (namespaced-sxml->sxml `(*TOP* (,(xml 'a))))) - - (test-group "With namespaces" - (match (namespaced-sxml->sxml `(*TOP* (,(xml (ns 1) 'a)))) - ;; (ns 1) hard coded to work with match - (`(*TOP* (,el (@ (,key "http://example.com/1")))) - (let ((el-pair (string-split (symbol->string el) #\:)) - (key-pair (string-split (symbol->string key) #\:))) - (test-equal "a" (cadr el-pair)) - (test-equal "xmlns" (car key-pair)) - (test-equal (car el-pair) (cadr key-pair)))) - (any - (test-assert (format #f "Match failed: ~s" any) #f)))))) - -;; (namespaced-sxml->xml) -;; Literal strings - - -(test-error "Namespaces x is missing, note error" - 'parser-error - (xml->namespaced-sxml "<x:a xmlns:y=\"http://example.com/1\"><x:b/></x:a>" - ; `((x . ,(ns 1))) - )) diff --git a/tests/test/termios.scm b/tests/test/termios.scm deleted file mode 100644 index 7f607cc4..00000000 --- a/tests/test/termios.scm +++ /dev/null @@ -1,48 +0,0 @@ -;;; Commentary: -;; Tests that my termios function works, at least somewhat. -;; Note that this actually modifies the terminal it's run on, and might fail -;; if the terminal doesn't support the wanted modes. See termios(3). -;; It might also leave the terminal in a broken state if exited prematurely. -;;; Code: - -(define-module (test termios) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((hnh util) :select (set!)) - :use-module ((vulgar termios) - :select (make-termios - copy-termios - lflag - tcgetattr! - tcsetattr! - ECHO - ICANON)) - :use-module ((srfi srfi-60) - :select ((bitwise-ior . ||) - (bitwise-not . ~) - (bitwise-and . &)))) - -(define tty (open-input-file "/dev/tty")) - -(define-syntax-rule (&= lvalue val) - (set! lvalue = ((lambda (v) (& v val))))) - -(define t (make-termios)) - -(test-equal 0 (tcgetattr! t tty)) - -(define ifl (lflag t)) - -(define copy (copy-termios t)) - -#!curly-infix {(lflag t) &= (~ (|| ECHO ICANON))} - -(test-equal 0 (tcsetattr! t tty)) - -(test-equal - (& ifl (~ (|| ECHO ICANON))) - (lflag t)) - -(test-equal 0 (tcsetattr! copy tty)) - - diff --git a/tests/test/timespec.scm b/tests/test/timespec.scm deleted file mode 100644 index 256c01bf..00000000 --- a/tests/test/timespec.scm +++ /dev/null @@ -1,88 +0,0 @@ -(define-module (test timespec) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module (datetime) - :use-module (datetime timespec)) - -(test-equal "The empty string parses to the empty timespec" - (timespec-zero) (parse-time-spec "")) - -(test-group "timespec-add" - - (test-equal "Zero operands gives 0" - (timespec-zero) (timespec-add)) - - (let ((ts (make-timespec #10:20:30 '- #\z))) - (test-equal "Single operand gives that operand" - ts (timespec-add ts))) - - (test-equal "0 + 0 = 0" - (timespec-zero) (timespec-add (timespec-zero) (timespec-zero))) - - (test-group - "+ -" - (test-equal "Remove a number less than the base" - (make-timespec #10:00:00 '+ #\w) - (timespec-add (make-timespec #10:20:30 '+ #\w) - (make-timespec #00:20:30 '- #\w))) - - (test-equal "Remove a number greater than the base" - (make-timespec #01:00:00 '- #\w) - (timespec-add (make-timespec #10:00:00 '+ #\w) - (make-timespec #11:00:00 '- #\w))) - - (test-equal "x + -x = 0" - (timespec-zero) (timespec-add (make-timespec #10:20:30 '+ #\w) - (make-timespec #10:20:30 '- #\w)))) - - (test-group "- +" - (test-equal "Add a number less than the (negative) base" - (make-timespec #10:00:00 '+ #\w) - (timespec-add (make-timespec #10:20:30 '- #\w) - (make-timespec #00:20:30 '+ #\w))) - - (test-equal "Add a number greater than the (negative) base" - (make-timespec #01:00:00 '- #\w) - (timespec-add (make-timespec #10:00:00 '- #\w) - (make-timespec #11:00:00 '+ #\w))) - - (test-equal "-x + x = 0" - (timespec-zero) (timespec-add (make-timespec #10:20:30 '- #\w) - (make-timespec #10:20:30 '+ #\w)))) - - (test-group "+ +" - (test-equal "x + x = 2x" - (make-timespec #20:41:00 '+ #\w) - (timespec-add (make-timespec #10:20:30 '+ #\w) - (make-timespec #10:20:30 '+ #\w)))) - - (test-group "- -" - (test-equal "-x + -x = -2x" - (make-timespec #20:41:00 '- #\w) - (timespec-add (make-timespec #10:20:30 '- #\w) - (make-timespec #10:20:30 '- #\w)))) - - ;; add more than two timespecs - - ;; add timespecs of differing types - ) - -(test-group "parse-time-spec" - ;; TODO what even is this case? - (test-equal (make-timespec (time) '+ #\g) (parse-time-spec "-g")) - - (test-equal "Parse direct date, with hour minute and second" - (make-timespec #20:00:00 '+ #\w) (parse-time-spec "20:00:00")) - (test-equal "Parse direct date, with hour and minute" - (make-timespec #20:00:00 '+ #\w) (parse-time-spec "20:00")) - (test-equal "Parse direct date, with just hour" - (make-timespec #20:00:00 '+ #\w) (parse-time-spec "20")) - - (test-equal "Parse timespec with letter at end" - (make-timespec #20:00:00 '+ #\g) (parse-time-spec "20:00g")) - - (test-equal "Parse negative timespec" - (make-timespec #20:00:00 '- #\w) (parse-time-spec "-20")) - - (test-equal "Parse negative timespec with letter at end" - (make-timespec #20:00:00 '- #\z) (parse-time-spec "-20z"))) diff --git a/tests/test/translation.scm b/tests/test/translation.scm deleted file mode 100644 index 5fb32ab0..00000000 --- a/tests/test/translation.scm +++ /dev/null @@ -1,15 +0,0 @@ -(define-module (test translation) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module (calp translation) - :use-module (ice-9 i18n)) - -(define sv (make-locale (list LC_CTYPE LC_MESSAGES) "sv_SE.UTF-8")) - -;; empty key should give us translation header -;; this also tests that translations are properly loaded -(test-assert "translations" (string? (translate ""))) - -(test-equal "yes-no yes" 'yes (yes-no-check "y" sv)) -(test-equal "yes-no no" 'no (yes-no-check "n" sv)) -(test-equal "yes-no invalid" #f (yes-no-check "other" sv)) diff --git a/tests/test/tz.scm b/tests/test/tz.scm deleted file mode 100644 index 00a611b3..00000000 --- a/tests/test/tz.scm +++ /dev/null @@ -1,87 +0,0 @@ -;;; Commentary: -;; Tests that datetime->unix-time correctly converts between Olssen -;; timezone definitions (e.g. Europe/Stockholm), into correct times -;; and offsets (in unix time). -;; Also indirectly tests the Zone Info Compiler (datetime zic), since -;; the zoneinfo comes from there. -;;; Code: - -(define-module (test tz) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((datetime) - :select (parse-ics-datetime - datetime - date - time - datetime->unix-time - unix-time->datetime - get-datetime)) - :use-module ((hnh util env) :select (let-env))) - -;; London alternates between +0000 and +0100 -(let-env - ((TZ "Europe/London")) - (test-equal - "London winter" - #2020-01-12T13:30:00 - (get-datetime - (parse-ics-datetime "20200112T133000Z"))) - (test-equal - "London summer" - #2020-06-12T14:30:00 - (get-datetime - (parse-ics-datetime "20200612T133000Z")))) - -;; Stockholm alternates between +0100 and +0200 -(let-env - ((TZ "Europe/Stockholm")) - (test-equal - "Stockholm winter" - #2020-01-12T14:30:00 - (get-datetime - (parse-ics-datetime "20200112T133000Z"))) - (test-equal - "Stockholm summer" - #2020-06-12T15:30:00 - (get-datetime - (parse-ics-datetime "20200612T133000Z")))) - -(test-equal - -10800 - (datetime->unix-time - (parse-ics-datetime - "19700101T000000" - "Europe/Tallinn"))) - -(test-equal - -3600 - (datetime->unix-time - (parse-ics-datetime - "19700101T000000" - "Europe/Stockholm"))) - -(test-equal - 0 - (datetime->unix-time - (parse-ics-datetime "19700101T000000Z"))) - -;; yes, really -(test-equal - -3600 - (datetime->unix-time - (parse-ics-datetime - "19700101T000000" - "Europe/London"))) - -(test-equal - (datetime - date: - #1970-01-01 - time: - #00:00:00 - tz: - "UTC") - (unix-time->datetime 0)) - - diff --git a/tests/test/uuid.scm b/tests/test/uuid.scm deleted file mode 100644 index 1cedb59e..00000000 --- a/tests/test/uuid.scm +++ /dev/null @@ -1,11 +0,0 @@ -(define-module (test uuid) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module (hnh util uuid)) - - -(test-equal "UUIDv4 fixed seed" - "d19c9347-9a85-4432-a876-5fb9c0d24d2b" - (parameterize ((seed (seed->random-state 0))) - (uuid-v4))) diff --git a/tests/test/vcomponent-control.scm b/tests/test/vcomponent-control.scm deleted file mode 100644 index cf6995bf..00000000 --- a/tests/test/vcomponent-control.scm +++ /dev/null @@ -1,36 +0,0 @@ -;;; Commentary: -;; Tests that with-replaced-properties work. -;;; Code: - -(define-module (test vcomponent-control) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module (vcomponent create) - :use-module ((vcomponent util control) - :select (with-replaced-properties)) - :use-module ((vcomponent formats ical parse) - :select (parse-calendar)) - :use-module ((vcomponent base) :select (prop))) - -(define ev (vcomponent 'DUMMY x-key: "value")) - -(test-group "With replaced properties" - ;; Test that temoraries are set and restored - (test-equal "value" (prop ev 'X-KEY)) - - (with-replaced-properties - (ev (X-KEY "other")) - (test-equal "other" (prop ev 'X-KEY))) - - (test-equal "value" (prop ev 'X-KEY))) - -;; Test that they are restored on non-local exit -(test-group "With replaced properties when throwing" - (catch #t - (lambda () - (with-replaced-properties - (ev (X-KEY "other")) - (throw 'any))) - (lambda _ (test-equal "value" (prop ev 'X-KEY))))) - - diff --git a/tests/test/vcomponent-datetime.scm b/tests/test/vcomponent-datetime.scm deleted file mode 100644 index 49d1711f..00000000 --- a/tests/test/vcomponent-datetime.scm +++ /dev/null @@ -1,43 +0,0 @@ -;;; Commentary: -;; Tests that event-clamping (checking how long part of an event -;; overlaps another time span) works. -;;; Code: - -(define-module (test vcomponent-datetime) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((datetime) :select (date time datetime)) - :use-module ((vcomponent datetime) :select (event-length/clamped)) - :use-module ((vcomponent create) :select (vevent))) - -(define ev - (vevent - dtstart: #2020-03-29T17:00:00 - dtend: #2020-04-01T10:00:00)) - - -;; |-----------------| test interval -;; |----------| event interval - -(test-equal - "Correct clamping" - (datetime time: (time hour: 7)) ; 2020-03-29T17:00 - 2020-03-30T00:00 - (event-length/clamped - #2020-03-23 ; a time way before the start of the event - #2020-03-29 ; a time slightly after the end of the event - ev)) - -(define utc-ev - (vevent - dtstart: #2020-03-29T15:00:00Z - dtend: #2020-04-01T08:00:00Z)) - -(test-equal - "Correct clamping UTC" - (datetime time: (time hour: 7)) - (event-length/clamped - #2020-03-23 - #2020-03-29 - ev)) - - diff --git a/tests/test/vcomponent-formats-common-types.scm b/tests/test/vcomponent-formats-common-types.scm deleted file mode 100644 index 4c442461..00000000 --- a/tests/test/vcomponent-formats-common-types.scm +++ /dev/null @@ -1,138 +0,0 @@ -(define-module (test vcomponent-formats-common-types) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module ((vcomponent formats common types) - :select (get-parser)) - :use-module ((datetime) :select (date time datetime))) - - - -(define parse-binary (get-parser 'BINARY)) -;; TODO - - - -(define parse-boolean (get-parser 'BOOLEAN)) - -(test-equal #t (parse-boolean #f "TRUE")) -(test-equal #f (parse-boolean #f "FALSE")) - -(test-error 'warning (parse-boolean #f "ANYTHING ELSE")) - - - -(define parse-cal-address - (get-parser 'CAL-ADDRESS)) - -(test-equal "Test uri is passthrough" - 74 (parse-cal-address #f 74)) - - - -(define parse-date (get-parser 'DATE)) - -(test-equal - #2021-12-02 - (parse-date #f "20211202")) -;; TODO negative test here - -(define parse-datetime (get-parser 'DATE-TIME)) - -(test-equal - #2021-12-02T10:20:30 - (parse-datetime - (make-hash-table) - "20211202T102030")) - -;; TODO tests with timezones here -;; TODO test -X-HNH-ORIGINAL here - -;; TODO negative test here - - - -(define parse-duration (get-parser 'DURATION)) - -;; assume someone else tests this one -;; (test-eq (@ (vcomponent duration) parse-duration) -;; parse-duration) - - - -(define parse-float (get-parser 'FLOAT)) - -(test-equal 1.0 (parse-float #f "1.0")) -(test-equal 1 (parse-float #f "1")) -(test-equal 1/2 (parse-float #f "1/2")) - -;; TODO negative test here? - - - -(define parse-integer (get-parser 'INTEGER)) - -(test-equal - "parse integer" - 123456 - (parse-integer #f "123456")) - -(test-equal - "parse bigint" - 123451234512345123456666123456 - (parse-integer - #f - "123451234512345123456666123456")) - -;; TODO is this expected behaivour? -(test-error 'warning (parse-integer #f "failure")) - -(test-error - "Non-integers aren't integers" - 'warning - (parse-integer #f "1.1")) - -(test-equal - "But exact floats are" - 1.0 - (parse-integer #f "1.0")) - - - -(define parse-period (get-parser 'PERIOD)) - -;; TODO - - - -(define parse-recur (get-parser 'RECUR)) - -;; (test-eq (@ (vcomponent recurrence parse) parse-recurrence-rule)) - - - -(define parse-text (get-parser 'TEXT)) - -;; TODO - - - -(define parse-time (get-parser 'TIME)) - -(test-equal - #10:20:30 - (parse-time #f "102030")) -;; TODO negative test here - - - -(define parse-uri (get-parser 'URI)) - -(test-equal "Test uri is passthrough" 74 (parse-uri #f 74)) - - - -(define parse-utc-offset - (get-parser 'UTC-OFFSET)) - -;; TODO diff --git a/tests/test/vcomponent.scm b/tests/test/vcomponent.scm deleted file mode 100644 index bdaefa95..00000000 --- a/tests/test/vcomponent.scm +++ /dev/null @@ -1,103 +0,0 @@ -;;; Commentary: -;; Test base functionallity of vcomponent structures. -;;; Code: - -(define-module (test vcomponent) - :use-module (srfi srfi-17) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module (hnh util table) - :use-module (datetime) - :use-module (vcomponent base)) - - - - -(define ev - (prop (vcomponent type: 'DUMMY) - 'X-KEY "value")) - -(test-eqv "Non-existant properties return #f" - #f (prop ev 'MISSING)) - -(test-assert "Existing property is non-false" - (prop ev 'X-KEY)) - -(test-equal "Getting value of existing property" - "value" (prop ev 'X-KEY)) - -(define calendar (add-child (vcomponent type: 'VCALENDAR) - ev)) - -(test-equal 1 (length (children calendar))) - -;;; TODO remove child -;; (abandon! calendar ev) -;; (test-equal 0 (length (children calendar))) - - - -(define vline* - (vline - key: 'DTSTART - vline-value: #2020-01-02 - vline-parameters: (alist->table - '((VALUE . "DATE"))) - vline-source: "DTSTART;VALUE=DATE:2020-01-02")) - -(test-group "vline" - (test-assert "Type check works as expected" - (vline? vline*))) - -(define vcomponent* - (vcomponent type: 'VEVENT)) - -(test-assert "Type check works as expected" - (vcomponent? vcomponent*)) - -(define child - (vcomponent type: 'CHILD)) - - -(test-eqv - "An added component extends length" - 1 (length (children (add-child vcomponent* child)))) - -(test-eqv - "But the source isn't modified" - 0 (length (children vcomponent*))) - -(test-equal "Setting property" - (list (list 'KEY (vline key: 'KEY vline-value: "Value"))) - (properties - (prop vcomponent* 'KEY "Value"))) - -(let ((vl (vline key: 'KEY vline-value: "Value"))) - (test-equal "Setting property vline" - (list (list 'KEY vl)) - (properties - (prop* vcomponent* 'KEY vl)))) - -(test-equal "Set properties test" - '(K1 K2) - (map car - (properties - (apply set-properties - vcomponent* - `((K1 . "V1") - (K2 . "V2")))))) - -;; remove-property - -;; extract extract* - - -;; remove-parameter -;; value -;; param - -;; parameters -;; properties - -;; x-property? -;; internal-field? diff --git a/tests/test/web-query.scm b/tests/test/web-query.scm deleted file mode 100644 index 0555258b..00000000 --- a/tests/test/web-query.scm +++ /dev/null @@ -1,34 +0,0 @@ -(define-module (test web-query) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((web query) :select (parse-query))) - -(test-equal "Empty query gives empty assoc list" - '() (parse-query "")) -(test-equal "Simple key-value query" - '(key: "value") (parse-query "key=value")) - -;; Slightly cumbersome check, since keys aren't ordered -(test-group - "Simple key-value query, with multiple keys" - (let ((kv-list (parse-query "k1=value&k2=1"))) - (test-equal "value" (and=> (memv k1: kv-list) cadr)) - (test-equal "1" (and=> (memv k2: kv-list) cadr)))) - -(test-equal "Values are HTTP-decoded" - '(key: " ") (parse-query "key=%20")) -(test-equal "Keys are HTTP-decoded" - '(A: "test") (parse-query "%41=test")) - -(test-equal "Query with only key, value becomes key" - '(key: "key") (parse-query "key")) - -(test-group - "Some with only key" - (let ((kv-list (parse-query "k1&k2=10"))) - (test-equal "k1" (and=> (memv k1: kv-list) cadr)) - (test-equal "10" (and=> (memv k2: kv-list) cadr)))) - -;; I don't know if HTTP allows this, but my code works like this -(test-equal "Value with equal in it" - '(key: "=") (parse-query "key==")) diff --git a/tests/test/web-server.scm b/tests/test/web-server.scm deleted file mode 100644 index 69d18536..00000000 --- a/tests/test/web-server.scm +++ /dev/null @@ -1,116 +0,0 @@ -;;; Commentary: -;; Checks that HTTP server can start correctly, and that at least some -;; endpoints return correct information. -;; -;; NOTE This test, when ran in as `tests/run-tests --only web-server.scm' -;; segfaults on Guile 2.2.7, but not on Guile 3.0.8. This doesn't happen -;; when it's run as one of all tests. -;;; Code: - -(define-module (test web-server) - :use-module (srfi srfi-64) - :use-module (srfi srfi-71) - :use-module (srfi srfi-88) - :use-module ((calp server routes) :select (make-make-routes)) - :use-module ((web server) :select (run-server)) - :use-module ((ice-9 threads) - :select (call-with-new-thread cancel-thread)) - :use-module ((web client) :select (http-get)) - :use-module ((web response) :select (response-code response-location)) - :use-module ((web uri) :select (build-uri uri-path)) - :use-module ((guile) - :select (socket - inet-pton - bind - make-socket-address - setsockopt - AF_INET - PF_INET - SOL_SOCKET - SO_REUSEADDR - SOCK_STREAM - current-error-port)) - :use-module ((ice-9 format) :select (format)) - :use-module ((web response) :select (build-response))) - -(define host "127.8.9.5") - -(define sock (socket PF_INET SOCK_STREAM 0)) - -(setsockopt sock SOL_SOCKET SO_REUSEADDR 1) - -(define-values - (port sock) - (let ((addr (inet-pton AF_INET host))) - (let loop ((port 8090)) - (catch 'system-error - (lambda () - (bind sock - (make-socket-address AF_INET addr port)) - (values port sock)) - (lambda (err proc fmt args data) - (if (and (not (null? data)) - ;; errno address already in use - (= 98 (car data))) - (loop (1+ port)) - ;; rethrow - (throw err fmt args data))))))) - -(define server-thread - (call-with-new-thread - (lambda () - (catch #t - (lambda () - (run-server - (make-make-routes) - 'http - `(socket: ,sock))) - (lambda args - (format #f "~s~%" args) - (test-assert "Server Crashed" #f))) - ;; This test should always fail, but should never be run - (test-assert "Server returned unexpectedly" #f)))) - -(let ((response - _ - (catch 'system-error - (lambda () - (http-get - (build-uri 'http host: host port: port))) - (lambda (err proc fmt args data) - (format - (current-error-port) - "~a (in ~a) ~?~%" - err - proc - fmt - args) - (values (build-response code: 500) #f))))) - (test-eqv - "Basic connect" - 200 - (response-code response))) - -(let ((response - body - (http-get - (build-uri - 'http - host: - host - port: - port - path: - "/today" - query: - "view=week&date=2020-01-04")))) - (test-eqv - "Redirect" - 302 - (response-code response)) - (test-equal - "Fully specified redirect position" - "/week/2020-01-04.html" - (uri-path (response-location response)))) - -(cancel-thread server-thread) diff --git a/tests/test/webdav-file.scm b/tests/test/webdav-file.scm deleted file mode 100644 index 4096016b..00000000 --- a/tests/test/webdav-file.scm +++ /dev/null @@ -1,53 +0,0 @@ -(define-module (test webdav-file) - :use-module (srfi srfi-64) - :use-module (srfi srfi-71) - :use-module (srfi srfi-88) - :use-module (hnh util) - :use-module (hnh util path) - :use-module (ice-9 ftw) - :use-module (ice-9 rdelim) - :use-module (oop goops) - :use-module (calp webdav resource) - :use-module (calp webdav resource file) - ) - -;;; Commentary: -;;; Tests the specifics of the file backed webdav resource objects. -;;; Code: - - -;;; TODO general helper procedure for this -(define test-root (mkdtemp (string-copy "/tmp/calp-test-XXXXXX"))) - -(define root-resource (make <file-resource> - root: test-root)) - - -(test-group "File resource collection" - (add-collection! root-resource "subdir") - (test-eqv "Collection correctly added" - 'directory (-> (path-append test-root "subdir") - stat stat:type) )) - - - -;;; TODO this fails, sice <file-resource> doesn't override add-resource! -;;; <file-resources>'s add resource must at least update root path path of the -;;; child resource, and possibly also touch the file (so ctime gets set). -(test-group "File resource with content" - (let ((fname "file.txt") - (s "Hello, World!\n")) - (add-resource! root-resource fname s) - (let ((p (path-append test-root fname))) - (test-eqv "File correctly added" - 'regular (-> p stat stat:type)) - (test-equal "Expected content was written" - s - (with-input-from-file p - (lambda () (read-delimited ""))) - )))) - - - -(test-group "Copy file" - 'TODO) diff --git a/tests/test/webdav-server.scm b/tests/test/webdav-server.scm deleted file mode 100644 index 67747de7..00000000 --- a/tests/test/webdav-server.scm +++ /dev/null @@ -1,351 +0,0 @@ -(define-module (test webdav-server) - ;; :use-module (srfi srfi-1) - ;; :use-module (ice-9 threads) - - :use-module (srfi srfi-64) - :use-module (srfi srfi-71) - :use-module (srfi srfi-88) - :use-module (calp server webdav) - :use-module (calp webdav resource) - :use-module ((calp webdav property) :select (propstat)) - :use-module (calp webdav resource virtual) - :use-module (calp namespaces) - :use-module (oop goops) - :use-module (web request) - :use-module (web response) - :use-module (web uri) - :use-module (sxml simple) - :use-module (sxml xpath) - :use-module (sxml namespaced) - :use-module (hnh util) - ) - -;;; Commentary: -;;; Tests that handlers for all HTTP Methods works correctly. -;;; Note that these tests don't have as goal to check that resources and -;;; properties work correctly. See (test webdav) and (test webdav-tree) for that. -;;; -;;; The namespaces http://ns.example.com/properties is intentionally given -;;; different prefixes everywhere, to ensure that namespaces are handled correctly. -;;; Code: - -(define prop-ns (string->symbol "http://ns.example.com/properties")) - -(root-resource (make <virtual-resource> name: "*root*")) -(add-resource! (root-resource) "a" "Contents of A") -(add-resource! (root-resource) "b" "Contents of B") - -;;; Connect output of one procedure to input of another -;;; Both producer and consumer should take exactly one port as argument -(define (connect producer consumer) - ;; (let ((in out (car+cdr (pipe)))) - ;; (let ((thread (begin-thread (consumer in)))) - ;; (producer out) - ;; (join-thread thread))) - - (call-with-input-string - (call-with-output-string producer) - consumer)) - -(define (xml->sxml* port) - (xml->sxml port namespaces: `((d . ,(symbol->string webdav)) - (y . ,(symbol->string prop-ns))))) - - - -(test-group "run-propfind" - (test-group "Working, depth 0" - (let* ((request (build-request - (string->uri "http://localhost/") - method: 'PROPFIND - headers: '((depth . 0)) - validate-headers?: #f)) - (head body (run-propfind '() request #f))) - (test-equal 207 (response-code head)) - (test-equal '(application/xml) - (response-content-type head)) - (test-assert (procedure? body)) - (let ((body* (connect body xml->sxml*))) - ;; Arbitrarily chosen resource - (test-equal "Resource gets returned as expected" - '((d:resourcetype (d:collection))) - ((sxpath '(// d:response - (d:propstat (// d:status (equal? "HTTP/1.1 200 OK"))) - // d:resourcetype)) - body*))))) - - (test-group "Depth: infinity" - (let* ((request (build-request - (string->uri "http://localhost/") - method: 'PROPFIND - headers: '((depth . infinity)) - validate-headers?: #f)) - (head body (run-propfind '() request #f))) - (test-equal 207 (response-code head)) - (test-equal '(application/xml) (response-content-type head)) - (test-assert (procedure? body)) - (let ((body* (connect body xml->sxml*))) - (test-equal - '("/" "/a" "/b") - (sort* ((sxpath '(// d:href *text*)) body*) - string<))))) - - (test-group "With body" - (let ((request (build-request (string->uri "http://localhost/") - method: 'PROPFIND - headers: '((depth . 0)) - validate-headers?: #f)) - (request-body "<?xml version=\"1.0\" encoding=\"utf-8\"?> -<propfind xmlns=\"DAV:\"> - <prop><resourcetype/></prop> -</propfind>")) - (let ((head body (run-propfind '() request request-body))) - (test-equal 207 (response-code head)) - (test-equal '(application/xml) (response-content-type head)) - (test-assert (procedure? body)) - (let ((body* (connect body xml->sxml*))) - (test-equal "We only get what we ask for" - '((d:prop (d:resourcetype (d:collection)))) - ((sxpath '(// d:response - (d:propstat (// d:status (equal? "HTTP/1.1 200 OK"))) - // d:prop)) - body*))))))) - - - -(test-group "run-proppatch" - (let ((request (build-request (string->uri "http://localhost/a") - method: 'PROPPATCH)) - (request-body (format #f "<?xml version=\"1.0\" encoding=\"utf-8\"?> -<propertyupdate xmlns=\"DAV:\" xmlns:x=\"~a\"> - <set> - <prop> - <displayname>New Displayname</displayname> - <x:test><x:content/></x:test> - </prop> - </set> - <!-- TODO test remove? --> -</propertyupdate>" prop-ns))) - (let ((response body (run-proppatch '("a") request request-body))) - (test-equal 207 (response-code response)) - (test-equal '(application/xml) (response-content-type response)) - (test-assert (procedure? body)) - ;; Commit the changes - (call-with-output-string body) - )) - - (let ((response body (run-propfind - '("a") - (build-request (string->uri "http://localhost/a") - method: 'PROPFIND - headers: '((depth . 0)) - validate-headers?: #f) - (format #f "<?xml version=\"1.0\" encoding=\"utf-8\"?> -<propfind xmlns=\"DAV:\" xmlns:z=\"~a\"> - <prop> - <displayname/> - <z:test/> - </prop> -</propfind>" prop-ns)))) - (test-equal 207 (response-code response)) - (test-equal '(application/xml) (response-content-type response)) - (test-assert (procedure? body)) - - ;; (format (current-error-port) "Here~%") - ;; ;; The crash is after here - ;; (body (current-error-port)) - - (let* ((body* (connect body xml->sxml*)) - (properties ((sxpath '(// d:response - (d:propstat (// d:status (equal? "HTTP/1.1 200 OK"))))) - body*))) - ;; ((@ (ice-9 format) format) (current-error-port) "Properties: ~y~%" properties) - (test-equal "Native active property is properly updated" - '("New Displayname") - ((sxpath '(// d:displayname *text*)) properties)) - (test-equal "Custom property is correctly stored and preserved" - '((y:test (y:content))) - ((sxpath '(// y:test)) properties)))) - - ;; TODO test proppatch atomicity - ) - - - -(test-group "run-options" - (let ((head body (run-options #f #f))) - (test-equal "options head" - (build-response - code: 200 - headers: `((dav . (1)) - (allow . (GET HEAD PUT MKCOL PROPFIND OPTIONS DELETE COPY MOVE)))) - head) - (test-equal "options body" - "" body))) - - - -(test-group "run-get" - (let ((head body (run-get '("a") - (build-request - (string->uri "http://localhost/a") - method: 'GET) - 'GET))) - (test-equal "Contents of A" body))) - - - -(test-group "run-put" - (test-group "Update existing resource" - (run-put '("a") - (build-request (string->uri "http://localhost/a") - method: 'PUT - port: (open-output-string)) - "New Contents of A") - - (let ((head body (run-get '("a") - (build-request - (string->uri "http://localhost/a") - method: 'GET) - 'GET))) - (test-equal "Put updates subsequent gets" - "New Contents of A" body))) - - (test-group "Create new resource" - (run-put '("c") - (build-request (string->uri "http://localhost/c") - method: 'PUT - port: (open-output-string)) - "Created Resource C") - (let ((head body (run-get '("c") - (build-request - (string->uri "http://localhost/c") - method: 'GET) - 'GET))) - (test-equal "Put creates new resources" - "Created Resource C" body)))) - - - -;;; Run DELETE -(test-group "run-delete" - 'TODO) - - - - -(test-group "run-mkcol" - (run-mkcol '("a" "b") - (build-request (string->uri "http://localhost/a/b") - method: 'MKCOL) - "") - (let* ((request (build-request - (string->uri "http://localhost/") - method: 'PROPFIND - headers: '((depth . infinity)) - validate-headers?: #f)) - (head body (run-propfind '() request #f))) - (test-equal 207 (response-code head)) - (test-equal '(application/xml) (response-content-type head)) - (test-assert (procedure? body)) - (let ((body* (connect body xml->sxml*))) - (test-equal "Check that all created resources now exists" - '("/" "/a" "/a/b" "/b" "/c") - (sort* ((sxpath '(// d:href *text*)) body*) - string<))))) - - -;;; TODO test MKCOL indempotence - - - -;;; Run COPY -(test-group "run-copy" - (parameterize ((root-resource (make <virtual-resource> name: "*root*"))) - (add-resource! (root-resource) "a" "Content of A") - (let ((a (lookup-resource (root-resource) '("a")))) - (set-property! a `(,(xml prop-ns 'test) "prop-value")) - ;; Extra child added to ensure deep copy works - (add-resource! a "d" "Content of d")) - - (test-group "cp /a /c" - (let ((response _ - (run-copy '("a") - (build-request - (string->uri "http://example.com/a") - headers: `((destination - . ,(string->uri "http://example.com/c"))))))) - ;; Created - (test-eqv "Resource was reported created" - 201 (response-code response))) - - (let ((c (lookup-resource (root-resource) '("c")))) - (test-assert "New resource present in tree" c) - (test-equal "Content was correctly copied" - "Content of A" (content c)) - (test-equal "Property was correctly copied" - (propstat 200 - (list `(,(xml prop-ns 'test) - "prop-value"))) - (get-property c (xml prop-ns 'test))))) - - (test-group "cp --no-clobber /c /a" - (let ((response _ - (run-copy '("c") - (build-request - (string->uri "http://example.com/c") - headers: `((destination - . ,(string->uri "http://example.com/a")) - (overwrite . #f)))))) - ;; collision - (test-eqv "Resource collision was reported" - 412 (response-code response)))) - - ;; Copy recursive collection, and onto child of self. - (test-group "cp -r / /c" - (let ((response _ - (run-copy '() - (build-request - (string->uri "http://example.com/") - headers: `((destination . ,(string->uri "http://example.com/c"))))))) - (test-eqv "Check that reported replaced" - 204 (response-code response)) - (test-equal "Check that recursive resources where created" - '("/" "/a" "/a/d" "/c" - ;; New resources. Note that /c/c doesn't create an infinite loop - "/c/a" "/c/a/d" "/c/c") - (map car - (sort* (map (lambda (p) (cons (href->string (car p)) (cdr p))) - (all-resources-under (root-resource) '())) - string< car))) - - ;; TODO we should also check that /c is a copy of the root resource, - ;; instead of the old /c resource. - ;; Do this by setting some properties - )))) - - - -;;; Run MOVE -(test-group "run-move" - (parameterize ((root-resource (make <virtual-resource> name: "*root*"))) - (add-resource! (root-resource) "a" "Content of A") - (let ((a (lookup-resource (root-resource) '("a")))) - (set-property! a `(,(xml prop-ns 'test) "prop-value"))) - - (test-group "mv /a /c" - (let ((response _ - (run-move '("a") - (build-request - (string->uri "http://example.com/a") - headers: `((destination - . ,(string->uri "http://example.com/c"))))))) - ;; Created - (test-eqv "Resource was reported created" - 201 (response-code response)) - ;; TODO check that old resource is gone - )))) - - - -;;; Run REPORT diff --git a/tests/test/webdav-tree.scm b/tests/test/webdav-tree.scm deleted file mode 100644 index 5c2a6a9b..00000000 --- a/tests/test/webdav-tree.scm +++ /dev/null @@ -1,89 +0,0 @@ -(define-module (test webdav-tree) - :use-module (srfi srfi-64) - :use-module (srfi srfi-71) - :use-module (srfi srfi-88) - :use-module (calp webdav resource) - :use-module (calp webdav resource virtual) - :use-module (calp webdav resource file) - :use-module (oop goops) - :use-module (rnrs bytevectors) - :use-module (rnrs io ports) - :use-module ((hnh util) :select (sort*)) - :use-module (hnh util path) - ) - -(define* (pretty-print-tree tree - optional: (formatter (lambda (el) (write el) (newline))) - key: (depth 0)) - (cond ((null? tree) 'noop) - ((pair? tree) - (display (make-string (* depth 2) #\space)) (formatter (car tree)) - (for-each (lambda (el) (pretty-print-tree el formatter depth: (+ depth 1))) - (cdr tree))) - (else (formatter tree)))) - -(define-method (resource-tree (self <resource>)) - (cons self - (map resource-tree (children self)))) - - - -(define dir (mkdtemp (string-copy "/tmp/webdav-tree-XXXXXX"))) -(with-output-to-file (path-append dir "greeting") - (lambda () (display "Hello, World!\n"))) - -(define root-resource (make <virtual-resource> - name: "*root*")) - -(define virtual-resource (make <virtual-resource> - name: "virtual" - content: (string->bytevector "I'm Virtual!" (native-transcoder)))) - -(define file-tree (make <file-resource> - root: dir - name: "files")) - -(mount-resource! root-resource file-tree) -(mount-resource! root-resource virtual-resource) - -(test-equal "All resources in tree, along with href items" - (list (cons '() root-resource) - (cons '("files") file-tree) - (cons '("files" "greeting") (car (children file-tree))) - (cons '("virtual") virtual-resource)) - (sort* (all-resources-under root-resource) string< (compose string-concatenate car))) - - - -;; (pretty-print-tree (resource-tree root-resource)) - - - -;; (test-equal '("") (href root-resource) ) ; / -;; ;; (test-equal '("" "virtual") (href virtual-resource)) ; /virtual & /virtual/ -;; (test-equal '("virtual") (href virtual-resource)) ; /virtual & /virtual/ -;; ;; (test-equal '("" "files") (href file-tree)) ; /files & /files/ -;; (test-equal '("files") (href file-tree)) ; /files & /files/ - -(test-eqv "Correct amount of children are mounted" - 2 (length (children root-resource))) - -(test-eq "Lookup root" - root-resource (lookup-resource root-resource '())) - -(test-eq "Lookup of mount works (virtual)" - virtual-resource (lookup-resource root-resource '("virtual"))) -(test-eq "Lookup of mount works (files)" - file-tree (lookup-resource root-resource '("files"))) - -;; (test-equal "File resource works as expected" -;; "/home/hugo/tmp" -;; (path file-tree)) - -(let ((resource (lookup-resource root-resource (string->href "/files/greeting")))) - (test-assert (resource? resource)) - (test-assert (file-resource? resource)) - ;; (test-equal "/files/greeting" (href->string (href resource))) - (test-equal "Hello, World!\n" (bytevector->string (content resource) (native-transcoder))) - ) - diff --git a/tests/test/webdav-util.scm b/tests/test/webdav-util.scm deleted file mode 100644 index 5c89cf6c..00000000 --- a/tests/test/webdav-util.scm +++ /dev/null @@ -1,29 +0,0 @@ -(define-module (test webdav-util) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-71) - :use-module (srfi srfi-88) - :use-module (calp webdav resource base)) - -(test-group "string->href" - (test-equal "Root path becomes null" - '() (string->href "/")) - (test-equal "Trailing slashes are ignored" - '("a" "b") (string->href "/a/b/"))) - -(test-group "href->string" - (test-equal "Null case becomes root path" - "/" (href->string '())) - (test-equal "Trailing slashes are not added" - "/a/b" (href->string '("a" "b")))) - -(test-group "href-relative" - (test-equal '("a" "b") (href-relative '() '("a" "b"))) - (test-equal '("b") (href-relative '("a") '("a" "b"))) - (test-equal '() (href-relative '("a" "b") '("a" "b"))) - - (test-error 'misc-error - (href-relative '("c") '("a" "b"))) - - (test-error 'misc-error - (href-relative '("c") '()))) diff --git a/tests/test/webdav.scm b/tests/test/webdav.scm deleted file mode 100644 index 0962a89e..00000000 --- a/tests/test/webdav.scm +++ /dev/null @@ -1,353 +0,0 @@ -(define-module (test webdav) - :use-module (srfi srfi-64) - :use-module (srfi srfi-71) - :use-module (srfi srfi-88) - :use-module (srfi srfi-1) - :use-module (sxml namespaced) - :use-module (oop goops) - :use-module (calp namespaces) - :use-module ((hnh util) :select (sort*)) - :use-module (datetime) - - :use-module (calp webdav property) - :use-module (calp webdav propfind) - :use-module (calp webdav resource) - :use-module (calp webdav resource virtual) - ) - -;;; NOTE these tests don't check that XML namespaces work correctly, but only as -;;; far as not checking that the correct namespace is choosen. They should fail if -;;; namespacing gets completely broken. - -;;; TODO tests for a missing resource? - -(define (swap p) (xcons (car p) (cdr p))) - -(define dt #2010-11-12T13:14:15) - -(define resource (make <virtual-resource> - ;; local-path: '("") - name: "*root" - content: #vu8(1 2 3 4) - creation-time: dt)) - -(define (sort-propstats propstats) - (map - (lambda (propstat) - (make-propstat (propstat-status-code propstat) - (sort* (propstat-property propstat) - string< (compose symbol->string xml-element-tagname car)) - (propstat-error propstat) - (propstat-response-description propstat))) - (sort* propstats < propstat-status-code)) - ) - -;; (test-equal "/" (href->string (href resource))) -(test-equal "Basic propstat" - (propstat 200 (list (list (xml webdav 'getcontentlength) 4))) - (getcontentlength resource)) - - -(define (sort-symbols symbs) - (sort* symbs string<=? symbol->string)) - - - -;;; NOTE propstat's return order isn't stable, making this test possibly fail -(let ((ps (list (propstat 200 (list `(,(xml webdav 'displayname) "Displayname"))) - (propstat 200 (list `(,(xml webdav 'getcontenttype) "text/plain")))))) - (test-equal "Propstat merger" - (list (propstat 200 - (list (list (xml webdav 'getcontenttype) "text/plain") - (list (xml webdav 'displayname) "Displayname")))) - (merge-propstats ps))) - - - -(test-group "All live properties" - (let ((props (live-properties resource))) - (test-assert (list? props)) - (for-each (lambda (pair) - ;; (test-assert (xml-element? (car pair))) - (test-assert (live-property? (cdr pair))) - (test-assert (procedure? (property-getter (cdr pair)))) - (test-assert (procedure? (property-setter-generator (cdr pair))))) - props))) - -(test-group "\"All\" live properties" - (let ((most (propfind-most-live-properties resource))) - (test-equal "Correct amount of keys" 10 (length most)) - (for-each (lambda (propstat) - (test-assert "Propstat is propstat" (propstat? propstat)) - (test-equal (format #f "Propstat well formed: ~a" (propstat-property propstat)) - 1 (length (propstat-property propstat))) - (test-assert "Propstat child is xml" - (xml-element? (caar (propstat-property propstat))))) - most) - - (test-equal "Correct keys" - '(creationdate displayname getcontentlanguage getcontentlength - getcontenttype getetag getlastmodified - lockdiscovery resourcetype supportedlock) - (sort-symbols (map (compose xml-element-tagname caar propstat-property) most))))) - - - -(define ns1 (string->symbol "http://example.com/namespace")) - -(set-dead-property! resource `(,(xml ns1 'test) "Content")) - -(test-equal "Get dead property" - (propstat 200 (list (list (xml ns1 'test) "Content"))) - (get-dead-property resource (xml ns1 'test))) - -(test-equal "Get live property" - (propstat 404 (list (list (xml ns1 'test)))) - (get-live-property resource (xml ns1 'test))) - -(test-group "Dead properties" - (test-equal "Existing property" - (propstat 200 (list (list (xml ns1 'test) "Content"))) - (get-property resource (xml ns1 'test))) - - (test-equal "Missing property" - (propstat 404 (list (list (xml ns1 'test2)))) - (get-property resource (xml ns1 'test2))) - - (test-equal "All dead properties" - (list (propstat 200 (list (list (xml ns1 'test) "Content")))) - (propfind-all-dead-properties resource))) - -(test-group "Live Properties" - - ;; TODO these tests were written when displayname always returned 200, but have since changed to test for 404. - ;; Change to another property which return 200 - (test-equal "Existing live property (through get-live-property)" - (propstat 404 `((,(xml webdav 'displayname)))) - (get-live-property resource (xml webdav 'displayname))) - - (test-equal "Existing live property (thrtough get-property)" - (propstat 404 `((,(xml webdav 'displayname)))) - (get-property resource (xml webdav 'displayname))) - ) - -(test-equal "propfind-selected-properties" - (list (propstat 404 `((,(xml webdav 'displayname))))) - (propfind-selected-properties resource (list (xml webdav 'displayname)))) - -(test-group "parse-propfind" - (test-group "propname" - (let ((props (parse-propfind `(,(xml webdav 'propfind) - (,(xml webdav 'propname))) - resource))) - - - (test-group "Propfind should NEVER fail for an existing resource" - (test-equal 1 (length props)) - (test-equal 200 (propstat-status-code (car props)))) - - (test-assert "Propstat objects are returned" (propstat? (car props))) - (for-each (lambda (el) - (test-assert "Base is list" (list? el)) - (test-eqv "List only contains head el" 1 (length el)) - #; - (test-assert (format #f "Head is an xml tag: ~a" el) - (xml-element? (car el)))) - (propstat-property (car props))) - - #; - (test-equal "Correct property keys" - (sort-symbols (cons* 'test 'is-virtual webdav-keys)) - (sort-symbols (map (compose xml-element-tagname car) - (propstat-property (car props))))) - - (test-group "No property should contain any data" - (for-each (lambda (el) - (test-eqv (format #f "Propname property: ~s" el) - 1 (length el))) - (propstat-property (car props)))))) - - - (test-group "direct property list" - (let ((props (parse-propfind `((xml webdav 'propfind) - (,(xml webdav 'prop) - (,(xml webdav 'displayname)))) - resource))) - (test-equal "Simple lookup" - (list (propstat 404 (list (list (xml webdav 'displayname) - )))) - props))) - - ;; TODO test that calendar properties are reported by propname - ;; TODO test that non-native caldav propreties aren't reported by allprop - - (test-group "allprop" - (let ((props (parse-propfind `(,(xml webdav 'propfind) - (,(xml webdav 'allprop))) - resource))) - - - (test-equal "Propfind result" - (list - (propstat 200 - (list (list (xml webdav 'creationdate) - (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) - (list (xml webdav 'getcontentlength) - 4) - (list (xml webdav 'getcontenttype) - "application/binary") - (list (xml webdav 'getlastmodified) - "Thu, 01 Jan 1970 00:00:00 GMT") - (list (xml webdav 'lockdiscovery) '()) - (list (xml webdav 'resourcetype) - ; (list (xml webdav 'collection)) - ) - (list (xml webdav 'supportedlock) '()) - (list (xml ns1 'test) "Content") - )) - (propstat 404 (list (list (xml webdav 'displayname)) - (list (xml webdav 'getcontentlanguage)))) - (propstat 501 - (list (list (xml webdav 'getetag)) - ))) - (sort-propstats props)))) - - - (test-group "allprop with include" - (let ((props (parse-propfind `((xml webdav 'propfind) - (,(xml webdav 'allprop)) - (,(xml webdav 'include))) - resource))) - - - (test-equal "Include NOTHING" - (list - (propstat 200 - (list (list (xml webdav 'creationdate) - (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) - (list (xml webdav 'getcontentlength) - 4) - (list (xml webdav 'getcontenttype) - "application/binary") - (list (xml webdav 'getlastmodified) - "Thu, 01 Jan 1970 00:00:00 GMT") - (list (xml webdav 'lockdiscovery) '()) - (list (xml webdav 'resourcetype) - ; (list (xml webdav 'collection)) - ) - (list (xml webdav 'supportedlock) '()) - (list (xml ns1 'test) "Content") - )) - (propstat 404 (list (list (xml webdav 'displayname)) - (list (xml webdav 'getcontentlanguage)))) - (propstat 501 - (list (list (xml webdav 'getetag)) - ))) - (sort-propstats props))) - - - (let ((props (parse-propfind `(,(xml webdav 'propfind) - (,(xml webdav 'allprop)) - (,(xml webdav 'include) - (,(xml virtual-ns 'isvirtual)))) - resource))) - - (test-equal "Include isvirtual" - (list - (propstat 200 - (list (list (xml webdav 'creationdate) (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) - (list (xml webdav 'getcontentlength) 4) - (list (xml webdav 'getcontenttype) "application/binary") - (list (xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") - (list (xml virtual-ns 'isvirtual) "true") - (list (xml webdav 'lockdiscovery) '()) - (list (xml webdav 'resourcetype)) - (list (xml webdav 'supportedlock) '()) - (list (xml ns1 'test) "Content") - )) - (propstat 404 (list (list (xml webdav 'displayname)) - (list (xml webdav 'getcontentlanguage)))) - (propstat 501 - (list (list (xml webdav 'getetag)) - ))) - (sort-propstats props))))) - - - - -;;; Setting properties - -;;; We already use set-dead-property! above, but for testing get we need set, -;;; and for testing set we need get, and get is more independent, so we start there. - - - -(test-group "Propstat -> namespaced sxml" - (test-equal "Simple" - `(,(xml webdav 'propstat) - (,(xml webdav 'prop) (,(xml webdav 'displayname) "test")) - (,(xml webdav 'status) "HTTP/1.1 200 OK")) - (propstat->namespaced-sxml (propstat 200 `((,(xml webdav 'displayname) "test")) ))) - - ;; TODO populated error field - - (test-equal "With response description" - `(,(xml webdav 'propstat) - (,(xml webdav 'prop) (,(xml webdav 'displayname) "test")) - (,(xml webdav 'status) "HTTP/1.1 403 Forbidden") - (,(xml webdav 'responsedescription) "Try logging in")) - (propstat->namespaced-sxml (propstat 403 `((,(xml webdav 'displayname) "test")) - responsedescription: "Try logging in")))) - - - - -;;; TODO what am I doing here? - -(test-equal - (list (propstat 200 - `((,(xml webdav 'getcontentlength) 4) - (,(xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") - (,(xml webdav 'resourcetype)))) - (propstat 404 - `((,(xml webdav 'checked-in)) - (,(xml webdav 'checked-out)) - (,(xml (string->symbol "http://apache.org/dav/props/") 'executable))))) - (let ((request (xml->namespaced-sxml - "<?xml version=\"1.0\" encoding=\"utf-8\"?> -<propfind xmlns=\"DAV:\"> - <prop> - <getcontentlength/> - <getlastmodified/> - <executable xmlns=\"http://apache.org/dav/props/\"/> - <resourcetype/> - <checked-in/> - <checked-out/> - </prop> -</propfind>"))) - - (sort-propstats (parse-propfind (caddr request) resource)))) - - - -(test-group "lookup-resource" - (let* ((root (make <virtual-resource> name: "*root*")) - (a (add-collection! root "a")) - (b (add-collection! a "b")) - (c (add-resource! b "c" "~~Nothing~~"))) - (test-eq "Lookup root" - root (lookup-resource root '())) - (test-eq "Lookup direct child" - a (lookup-resource root '("a"))) - (test-eq "Lookup deep child" - c (lookup-resource root '("a" "b" "c"))) - (test-assert "Lookup missing" - (not (lookup-resource root '("a" "d" "c")))))) - - - - -(test-group "mkcol" - (let ((root (make <virtual-resource> name: "*root*"))) - (add-collection! root "child") - (test-eqv "Child got added" 1 (length (children root))))) diff --git a/tests/test/xdg-basedir.scm b/tests/test/xdg-basedir.scm deleted file mode 100644 index 682c1347..00000000 --- a/tests/test/xdg-basedir.scm +++ /dev/null @@ -1,58 +0,0 @@ -(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/test/xml-namespace.scm b/tests/test/xml-namespace.scm deleted file mode 100644 index 09402ceb..00000000 --- a/tests/test/xml-namespace.scm +++ /dev/null @@ -1,36 +0,0 @@ -(define-module (test xml-namespace) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((sxml namespace) :select (move-to-namespace))) - -(test-equal - "Move unnamespaced to namespace" - '(NEW:test) - (move-to-namespace '(test) '((#f . NEW)))) - -(test-equal - "Swap namespaces" - '(b:a (a:b)) - (move-to-namespace - '(a:a (b:b)) - '((a . b) (b . a)))) - -(test-equal - "Remove all namespaces" - '(a (b)) - (move-to-namespace '(a:a (b:b)) #f)) - -(test-equal - "Move everything to one namespace" - '(c:a (c:b)) - (move-to-namespace '(a:a (b:b)) 'c)) - -(test-equal - "Partial namespace change" - '(c:a (b:b)) - (move-to-namespace '(a:a (b:b)) '((a . c)))) - -(test-equal - "Remove specific namespace" - '(a:a (b)) - (move-to-namespace '(a:a (b:b)) '((b . #f)))) diff --git a/tests/test/zic.scm b/tests/test/zic.scm deleted file mode 100644 index 99247cf1..00000000 --- a/tests/test/zic.scm +++ /dev/null @@ -1,317 +0,0 @@ -(define-module (test zic) - :use-module ((srfi srfi-1) :select (every)) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module (datetime) - :use-module (datetime timespec) - :use-module (datetime zic)) - - -(test-expect-fail "Simple Leap") -(test-expect-fail "Simple Expire") - -(define big-sample - "# Rule NAME FROM TO - IN ON AT SAVE LETTER/S -Rule Swiss 1941 1942 - May Mon>=1 1:00 1:00 S -Rule Swiss 1941 1942 - Oct Mon>=1 2:00 0 - -Rule EU 1977 1980 - Apr Sun>=1 1:00u 1:00 S -Rule EU 1977 only - Sep lastSun 1:00u 0 - -Rule EU 1978 only - Oct 1 1:00u 0 - -Rule EU 1979 1995 - Sep lastSun 1:00u 0 - -Rule EU 1981 max - Mar lastSun 1:00u 1:00 S -Rule EU 1996 max - Oct lastSun 1:00u 0 - - -# Zone NAME STDOFF RULES FORMAT [UNTIL] -Zone Europe/Zurich 0:34:08 - LMT 1853 Jul 16 - 0:29:45.50 - BMT 1894 Jun - 1:00 Swiss CE%sT 1981 - 1:00 EU CE%sT - -Link Europe/Zurich Europe/Vaduz -") - -(define parse-zic-file (@@ (datetime zic) parse-zic-file)) - -;; Some of the tests are slightly altered to score better on the coverage -(test-group "From zic(8)" - (test-equal "Basic Rule" - (list ((@@ (datetime zic) make-rule) - 'US 1967 1973 4 '(last 0) - ((@ (datetime zic) make-timespec) #02:00:00 '+ #\w) - ((@ (datetime zic) make-timespec) #01:00:00 '+ #\d) - "D")) - (call-with-input-string "Rule US 1967 1973 - Apr lastSun 2:00w 1:00d D" - parse-zic-file)) - - ;; Technically not from zic(8), since that example has an until field - (test-equal "Basic Zone" - (list ((@@ (datetime zic) make-zone) "Asia/Amman" - (list ((@@ (datetime zic) make-zone-entry) - (make-timespec #02:00:00 '+ #\w) - 'Jordan "EE%sT" #f)))) - - (call-with-input-string - "Zone Asia/Amman 2:00 Jordan EE%sT" - parse-zic-file)) - - ;; Modified from the following example - (test-equal "Basic Zone with continuation" - (list ((@@ (datetime zic) make-zone) "America/Menominee" - (list ((@@ (datetime zic) make-zone-entry) - (make-timespec #05:00:00 '- #\w) - #f "EST" #1973-04-29T02:00:00) - ((@@ (datetime zic) make-zone-entry) - (make-timespec #06:00:00 '- #\w) - 'US "C%sT" #f)))) - ;; Why can't I single read a zone with an until field? - (call-with-input-string - "Zone America/Menominee -5:00 - EST 1973 Apr 29 2:00 - -6:00 US C%sT" - parse-zic-file)) - - - (test-equal "Rules and Zone" - (list ((@@ (datetime zic) make-zone) "America/Menominee" - (list ((@@ (datetime zic) make-zone-entry) - (make-timespec #05:00:00 '- #\w) - #f "EST" #1973-04-29T02:00:00) - ((@@ (datetime zic) make-zone-entry) - (make-timespec #06:00:00 '- #\w) - 'US "C%sT" #f))) - ((@@ (datetime zic) make-rule) - 'US 1967 1973 dec '(last 0) - (make-timespec #02:00:00 '+ #\w) - (make-timespec #01:00:00 '+ #\w) - "D") - ((@@ (datetime zic) make-rule) - 'US 1967 2006 nov '(last 0) - (make-timespec #02:00:00 '+ #\w) - (make-timespec #00:00:00 '+ #\w) - "S")) - (call-with-input-string - "# Rule NAME FROM TO - IN ON AT SAVE LETTER/S -Rule US 1967 2006 - Nov lastSun 2:00 0 S -Rule US 1967 1973 - Dec lastSun 2:00 1:00 D -# Zone NAME STDOFF RULES FORMAT [UNTIL] -Zone America/Menominee -5:00 - EST 1973 Apr 29 2:00 - -6:00 US C%sT -" parse-zic-file)) - - - (test-equal "Simple Link" - (list ((@@ (datetime zic) make-link) "Asia/Istanbul" "Europe/Istanbul")) - (call-with-input-string "Link Europe/Istanbul Asia/Istanbul" - parse-zic-file)) - - (test-equal "Simple Leap" - 'not-yet-implemented - (call-with-input-string "Leap 2016 Dec 31 23:59:60 + S" - parse-zic-file)) - - (test-equal "Simple Expire" - 'not-yet-implemented - (call-with-input-string "Expires 2020 Dec 28 00:00:00" - parse-zic-file)) - - - (test-equal "Extended example" - ;; Items are in reverse order of discovery - (list ((@@ (datetime zic) make-link) "Europe/Vaduz" "Europe/Zurich") - ((@@ (datetime zic) make-zone) "Europe/Zurich" - (list ((@@ (datetime zic) make-zone-entry) - (make-timespec #00:34:08 '+ #\w) - #f "LMT" #1853-07-16T00:00:00) - ((@@ (datetime zic) make-zone-entry) - (make-timespec #00:29:45 '+ #\w) ; NOTE that the .50 is discarded - #f "BMT" #1894-06-01T00:00:00) - ((@@ (datetime zic) make-zone-entry) - (make-timespec #01:00:00 '+ #\w) - 'Swiss "CE%sT" #1981-01-01T00:00:00) - ((@@ (datetime zic) make-zone-entry) - (make-timespec #01:00:00 '+ #\w) - 'EU "CE%sT" #f))) - ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 '(last 0) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - "") - ((@@ (datetime zic) make-rule) 'EU 1981 'maximum 3 '(last 0) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #01:00:00 '+ #\w) - "S") - ((@@ (datetime zic) make-rule) 'EU 1979 1995 9 `(last ,sun) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - "") - ((@@ (datetime zic) make-rule) 'EU 1978 'only 10 1 - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - "") - ((@@ (datetime zic) make-rule) 'EU 1977 'only 9 `(last ,sun) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - "") - ((@@ (datetime zic) make-rule) 'EU 1977 1980 4 `(> ,sun 1) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #01:00:00 '+ #\w) - "S") - ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 10 `(> ,mon 1) - (make-timespec #02:00:00 '+ #\w) - (make-timespec #00:00:00 '+ #\w) - "") - ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 5 `(> ,mon 1) - (make-timespec #01:00:00 '+ #\w) - (make-timespec #01:00:00 '+ #\w) - "S")) - (call-with-input-string big-sample - parse-zic-file))) - -(test-group "rule->dtstart" - (test-equal "last sunday" - #1967-04-30T02:00:00 - (rule->dtstart - ((@@ (datetime zic) make-rule) - 'US 1967 1973 4 '(last 0) - ((@ (datetime zic) make-timespec) #02:00:00 '+ #\w) - ((@ (datetime zic) make-timespec) #01:00:00 '+ #\d) - "D"))) - - (test-equal "sunday >= 1" - #1977-04-03T01:00:00Z - (rule->dtstart - ((@@ (datetime zic) make-rule) 'EU 1977 1980 4 `(> ,sun 1) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #01:00:00 '+ #\w) - "S"))) - - ;; Max and min uses dummy dates, which is slightly wrong - ;; but shouldn't cause any real problems - - (test-equal "Minimum time" - #0000-10-30T01:00:00Z - (rule->dtstart - ((@@ (datetime zic) make-rule) 'EU 'minimum 2000 10 '(last 0) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - ""))) - - (test-equal "Maximum time" - (datetime year: 9999 month: oct day: 27 - hour: 1 tz: "UTC") - (rule->dtstart - ((@@ (datetime zic) make-rule) 'EU 'maximum 2000 10 '(last 0) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - "")))) - -(test-group "zone-format" - - (test-equal "Zone format with argument" "CEST" (zone-format "CE%sT" "S")) - (test-equal "Zone format with empty" "CET" (zone-format "CE%sT" "")) - - ;; TODO zone-format %z is not yet implemented, and therefore untested - - ;; TODO this error message is currently translatable... - (test-equal "Invalid format specifier" - '(misc-error "zone-format" "Invalid format char ~s in ~s at position ~a" (#\S "%S" 1) #f) - (catch 'misc-error (lambda () (zone-format "%S" "A")) - list))) - -(test-group "Actual object" - ;; NOTE this doesn't test read-zoneinfos ability to - ;; - take filenames - ;; - take multiple items - (let ((zoneinfo (call-with-input-string big-sample (compose read-zoneinfo list)))) - (test-assert "get-zone returns a zone-entry object" - (every zone-entry? (get-zone zoneinfo "Europe/Zurich"))) - (test-equal "A link resolves to the same object as its target" - (get-zone zoneinfo "Europe/Zurich") (get-zone zoneinfo "Europe/Vaduz")) - (test-equal "Get rules returns correctly, and in order" - ;; Rules are sorted - (list ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 5 `(> ,mon 1) - (make-timespec #01:00:00 '+ #\w) - (make-timespec #01:00:00 '+ #\w) - "S") - ((@@ (datetime zic) make-rule) 'Swiss 1941 1942 10 `(> ,mon 1) - (make-timespec #02:00:00 '+ #\w) - (make-timespec #00:00:00 '+ #\w) - "")) - (get-rule zoneinfo 'Swiss)))) - - -(test-group "rule->rrule" - (test-equal "Basic example, and to = maximum" - ((@ (vcomponent recurrence internal) make-recur-rule) - freq: 'YEARLY interval: 1 wkst: mon - byday: (list (cons -1 sun)) - bymonth: (list oct)) - (rule->rrule - ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 '(last 0) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - "") - )) - - (test-equal "with to = only" - #f - (rule->rrule - ((@@ (datetime zic) make-rule) 'EU 1996 'only 10 '(last 2) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - ""))) - - (test-equal "with definitive to year" - ((@ (vcomponent recurrence internal) make-recur-rule) - freq: 'YEARLY interval: 1 wkst: mon - byday: (list (cons -1 tue)) - bymonth: (list oct) - until: #2000-01-01T00:00:00) - (rule->rrule - ((@@ (datetime zic) make-rule) 'EU 1996 2000 10 '(last 2) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - ""))) - - (test-equal "on being a month day" - ((@ (vcomponent recurrence internal) make-recur-rule) - freq: 'YEARLY interval: 1 wkst: mon - bymonthday: (list 2) - bymonth: (list oct)) - (rule->rrule - ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 2 - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - ""))) - - (test-equal "on being first day after date" - ((@ (vcomponent recurrence internal) make-recur-rule) - freq: 'YEARLY interval: 1 wkst: mon - byday: (list (cons 1 mon)) - bymonth: (list oct)) - (rule->rrule - ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 `(> ,mon 2) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - ""))) - - (test-equal "Crash on counting backwards from date" - '(misc-error "rule->rrule" "Counting backward for RRULES unsupported" #f #f) - (catch 'misc-error - (lambda () - (rule->rrule - ((@@ (datetime zic) make-rule) 'EU 1996 'maximum 10 `(< ,mon 2) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - ""))) - list)) - - (test-equal "Crash on to = minimum" - '(misc-error "rule->rrule" "Check your input" #f #f) - (catch 'misc-error - (lambda () - (rule->rrule - ((@@ (datetime zic) make-rule) 'EU 1996 'minimum 10 `(< ,mon 2) - (make-timespec #01:00:00 '+ #\u) - (make-timespec #00:00:00 '+ #\w) - ""))) - list)) - ) |