Changeset 12648 in project


Ignore:
Timestamp:
11/29/08 15:49:15 (11 years ago)
Author:
azul
Message:

Blessing.

Location:
release/3/embedded-test
Files:
2 added
4 copied

Legend:

Unmodified
Added
Removed
  • release/3/embedded-test/trunk/embedded-test-runtime.scm

    r12595 r12648  
    1 (define-record unittest name proc expect equal?)
    21
    3 (define *unittests* '())
     2(use format-modular srfi-1)
    43
    5 (define (run-unittests)
    6   (when (getenv "UNITTESTS")
    7     (let ((errors 0))
    8       (for-each
    9         (lambda (test)
    10           (when (getenv "UNITTESTS_VERBOSE")
    11             (format (current-error-port) "Running test: ~S..." (unittest-name test)))
    12           (let ((result ((unittest-proc test))))
    13             (cond
    14               ((not ((unittest-equal? test) result (unittest-expect test)))
    15                (set! errors (+ errors 1))
    16                (when (getenv "UNITTESTS_VERBOSE")
    17                  (format (current-error-port) " FAIL~%"))
    18                (format (current-error-port) "Test failed: ~S~%Expected: ~S~%Received: ~S~%~%"
    19                        (unittest-name test)
    20                        (unittest-expect test)
    21                        result))
    22               ((getenv "UNITTESTS_VERBOSE")
    23                (format (current-error-port) " PASS~%")))))
    24         (reverse *unittests*))
    25       (when (positive? errors)
    26         (error "Unit tests failed")))))
     4(define *tests* '())
    275
    28 ; Args as the same as make-unittest expects.
     6(define-record test group-name name proc expect equal?)
    297
    30 (define (register-unittest . args)
    31   (set! *unittests* (cons (apply make-unittest args) *unittests*)))
     8(define (register-test . args)
     9  (set! *tests* (cons (apply make-test args) *tests*)))
     10
     11(define (run-test test)
     12  (when (getenv "TESTS_VERBOSE")
     13    (format (current-error-port) "Test~A: ~S..."
     14            (if (test-group-name test)
     15              (format #f " from group ~A" (test-group-name test))
     16              "")
     17            (test-name test)))
     18  (let* ((result ((test-proc test)))
     19         (expect ((test-expect test)))
     20         (pass ((test-equal? test) result expect)))
     21    (when (getenv "TESTS_VERBOSE")
     22      (format (current-error-port) " ~A~%" (if pass "PASS" "FAIL")))
     23    (unless pass
     24      (format (current-error-port) "Test~A failed: ~S~%Expected: ~S~%Received: ~S~%~%"
     25        (if (test-group-name test)
     26          (format #f " from group ~A" (test-group-name test))
     27          "")
     28        (test-name test)
     29        expect
     30        result))
     31    pass))
     32
     33(define (run-tests)
     34  (when (getenv "TESTS_SHOW_GROUPS")
     35    (format (current-error-port) "Groups:~{ ~A~}~%"
     36            (delete-duplicates (map test-group-name (reverse *tests*)))))
     37  (when (and (getenv "TESTS")
     38             (positive?
     39               (count
     40                 (complement run-test)
     41                 (reverse
     42                   (filter
     43                     (let ((groups (map string->symbol
     44                                        (string-split
     45                                          (or (getenv "TESTS_GROUPS") "")
     46                                          " "))))
     47                       (if (null? groups)
     48                         identity
     49                         (compose (cut member <> groups)
     50                                  test-group-name)))
     51                     *tests*)))))
     52    (error "Unit tests failed")))
  • release/3/embedded-test/trunk/embedded-test.meta

    r12595 r12648  
    1 ;;; embedded-unittest.meta -*- Hen -*-
    2 ((files "embedded-unittest-base.scm" "embedded-unittest.scm" "embedded-unittest.setup" "embedded-unittest.html")
    3  (egg "embedded-unittest.egg")
     1;;; embedded-test.meta -*- Hen -*-
     2((files "embedded-test-runtime.scm" "embedded-test.scm" "embedded-test.setup" "embedded-test.html")
     3 (egg "embedded-test.egg")
    44 (doc-from-wiki)
    55 (author "Alejandro Forero Cuervo")
  • release/3/embedded-test/trunk/embedded-test.scm

    r12595 r12648  
    1 (define-macro (unittest expr . rest)
    2   (let-optionals rest ((expect #t) (cmp? 'equal?))
    3     `(register-unittest ',expr (lambda () ,expr) ,expect ,cmp?)))
     1
     2(define-macro (test expr . rest)
     3  (let-optionals rest ((expect #t)
     4                       (cmp? (if (null? rest)
     5                               '(lambda (a b) a)
     6                               'equal?))
     7                       (name expr)
     8                       (group #f))
     9    `(register-test ',group
     10                    ',name
     11                    (lambda () ,expr)
     12                    (lambda () ,expect)
     13                    ,cmp?)))
     14
     15(define-macro (test-group group-name . rest)
     16  `(begin
     17     ,@(map
     18         (lambda (test)
     19           (let-optionals (cddr test) ((expect #t)
     20                                       (cmp? (if (null? rest)
     21                                               '(lambda (a b) a)
     22                                               'equal?))
     23                                       (name (cadr test)))
     24           `  (test ,(cadr test) ,expect ,cmp? ,name ,group-name)))
     25         rest)))
  • release/3/embedded-test/trunk/embedded-test.setup

    r12595 r12648  
    77
    88(compile  -O2 -d0 -s
    9          ,@(if has-exports? '(-check-imports -emit-exports embedded-unittest.exports) '())
    10          embedded-unittest-base.scm)
     9         ,@(if has-exports? '(-check-imports -emit-exports embedded-test.exports) '())
     10         embedded-test-runtime.scm)
    1111
    1212(install-extension
    1313
    1414  ; Name of your extension:
    15   'embedded-unittest
     15  'embedded-test
    1616
    1717  ; Files to install for your extension:
    18   `(,(dynld-name "embedded-unittest-base")
    19     "embedded-unittest.scm"
    20     ,@(if has-exports? '("embedded-unittest.exports") (list)) )
     18  `(,(dynld-name "embedded-test-runtime")
     19    "embedded-test.scm"
     20    ,@(if has-exports? '("embedded-test.exports") (list)) )
    2121
    2222  ; Assoc list with properties for your extension:
    2323  `((version 1.0)
    2424    (syntax)
    25     (require-at-runtime embedded-unittest-base)
    26     (documentation "embedded-unittest.html")
    27     ,@(if has-exports? `((exports "embedded-unittest.exports")) (list)) ))
     25    (require-at-runtime embedded-test-runtime)
     26    (documentation "embedded-test.html")
     27    ,@(if has-exports? `((exports "embedded-test.exports")) (list)) ))
Note: See TracChangeset for help on using the changeset viewer.