From 57e4004ec1a0489e6d8bc7dbd4bd07b110b6239b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 7 Mar 2022 22:55:14 +0100 Subject: Replace Guile's srfi-64:s test-error with working version. Along with updating now failing tests. --- module/srfi/srfi-64/test-error.scm | 85 ++++++++++++++++++++++++++ module/vcomponent/recurrence/parse.scm | 10 ++- tests/test/let-env.scm | 1 + tests/test/param.scm | 4 +- tests/test/recurrence-simple.scm | 3 +- tests/test/util.scm | 1 + tests/test/vcomponent-formats-common-types.scm | 1 + 7 files changed, 101 insertions(+), 4 deletions(-) create mode 100644 module/srfi/srfi-64/test-error.scm diff --git a/module/srfi/srfi-64/test-error.scm b/module/srfi/srfi-64/test-error.scm new file mode 100644 index 00000000..33922c32 --- /dev/null +++ b/module/srfi/srfi-64/test-error.scm @@ -0,0 +1,85 @@ +;; Copyright © 2022 Hugo Hörnquist +;; Copyright for this file, however, majority of contents borrowed under the +;; below mentioned license agreement from srfi/srfi-64/testing.scm of Guile 2.2.7. + +;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner +;; Added "full" support for Chicken, Gauche, Guile and SISC. +;; Alex Shinn, Copyright (c) 2005. +;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. +;; Support for Guile 2 by Mark H Weaver , Copyright (c) 2014. +;; +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. +;;; Commentary: +;; The code is directly copied from Guile's source tree +;; (module/srfi/srfi-64/testing.scm), but @var{etype} +;; is passed to @code{catch}, causing it to actually +;; check the expected error. +;;; Code: + +(define-module (srfi srfi-64 test-error) + :use-module (srfi srfi-64) + :use-module (hnh util) + :replace (test-error)) + +(define %test-source-line2 (@@ (srfi srfi-64) %test-source-line2)) +(define %test-on-test-begin (@@ (srfi srfi-64) %test-on-test-begin)) +(define %test-on-test-end (@@ (srfi srfi-64) %test-on-test-end)) +(define %test-report-result (@@ (srfi srfi-64) %test-report-result)) + +(define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (cond ((%test-on-test-begin r) + (let ((et etype)) + (test-result-set! r 'expected-error et) + (%test-on-test-end r + (catch etype + (lambda () + (test-result-set! r 'actual-value expr) + #f) + (lambda (key . args) + ;; TODO: decide how to specify expected + ;; error types for Guile. + (test-result-set! r 'actual-error + (cons key args)) + #t))) + (%test-report-result))))))) + +(define-syntax test-error + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac tname etype expr) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-error r etype expr)))) + (((mac etype expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r etype expr)))) + (((mac expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r #t expr))))))) + diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm index 3477f6d4..c2e3a10f 100644 --- a/module/vcomponent/recurrence/parse.scm +++ b/module/vcomponent/recurrence/parse.scm @@ -72,6 +72,12 @@ `(else ,@body))) cases)))) +(define* (string->number/throw string optional: (radix 10)) + (or (string->number string radix) + (scm-error 'wrong-type-argument + "string->number/throw" + "Can't parse ~s as number in base ~a" + '(string radix) #f))) ;; RFC 5545, Section 3.3.10. Recurrence Rule, states that the UNTIL value MUST have ;; the same type as the DTSTART of the event (date or datetime). I have seen events @@ -92,8 +98,8 @@ (parse-ics-datetime val))) (day (rfc->datetime-weekday (string->symbol val))) (days (map parse-day-spec (string-split val #\,))) - (num (string->number val)) - (nums (map string->number (string-split val #\,)))) + (num (string->number/throw val)) + (nums (map string->number/throw (string-split val #\,)))) ;; It's an error to give BYHOUR and smaller for pure dates. ;; 3.3.10. p 41 diff --git a/tests/test/let-env.scm b/tests/test/let-env.scm index 1d6d7507..07b92d2d 100644 --- a/tests/test/let-env.scm +++ b/tests/test/let-env.scm @@ -1,5 +1,6 @@ (define-module (test let-env) :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) :use-module (srfi srfi-88) :use-module ((guile) :select (setenv getenv)) :use-module ((hnh util) :select (let-env))) diff --git a/tests/test/param.scm b/tests/test/param.scm index 8b8a010d..4c3cbcfb 100644 --- a/tests/test/param.scm +++ b/tests/test/param.scm @@ -5,6 +5,7 @@ (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)) @@ -45,7 +46,8 @@ END:DUMMY" (call-with-input-string "BEGIN:DUMMY KEY:Some Text -END:DUMMY")) +END:DUMMY" + parse-calendar)) ;; Similar thing happens for sxcal, but during serialization instead (let ((component (make-vcomponent 'DUMMY))) diff --git a/tests/test/recurrence-simple.scm b/tests/test/recurrence-simple.scm index 0f421b05..6ded68ba 100644 --- a/tests/test/recurrence-simple.scm +++ b/tests/test/recurrence-simple.scm @@ -6,6 +6,7 @@ (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)) @@ -33,7 +34,7 @@ ;;; Test that recurrence rule parsing fails where appropriate (parameterize ((warnings-are-errors #t) - (warning-handler identity)) + (warning-handler (lambda _ ""))) (test-error "Invalid FREQ" 'warning (parse-recurrence-rule "FREQ=ERR;COUNT=3")) diff --git a/tests/test/util.scm b/tests/test/util.scm index 47edb225..7cba2142 100644 --- a/tests/test/util.scm +++ b/tests/test/util.scm @@ -4,6 +4,7 @@ (define-module (test util) :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) :use-module (srfi srfi-88) :use-module ((hnh util) :select (filter-sorted diff --git a/tests/test/vcomponent-formats-common-types.scm b/tests/test/vcomponent-formats-common-types.scm index c8bfd323..4c442461 100644 --- a/tests/test/vcomponent-formats-common-types.scm +++ b/tests/test/vcomponent-formats-common-types.scm @@ -1,5 +1,6 @@ (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)) -- cgit v1.2.3