Changeset 9501 in project


Ignore:
Timestamp:
03/12/08 01:05:41 (12 years ago)
Author:
Kon Lovett
Message:

Rel 2.0

Location:
release/3/testbase-results
Files:
2 deleted
4 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/3/testbase-results/tags/2.0.0/testbase-results.meta

    r8955 r9501  
    1515  "testbase-results.scm"
    1616  "testbase-reports.scm"
    17   "testbase-results-version.scm"
    1817  "testbase-results.setup"))
  • release/3/testbase-results/tags/2.0.0/testbase-results.scm

    r8955 r9501  
    55;;
    66;; - Test results db row header should be extensible via an api.
    7 
    8 (require-extension srfi-1 srfi-13 extras utils posix)
    9 (require-extension miscmacros misc-extn-posix)
    10 (require-extension numbers) ; Just in case
    11 (require-extension testbase-printers testbase-readers)
    127
    138(eval-when (compile)
     
    1611    (inline)
    1712    (fixnum)
     13    (no-bound-checks)
    1814    (no-procedure-checks)
    1915    (export
     
    2218      default-test-file-extension
    2319      delete-test-results-file
    24       fold-test-results-rows
    2520      load-test-results-reader-extension
    2621      test-results-reader-setup
     
    4540      test-results-row-model
    4641      test-results-row-results
    47       test-results-row-when) ) )
     42      test-results-row-when ) ) )
     43
     44(require-extension srfi-1 srfi-13 extras utils posix)
     45(require-extension miscmacros misc-extn-directory)
     46(require-extension numbers) ; Just in case
     47(require-extension testbase-printers testbase-readers)
    4848
    4949;;;
     
    7777  (let ([nam (test-result-field rslt 'name)])
    7878    (if (equal? "" nam)
    79       ;then <nameless> test result
    80       (test-result-field rslt 'id)
    81       ;else user named test result
    82       nam ) ) )
     79        ; then <nameless> test result
     80        (test-result-field rslt 'id)
     81        ; else user named test result
     82        nam ) ) )
    8383
    8484(define (test-result-finding rslt)
     
    9393  (eq? #t (test-result-finding rslt)) )
    9494
    95 ;;; Test Results Operations
     95;; Results row access
     96
     97(define (test-results-row-field row key)
     98  (alist-ref key row) )
     99
     100(define (test-results-row-model row)
     101  (test-results-row-field row 'model) )
     102
     103(define (test-results-row-when row)
     104  (test-results-row-field row 'when) )
     105
     106(define (test-results-row-results row)
     107  (test-results-row-field row 'results) )
     108
     109;;; Test Results Database Record Operations
    96110
    97111;; Returns a list of failed results for the supplied types.
     
    100114(define (test-results-failures rslts #!optional (typs '(expectation error)))
    101115  (filter-map
    102     (lambda (rslt)
    103       (and (not (test-result-passed? rslt))
    104            (memq (test-result-type rslt) typs)
    105            rslt ) )
    106     rslts) )
     116   (lambda (rslt)
     117     (and (not (test-result-passed? rslt))
     118          (memq (test-result-type rslt) typs)
     119          rslt ) )
     120   rslts) )
    107121
    108122(define (test-results-remove! rslts ids)
     
    110124        [typs (filter-map pair? ids)])
    111125    (remove!
    112       (lambda (rslt)
    113         (let ([id (test-result-identifier rslt)])
    114           (or (member id nams)
    115               (member (list (test-result-type rslt) id) typs) ) ) )
    116       rslts) ) )
     126     (lambda (rslt)
     127       (let ([id (test-result-identifier rslt)])
     128         (or (member id nams)
     129             (member (list (test-result-type rslt) id) typs) ) ) )
     130     rslts) ) )
     131
     132;; Create a results header with optional columns
     133
     134(define (make-test-results-row-header . cols)
     135  cols )
     136
     137;; Create a results row w/ std columns & optional columns
     138
     139(define (make-test-results-row knd rslts . cols)
     140  `((model . ,knd)
     141    (when . ,(seconds->local-time (current-seconds)))
     142    ,@cols
     143    (results . ,rslts)) )
    117144
    118145;;; Test Results Database Operations
    119146
    120 (define handled-row-header?
    121   (lambda (row)
    122     (and (pair? row)
    123          (let ([key (car row)])
    124            (and (symbol? key)
    125                 (let ([val (cdr row)])
    126                   (switch key
    127                     ['extension
    128                      (load-test-results-reader-extension val)]
    129                     ['setup
    130                       (test-results-reader-setup val)]
    131                     [else
    132                       (warning "unknown row header" row)])
    133                   #t ) ) ) ) ) )
     147(define (process-row-header row)
     148  ; A row header is a pair of symbol & value while a
     149  ; result row is an alist. So not the same form.
     150  (and (pair? row)
     151       (let ([key (car row)])
     152         (and (symbol? key)
     153              (let ([val (cdr row)])
     154                (switch key
     155                  ['extension
     156                   (load-test-results-reader-extension val)]
     157                  ['setup
     158                    (test-results-reader-setup val)]
     159                  [else
     160                    (warning "unknown row header" key val)])
     161                #t ) ) ) ) )
     162
     163;; Returns result of fold procedure.
     164;; By default a list: (<test-results-row> ...)
     165;; where test-results-row is an association list.
     166
     167(define (read-test-results-rows port #!optional (proc cons) (acc '()))
     168  (port-fold
     169   (lambda (row acc)
     170     ; Must process all row headers in-order due to possible
     171     ; reader extensions.
     172     (if (process-row-header row)
     173         ; then not a result row so nothing more todo
     174         acc
     175         ; else result row so "fold" it
     176         (proc row acc)) )
     177   acc
     178   (lambda () (read port))) )
     179
     180;;; File Oriented Operations
    134181
    135182;; Pathname Parameters
     
    142189  (lambda (x)
    143190    (if (string? x)
    144       x
    145       (begin
    146         (warning 'default-test-file-extension "invalid extension" x)
    147         (default-test-file-extension)))))
     191        x
     192        (begin
     193          (warning 'default-test-file-extension "invalid extension" x)
     194          (default-test-file-extension)))))
    148195
    149196(define-parameter test-files-directory
     
    151198  (lambda (x)
    152199    (if (absolute-pathname? x)
    153       x
    154       (begin
    155         (warning 'test-files-directory "invalid absolute pathname" x)
    156         (test-files-directory)))))
     200        x
     201        (begin
     202          (warning 'test-files-directory "invalid absolute pathname" x)
     203          (test-files-directory)))))
    157204
    158205(define-parameter test-results-directory
     
    160207  (lambda (x)
    161208    (if (absolute-pathname? x)
    162       x
    163       (begin
    164         (warning 'test-results-directory "invalid absolute pathname" x)
    165         (test-results-directory)))))
     209        x
     210        (begin
     211          (warning 'test-results-directory "invalid absolute pathname" x)
     212          (test-results-directory)))))
    166213
    167214;; Pathname Constructors
     
    194241;; Returns the test results rows from the given database file
    195242
    196 (define (read-test-results-file flnm)
     243(define (read-test-results-file flnm . rest)
    197244  (call-with-input-file (make-test-results-pathname flnm)
    198     read-test-results-rows) )
    199 
    200 ;; Returns result of fold procedure.
    201 
    202 (define (fold-test-results-rows proc acc port)
    203   (port-fold
    204     (lambda (row acc)
    205       (if (handled-row-header? row)
    206         acc
    207         (proc row acc)) )
    208     acc
    209     (lambda () (read port))) )
    210 
    211 ;; Returns a list: (<test-results-row> ...)
    212 ;; where test-results-row is an association list.
    213 
    214 (define (read-test-results-rows port)
    215   (reverse! (fold-test-results-rows cons '() port)) )
    216 
    217 ;;; Test Results Database Record Operations
    218 
    219 ;; Create a results header with optional columns
    220 
    221 (define (make-test-results-row-header . cols)
    222   cols )
    223 
    224 ;; Create a results row w/ std columns & optional columns
    225 
    226 (define (make-test-results-row knd rslts . cols)
    227   `((model . ,knd)
    228     (when . ,(seconds->local-time (current-seconds)))
    229     ,@cols
    230     (results . ,rslts)) )
     245                        (lambda (port)
     246                          (apply read-test-results-rows port rest))) )
    231247
    232248;; Write a results row to a results file, w/ optional header.
     
    239255      (write row port)
    240256      (close-output-port port) ) ) )
    241 
    242 ;; Results row access
    243 
    244 (define (test-results-row-field row key)
    245   (alist-ref key row) )
    246 
    247 (define (test-results-row-model row)
    248   (test-results-row-field row 'model) )
    249 
    250 (define (test-results-row-when row)
    251   (test-results-row-field row 'when) )
    252 
    253 (define (test-results-row-results row)
    254   (test-results-row-field row 'results) )
  • release/3/testbase-results/trunk/testbase-results.meta

    r8955 r9501  
    1515  "testbase-results.scm"
    1616  "testbase-reports.scm"
    17   "testbase-results-version.scm"
    1817  "testbase-results.setup"))
  • release/3/testbase-results/trunk/testbase-results.scm

    r8955 r9501  
    55;;
    66;; - Test results db row header should be extensible via an api.
    7 
    8 (require-extension srfi-1 srfi-13 extras utils posix)
    9 (require-extension miscmacros misc-extn-posix)
    10 (require-extension numbers) ; Just in case
    11 (require-extension testbase-printers testbase-readers)
    127
    138(eval-when (compile)
     
    1611    (inline)
    1712    (fixnum)
     13    (no-bound-checks)
    1814    (no-procedure-checks)
    1915    (export
     
    2218      default-test-file-extension
    2319      delete-test-results-file
    24       fold-test-results-rows
    2520      load-test-results-reader-extension
    2621      test-results-reader-setup
     
    4540      test-results-row-model
    4641      test-results-row-results
    47       test-results-row-when) ) )
     42      test-results-row-when ) ) )
     43
     44(require-extension srfi-1 srfi-13 extras utils posix)
     45(require-extension miscmacros misc-extn-directory)
     46(require-extension numbers) ; Just in case
     47(require-extension testbase-printers testbase-readers)
    4848
    4949;;;
     
    7777  (let ([nam (test-result-field rslt 'name)])
    7878    (if (equal? "" nam)
    79       ;then <nameless> test result
    80       (test-result-field rslt 'id)
    81       ;else user named test result
    82       nam ) ) )
     79        ; then <nameless> test result
     80        (test-result-field rslt 'id)
     81        ; else user named test result
     82        nam ) ) )
    8383
    8484(define (test-result-finding rslt)
     
    9393  (eq? #t (test-result-finding rslt)) )
    9494
    95 ;;; Test Results Operations
     95;; Results row access
     96
     97(define (test-results-row-field row key)
     98  (alist-ref key row) )
     99
     100(define (test-results-row-model row)
     101  (test-results-row-field row 'model) )
     102
     103(define (test-results-row-when row)
     104  (test-results-row-field row 'when) )
     105
     106(define (test-results-row-results row)
     107  (test-results-row-field row 'results) )
     108
     109;;; Test Results Database Record Operations
    96110
    97111;; Returns a list of failed results for the supplied types.
     
    100114(define (test-results-failures rslts #!optional (typs '(expectation error)))
    101115  (filter-map
    102     (lambda (rslt)
    103       (and (not (test-result-passed? rslt))
    104            (memq (test-result-type rslt) typs)
    105            rslt ) )
    106     rslts) )
     116   (lambda (rslt)
     117     (and (not (test-result-passed? rslt))
     118          (memq (test-result-type rslt) typs)
     119          rslt ) )
     120   rslts) )
    107121
    108122(define (test-results-remove! rslts ids)
     
    110124        [typs (filter-map pair? ids)])
    111125    (remove!
    112       (lambda (rslt)
    113         (let ([id (test-result-identifier rslt)])
    114           (or (member id nams)
    115               (member (list (test-result-type rslt) id) typs) ) ) )
    116       rslts) ) )
     126     (lambda (rslt)
     127       (let ([id (test-result-identifier rslt)])
     128         (or (member id nams)
     129             (member (list (test-result-type rslt) id) typs) ) ) )
     130     rslts) ) )
     131
     132;; Create a results header with optional columns
     133
     134(define (make-test-results-row-header . cols)
     135  cols )
     136
     137;; Create a results row w/ std columns & optional columns
     138
     139(define (make-test-results-row knd rslts . cols)
     140  `((model . ,knd)
     141    (when . ,(seconds->local-time (current-seconds)))
     142    ,@cols
     143    (results . ,rslts)) )
    117144
    118145;;; Test Results Database Operations
    119146
    120 (define handled-row-header?
    121   (lambda (row)
    122     (and (pair? row)
    123          (let ([key (car row)])
    124            (and (symbol? key)
    125                 (let ([val (cdr row)])
    126                   (switch key
    127                     ['extension
    128                      (load-test-results-reader-extension val)]
    129                     ['setup
    130                       (test-results-reader-setup val)]
    131                     [else
    132                       (warning "unknown row header" row)])
    133                   #t ) ) ) ) ) )
     147(define (process-row-header row)
     148  ; A row header is a pair of symbol & value while a
     149  ; result row is an alist. So not the same form.
     150  (and (pair? row)
     151       (let ([key (car row)])
     152         (and (symbol? key)
     153              (let ([val (cdr row)])
     154                (switch key
     155                  ['extension
     156                   (load-test-results-reader-extension val)]
     157                  ['setup
     158                    (test-results-reader-setup val)]
     159                  [else
     160                    (warning "unknown row header" key val)])
     161                #t ) ) ) ) )
     162
     163;; Returns result of fold procedure.
     164;; By default a list: (<test-results-row> ...)
     165;; where test-results-row is an association list.
     166
     167(define (read-test-results-rows port #!optional (proc cons) (acc '()))
     168  (port-fold
     169   (lambda (row acc)
     170     ; Must process all row headers in-order due to possible
     171     ; reader extensions.
     172     (if (process-row-header row)
     173         ; then not a result row so nothing more todo
     174         acc
     175         ; else result row so "fold" it
     176         (proc row acc)) )
     177   acc
     178   (lambda () (read port))) )
     179
     180;;; File Oriented Operations
    134181
    135182;; Pathname Parameters
     
    142189  (lambda (x)
    143190    (if (string? x)
    144       x
    145       (begin
    146         (warning 'default-test-file-extension "invalid extension" x)
    147         (default-test-file-extension)))))
     191        x
     192        (begin
     193          (warning 'default-test-file-extension "invalid extension" x)
     194          (default-test-file-extension)))))
    148195
    149196(define-parameter test-files-directory
     
    151198  (lambda (x)
    152199    (if (absolute-pathname? x)
    153       x
    154       (begin
    155         (warning 'test-files-directory "invalid absolute pathname" x)
    156         (test-files-directory)))))
     200        x
     201        (begin
     202          (warning 'test-files-directory "invalid absolute pathname" x)
     203          (test-files-directory)))))
    157204
    158205(define-parameter test-results-directory
     
    160207  (lambda (x)
    161208    (if (absolute-pathname? x)
    162       x
    163       (begin
    164         (warning 'test-results-directory "invalid absolute pathname" x)
    165         (test-results-directory)))))
     209        x
     210        (begin
     211          (warning 'test-results-directory "invalid absolute pathname" x)
     212          (test-results-directory)))))
    166213
    167214;; Pathname Constructors
     
    194241;; Returns the test results rows from the given database file
    195242
    196 (define (read-test-results-file flnm)
     243(define (read-test-results-file flnm . rest)
    197244  (call-with-input-file (make-test-results-pathname flnm)
    198     read-test-results-rows) )
    199 
    200 ;; Returns result of fold procedure.
    201 
    202 (define (fold-test-results-rows proc acc port)
    203   (port-fold
    204     (lambda (row acc)
    205       (if (handled-row-header? row)
    206         acc
    207         (proc row acc)) )
    208     acc
    209     (lambda () (read port))) )
    210 
    211 ;; Returns a list: (<test-results-row> ...)
    212 ;; where test-results-row is an association list.
    213 
    214 (define (read-test-results-rows port)
    215   (reverse! (fold-test-results-rows cons '() port)) )
    216 
    217 ;;; Test Results Database Record Operations
    218 
    219 ;; Create a results header with optional columns
    220 
    221 (define (make-test-results-row-header . cols)
    222   cols )
    223 
    224 ;; Create a results row w/ std columns & optional columns
    225 
    226 (define (make-test-results-row knd rslts . cols)
    227   `((model . ,knd)
    228     (when . ,(seconds->local-time (current-seconds)))
    229     ,@cols
    230     (results . ,rslts)) )
     245                        (lambda (port)
     246                          (apply read-test-results-rows port rest))) )
    231247
    232248;; Write a results row to a results file, w/ optional header.
     
    239255      (write row port)
    240256      (close-output-port port) ) ) )
    241 
    242 ;; Results row access
    243 
    244 (define (test-results-row-field row key)
    245   (alist-ref key row) )
    246 
    247 (define (test-results-row-model row)
    248   (test-results-row-field row 'model) )
    249 
    250 (define (test-results-row-when row)
    251   (test-results-row-field row 'when) )
    252 
    253 (define (test-results-row-results row)
    254   (test-results-row-field row 'results) )
Note: See TracChangeset for help on using the changeset viewer.