Changeset 9781 in project


Ignore:
Timestamp:
03/16/08 00:42:14 (12 years ago)
Author:
Kon Lovett
Message:

Bug fixes for cmdlin params - wasn't handling single valued properly.

Location:
release/3/testbase-driver/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/3/testbase-driver/trunk/testbase-driver.meta

    r9748 r9781  
    1212 (files
    1313  "setup-header.scm"
     14  "testbase-driver.html"
    1415  "testbase-driver.setup"
    1516  "testbase-driver.scm"))
  • release/3/testbase-driver/trunk/testbase-driver.scm

    r9701 r9781  
    2222      add-startup-object ) ) )
    2323
    24 (use srfi-1 extras regex utils posix)
    25 (use srfi-37 args miscmacros lookup-table
    26      misc-extn-list misc-extn-directory misc-extn-condition)
    27 (use testbase-results)
     24(use srfi-1 extras regex utils posix
     25    srfi-37 args miscmacros lookup-table
     26     misc-extn-list misc-extn-directory misc-extn-condition
     27    testbase-results)
    2828
    2929;;;
     
    6262
    6363(define-constant BASIC-INDENT 2)
     64
     65(define-constant *single-valued-tags*
     66  '((compile    command)
     67    (interpret  command)
     68    (test       compile interpret directory expectation-specifics failure-exit)))
    6469
    6570;;; Printing messages
     
    102107  (print-verbose-message msg)
    103108  (for-each
    104     (lambda (obj)
    105       (print-indented-verbose-message BASIC-INDENT obj)
    106       (unless *dry-run?*
    107         (cond [(string? obj)  (display obj port)]
    108               [else           (write obj port)])
    109         ; For any possible REPL
    110         (newline port) ) )
    111     objs) )
     109   (lambda (obj)
     110     (print-indented-verbose-message BASIC-INDENT obj)
     111     (unless *dry-run?*
     112       (cond [(string? obj)  (display obj port)]
     113             [else           (write obj port)])
     114       ; For any possible REPL
     115       (newline port) ) )
     116   objs) )
     117
     118(define (setup-selects model-tbl knd)
     119  (and-let* ([selsets (dict-ref model-tbl knd)]
     120             [tstsels
     121              (not-null?
     122               (append-map!
     123                (lambda (sels)
     124                  (if (pair? sels)
     125                      (map
     126                       (lambda (sel)
     127                         (if (and (pair? sel) (<= 2 (length sel)))
     128                             `(test::select ',knd ,@sel)
     129                             (error 'setup-selects "invalid select specification" sel)) )
     130                       sels)
     131                      (error 'setup-selects "invalid select specifications" sels) ) )
     132                selsets))])
     133    (apply dict-update-list! model-tbl 'setup tstsels) ) )
    112134
    113135(define (setup-skips model-tbl)
    114   (and-let* ([skips (dict-ref model-tbl 'skip)])
    115     (let loop ([lst '()] [skips skips])
    116       (cond [(null? skips)
    117               (unless (null? lst)
    118                 (dict-update-list! model-tbl 'setup `(begin ,@lst)))]
    119             [(pair? skips)
    120               (let ([skip (car skips)])
    121                 (if (pair? skip)
    122                     (loop (cons `(test::select 'skip ,@skip) lst) (cdr skips))
    123                     (error 'setup-skips "invalid skip specification" skips)) )]
    124             [else
    125               (error 'setup-skips "invalid skip specification" skips)]) ) ) )
     136  (setup-selects model-tbl 'skip) )
    126137
    127138(define (setup-takes model-tbl)
    128   (and-let* ([takes (dict-ref model-tbl 'take)])
    129     (let loop ([lst '()] [takes takes])
    130       (cond [(null? takes)
    131               (unless (null? lst)
    132                 (dict-update-list! model-tbl 'setup `(begin ,@lst)))]
    133             [(pair? takes)
    134               (let ([take (car takes)])
    135                 (if (pair? take)
    136                     (loop (cons `(test::select 'take ,@take) lst) (cdr takes))
    137                     (error 'setup-takes "invalid take specification" takes)) )]
    138             [else
    139               (error 'setup-takes "invalid take specification" takes)]) ) ) )
     139  (setup-selects model-tbl 'take) )
    140140
    141141;;; Simplified process* (Any non-zero exit code is an error!)
     
    218218                      (find-loop linlst)]))))) ) ) )
    219219
     220(define (single-valued-table-entry? knd key)
     221  (and-let* ([single (assq knd *single-valued-tags*)])
     222    (memq key (cdr single)) ) )
     223
    220224(define (merge-test-config major-tbl major-lst)
    221   (let major-loop ([major-lst major-lst])
    222     (if (null? major-lst)
    223         major-tbl
    224         (let ([major-elm (car major-lst)])
    225           (if (pair? major-elm)
    226               (let ([minor-tbl (dict-update-dict! major-tbl (car major-elm))])
    227                 (let minor-loop ([minor-lst (cdr major-elm)])
    228                   (if (null? minor-lst)
    229                       (major-loop (cdr major-lst))
    230                       (let ([minor-elm (car minor-lst)])
    231                         (if (pair? minor-elm)
    232                             (begin
    233                               (apply dict-update-list! minor-tbl minor-elm)
    234                               (minor-loop (cdr minor-lst)) )
    235                             (error 'merge-test-config "invalid minor element" minor-elm)) ) ) ) )
    236               (error 'merge-test-config "invalid major element" major-elm) ) ) ) ) )
     225  (for-each
     226    (lambda (major-elm)
     227      (if (pair? major-elm)
     228          (let* ([minor-key (car major-elm)]
     229                 [minor-tbl (dict-update-dict! major-tbl minor-key)])
     230            (for-each
     231             (lambda (minor-elm)
     232               (if (pair? minor-elm)
     233                   (let ([itm-key (car minor-elm)]
     234                         [itm-val (cdr minor-elm)])
     235                     (if (single-valued-table-entry? minor-key itm-key)
     236                         (dict-set! minor-tbl itm-key (car itm-val))
     237                         (apply dict-update-list! minor-tbl itm-key itm-val) ) )
     238                   (error 'merge-test-config "invalid minor element" minor-elm) ) )
     239             (cdr major-elm)) )
     240          (error 'merge-test-config "invalid major element" major-elm) ) )
     241    major-lst)
     242  major-tbl )
    237243
    238244;;; Saving test results
     
    300306(define (drive-test-process cmd args frms dir)
    301307  ; Test(s) invocation must come last
    302   (set! frms (append frms '((test::run))))
    303   ; Change to test directory, if necessary
    304   (when dir
    305     (print-verbose-message "In" dir)
    306     (change-directory dir) )
    307   ; State what we would send as setup phase
    308   (when *dry-run?*
    309     (output-objects "Performing Setup" frms #f) )
    310   ; Drive the test
    311   (let ([rslts '()]
    312         [errstr ""])
    313       (run-process
    314        cmd
    315        (append args '("-i"))
    316        (lambda (in out pid err)
    317          ; Tell the test what to do
    318          (output-objects "Performing Setup" frms out)
    319          ; Done telling
    320          (close-output-port out)
    321          ; Get everything from stdin
    322          (set! rslts (read-test-results in))
    323          ; Just in case
    324          (set! errstr (read-all err)) )
    325        (lambda (ecode)
    326          (when ecode
    327            (print-error errstr)
    328            (set! rslts
    329                  (append! rslts (list (make-test-abnormal-exit-result ecode errstr)))))))
    330       ; Test results
    331       rslts ) )
     308  (let ([frms (append frms '((test::run)))])
     309    ; State what we would send as setup phase
     310    (cond [*dry-run?*
     311           (when dir (print-verbose-message "In" dir) )
     312           (output-objects "Performing Setup" frms #f)
     313           '() ]
     314          [else
     315           ; Change to test directory, if necessary
     316           (when dir
     317             (print-verbose-message "In" dir)
     318             (change-directory dir) )
     319           ; Drive the test
     320           (let ([rslts '()]
     321                 [errstr ""])
     322               (run-process
     323                cmd
     324                (append args '("-i"))
     325                (lambda (in out pid err)
     326                  ; Tell the test what to do
     327                  (output-objects "Performing Setup" frms out)
     328                  ; Done telling
     329                  (close-output-port out)
     330                  ; Get everything from stdin
     331                  (set! rslts (read-test-results in))
     332                  ; Just in case
     333                  (set! errstr (read-all err)) )
     334                (lambda (ecode)
     335                  (when ecode
     336                    (print-error errstr)
     337                    (set! rslts
     338                          (append!
     339                           rslts
     340                           (list (make-test-abnormal-exit-result ecode errstr)))))))
     341               ; Test results
     342               rslts ) ] ) ) )
    332343
    333344(define (compile-test-file cmd args dir)
     
    336347        [errstr ""]
    337348        [out-err #f])
    338     ;XXX Due to no-spaces-in-windows-command-name bug 
     349    ;XXX Due to no-spaces-in-windows-command-name bug
    339350    #+windows
    340351    (when dir
     
    353364          (set! out-flnm #f)
    354365          (set! out-err (cons ecode (conc instr #\newline errstr))))))
    355     ;XXX Due to no-spaces-in-windows-command-name bug 
     366    ;XXX Due to no-spaces-in-windows-command-name bug
    356367    #+windows
    357368    (when dir
     
    416427    (dict-set! model-tbl 'failure-exit cod) )
    417428  ; Merge list items from test table (except the single valued)
    418   (merge-table-list-items model-tbl test-tbl '(interpret compile directory failure-exit))
     429  (merge-table-list-items model-tbl test-tbl (cdr (assq 'test *single-valued-tags*)))
    419430  ; Any user specified test selections?
    420431  (setup-skips model-tbl)
     
    430441  ; Must have a command to execute
    431442  (unless (dict-ref model-tbl 'command)
    432     (dict-set! model-tbl 'command defcmd) ) )
    433 
    434 (define (run-test-model test-file model-tbl knd makargs runtst)
     443    (dict-set! model-tbl 'command defcmd) )
    435444  ; Any test results reader extension?
    436445  (and-let* ([syms (dict-ref model-tbl 'reader-extension)])
     
    442451    (print-verbose-message "Performing Reader Setup")
    443452    (for-each (cut print-indented-verbose-message BASIC-INDENT <>) forms)
    444     (unless *dry-run?* (test-results-reader-setup forms) ) )
     453    (unless *dry-run?* (test-results-reader-setup forms) ) ) )
     454
     455(define (run-test-model test-file model-tbl knd makargs runtst)
    445456  ; Startup actions
    446457  (perform-startup model-tbl)
     
    448459  (let ([rslts (runtst (dict-ref model-tbl 'command)
    449460                       (makargs (cond-expand
    450                                   ;XXX Due to no-spaces-in-windows-command-name bug 
     461                                  ;XXX Due to no-spaces-in-windows-command-name bug
    451462                                  [windows (pathname-strip-directory test-file)]
    452463                                  [else    test-file])
     
    628639(define-macro (option-set! VAR NAME #!optional (EXPR '(or optval #t)))
    629640  `(let ([optval (alist-ref ',NAME opts eq? (void))])
    630      (unless (eq? optval (void))
     641     (unless (eq? (void) optval)
    631642       (set! ,VAR ,EXPR) ) ) )
    632643
     
    649660       (unless (absolute-pathname? dir)
    650661         (option-usage-error 'test-file "directory must be absolute" flnm) ) )
    651      (merge-test-config (dict-update-dict! tbl (make-test-file-pathname flnm)) major-lst))
     662     (let ([major-tbl (dict-update-dict! tbl (make-test-file-pathname flnm))])
     663       (merge-test-config major-tbl major-lst) ) )
    652664   flnms) )
    653665
     
    677689      (tagged-alist-option-set! lst interpreter-option 'interpret 'option option->list)
    678690      (tagged-alist-option-set! lst interpreter 'interpret 'command)
    679       (tagged-alist-option-set! lst test-ignore 'test 'ignore option->list)
    680       (tagged-alist-option-set! lst test-skip 'test 'skip option->list)
    681       (tagged-alist-option-set! lst test-take 'test 'take option->list)
    682       (tagged-alist-option-set! lst test-setup 'test 'setup option->list)
    683691      (tagged-alist-option-set! lst test-compile 'test 'compile)
    684692      (tagged-alist-option-set! lst test-interpret 'test 'interpret)
     
    693701             (option-usage-error 'failure-exit "invalid exit code" cod) )
    694702           cod)))
     703      ;FIXME these should allow multiple instances
     704      (tagged-alist-option-set! lst test-ignore 'test 'ignore option->list)
     705      (tagged-alist-option-set! lst test-skip 'test 'skip option->list)
     706      (tagged-alist-option-set! lst test-take 'test 'take option->list)
     707      (tagged-alist-option-set! lst test-setup 'test 'setup option->list)
    695708      ; Process test-files
    696709      (if (pair? oprs)
Note: See TracChangeset for help on using the changeset viewer.