︙ | | | ︙ | |
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
(declare (uses genexample))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2012
Usage: megatest [options]
|
>
|
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
(declare (uses genexample))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")
(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2012
Usage: megatest [options]
|
︙ | | | ︙ | |
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
-gen-megatest-test : create a skeleton megatest test. You will be prompted for info
Examples
# Get test path, use '.' to get a single path or a specific path/file pattern
megatest -test-files 'logs/*.log' -target ubuntu/n%/no% :runname w49% -testpatt test_mt%
Called as " (string-intersperse (argv) " ")))
;; -gui : start a gui interface
;; -config fname : override the runconfig file with fname
;; process args
(define remargs (args:get-args
(argv)
|
|
>
|
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
-gen-megatest-test : create a skeleton megatest test. You will be prompted for info
Examples
# Get test path, use '.' to get a single path or a specific path/file pattern
megatest -test-files 'logs/*.log' -target ubuntu/n%/no% :runname w49% -testpatt test_mt%
Called as " (string-intersperse (argv) " ") "
Built from " megatest-fossil-hash ))
;; -gui : start a gui interface
;; -config fname : override the runconfig file with fname
;; process args
(define remargs (args:get-args
(argv)
|
︙ | | | ︙ | |
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
|
(if (args:get-arg "-list-runs")
(let* ((db (begin
(setup-for-run)
(open-db)))
(runpatt (args:get-arg "-list-runs"))
(testpatt (args:get-arg "-testpatt"))
(itempatt (args:get-arg "-itempatt"))
(runsdat (rdb:get-runs db runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(keys (rdb:get-keys db))
(keynames (map key:get-fieldname keys)))
(if (not (args:get-arg "-server"))
(server:client-setup db))
;; Each run
(for-each
(lambda (run)
(debug:print 1 "Run: "
(string-intersperse (map (lambda (x)
(db:get-value-by-header run header x))
keynames) "/")
"/"
(db:get-value-by-header run header "runname")
" status: " (db:get-value-by-header run header "state"))
(let ((run-id (db:get-value-by-header run header "id")))
(let ((tests (rdb:get-tests-for-run db run-id testpatt itempatt '() '())))
;; Each test
(for-each
(lambda (test)
(format #t
" Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
(conc (db:test-get-testname test)
(if (equal? (db:test-get-item-path test) "")
|
|
|
|
|
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
|
(if (args:get-arg "-list-runs")
(let* ((db (begin
(setup-for-run)
(open-db)))
(runpatt (args:get-arg "-list-runs"))
(testpatt (args:get-arg "-testpatt"))
(itempatt (args:get-arg "-itempatt"))
(runsdat (db:get-runs db runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(keys (db:get-keys db))
(keynames (map key:get-fieldname keys)))
(if (not (args:get-arg "-server"))
(server:client-setup db))
;; Each run
(for-each
(lambda (run)
(debug:print 1 "Run: "
(string-intersperse (map (lambda (x)
(db:get-value-by-header run header x))
keynames) "/")
"/"
(db:get-value-by-header run header "runname")
" status: " (db:get-value-by-header run header "state"))
(let ((run-id (db:get-value-by-header run header "id")))
(let ((tests (db:get-tests-for-run db run-id testpatt itempatt '() '())))
;; Each test
(for-each
(lambda (test)
(format #t
" Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
(conc (db:test-get-testname test)
(if (equal? (db:test-get-item-path test) "")
|
︙ | | | ︙ | |
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
|
(begin
(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
(exit 1)))
(set! db (open-db))
(if (not (args:get-arg "-server"))
(server:client-setup db))
(let* ((itempatt (args:get-arg "-itempatt"))
(keys (rdb:get-keys db))
(keynames (map key:get-fieldname keys))
(paths (rdb:test-get-paths-matching db keynames target (args:get-arg "-test-files"))))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
paths)))
;; else do a general-run-call
(general-run-call
"-test-files"
"Get paths to test"
(lambda (db target runname keys keynames keyvallst)
(let* ((itempatt (args:get-arg "-itempatt"))
(paths (rdb:test-get-paths-matching db keynames target (args:get-arg "-test-files"))))
(for-each (lambda (path)
(print path))
paths))))))
;;======================================================================
;; Archive tests
;;======================================================================
|
|
|
|
|
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
|
(begin
(debug:print 0 "Failed to setup, giving up on -test-paths or -test-files, exiting")
(exit 1)))
(set! db (open-db))
(if (not (args:get-arg "-server"))
(server:client-setup db))
(let* ((itempatt (args:get-arg "-itempatt"))
(keys (db:get-keys db))
(keynames (map key:get-fieldname keys))
(paths (db:test-get-paths-matching db keynames target (args:get-arg "-test-files"))))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
paths)))
;; else do a general-run-call
(general-run-call
"-test-files"
"Get paths to test"
(lambda (db target runname keys keynames keyvallst)
(let* ((itempatt (args:get-arg "-itempatt"))
(paths (db:test-get-paths-matching db keynames target (args:get-arg "-test-files"))))
(for-each (lambda (path)
(print path))
paths))))))
;;======================================================================
;; Archive tests
;;======================================================================
|
︙ | | | ︙ | |
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
|
(begin
(debug:print 0 "Failed to setup, giving up on -archive, exiting")
(exit 1)))
(set! db (open-db))
(if (not (args:get-arg "-server"))
(server:client-setup db))
(let* ((itempatt (args:get-arg "-itempatt"))
(keys (rdb:get-keys db))
(keynames (map key:get-fieldname keys))
(paths (db:test-get-paths-matching db keynames target)))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
paths)))
;; else do a general-run-call
|
|
|
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
|
(begin
(debug:print 0 "Failed to setup, giving up on -archive, exiting")
(exit 1)))
(set! db (open-db))
(if (not (args:get-arg "-server"))
(server:client-setup db))
(let* ((itempatt (args:get-arg "-itempatt"))
(keys (db:get-keys db))
(keynames (map key:get-fieldname keys))
(paths (db:test-get-paths-matching db keynames target)))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
paths)))
;; else do a general-run-call
|
︙ | | | ︙ | |
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
|
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
(if (not (args:get-arg "-server"))
(server:client-setup db))
(if (and state status)
(rdb:teststep-set-status! db test-id step state status itemdat (args:get-arg "-m") logfile)
(begin
(debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
(exit 6)))
(sqlite3:finalize! db)
(set! *didsomething* #t))))
(if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status
|
|
|
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
|
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
(if (not (args:get-arg "-server"))
(server:client-setup db))
(if (and state status)
(db:teststep-set-status! db test-id step state status itemdat (args:get-arg "-m") logfile)
(begin
(debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
(exit 6)))
(sqlite3:finalize! db)
(set! *didsomething* #t))))
(if (or (args:get-arg "-setlog") ;; since setting up is so costly lets piggyback on -test-status
|
︙ | | | ︙ | |
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
|
(if (not (args:get-arg "-server"))
(server:client-setup db))
(if (args:get-arg "-load-test-data")
;; has sub commands that are rdb:
(db:load-test-data db test-id))
(if (args:get-arg "-setlog")
(let ((logfname (args:get-arg "-setlog")))
(rdb:test-set-log! db test-id logfname)))
(if (args:get-arg "-set-toplog")
(rtests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
(if (args:get-arg "-summarize-items")
(tests:summarize-items db run-id test-name #t)) ;; do force here
(if (args:get-arg "-runstep")
(if (null? remargs)
(begin
|
|
|
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
|
(if (not (args:get-arg "-server"))
(server:client-setup db))
(if (args:get-arg "-load-test-data")
;; has sub commands that are rdb:
(db:load-test-data db test-id))
(if (args:get-arg "-setlog")
(let ((logfname (args:get-arg "-setlog")))
(db:test-set-log! db test-id logfname)))
(if (args:get-arg "-set-toplog")
(rtests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
(if (args:get-arg "-summarize-items")
(tests:summarize-items db run-id test-name #t)) ;; do force here
(if (args:get-arg "-runstep")
(if (null? remargs)
(begin
|
︙ | | | ︙ | |
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
|
((tcsh csh ksh) ">&")
((zsh bash sh ash) "2>&1 >")
(else ">&")))
(fullcmd (conc "(" (string-intersperse
(cons cmd params) " ")
") " redir " " logfile)))
;; mark the start of the test
(rdb:teststep-set-status! db test-id stepname "start" "n/a" itemdat (args:get-arg "-m") logfile)
;; close the db
;; (sqlite3:finalize! db)
;; run the test step
(debug:print 2 "INFO: Running \"" fullcmd "\"")
(change-directory startingdir)
(set! exitstat (system fullcmd)) ;; cmd params))
(set! *globalexitstatus* exitstat)
|
|
|
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
|
((tcsh csh ksh) ">&")
((zsh bash sh ash) "2>&1 >")
(else ">&")))
(fullcmd (conc "(" (string-intersperse
(cons cmd params) " ")
") " redir " " logfile)))
;; mark the start of the test
(db:teststep-set-status! db test-id stepname "start" "n/a" itemdat (args:get-arg "-m") logfile)
;; close the db
;; (sqlite3:finalize! db)
;; run the test step
(debug:print 2 "INFO: Running \"" fullcmd "\"")
(change-directory startingdir)
(set! exitstat (system fullcmd)) ;; cmd params))
(set! *globalexitstatus* exitstat)
|
︙ | | | ︙ | |
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
|
(oldexitstat exitstat)
(cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
(debug:print 2 "INFO: running \"" cmd "\"")
(change-directory startingdir)
(set! exitstat (system cmd))
(set! *globalexitstatus* exitstat) ;; no necessary
(change-directory testpath)
(rdb:test-set-log! db test-id htmllogfile)))
(let ((msg (args:get-arg "-m")))
(rdb:teststep-set-status! db test-id stepname "end" exitstat itemdat msg logfile))
;; (sqlite3:finalize! db)
;;(if (not (eq? exitstat 0))
;; (exit 254)) ;; (exit exitstat) doesn't work?!?
;; open the db
;; mark the end of the test
)))
(if (or (args:get-arg "-test-status")
|
|
|
|
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
|
(oldexitstat exitstat)
(cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
(debug:print 2 "INFO: running \"" cmd "\"")
(change-directory startingdir)
(set! exitstat (system cmd))
(set! *globalexitstatus* exitstat) ;; no necessary
(change-directory testpath)
(db:test-set-log! db test-id htmllogfile)))
(let ((msg (args:get-arg "-m")))
(db:teststep-set-status! db test-id stepname "end" exitstat itemdat msg logfile))
;; (sqlite3:finalize! db)
;;(if (not (eq? exitstat 0))
;; (exit 254)) ;; (exit exitstat) doesn't work?!?
;; open the db
;; mark the end of the test
)))
(if (or (args:get-arg "-test-status")
|
︙ | | | ︙ | |
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
|
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
(if (not (args:get-arg "-server"))
(server:client-setup db))
(set! keys (rdb:get-keys db))
(debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", "))
(sqlite3:finalize! db)
(set! *didsomething* #t)))
(if (args:get-arg "-gui")
(begin
(debug:print 0 "Look at the dashboard for now")
|
|
|
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
|
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
(if (not (args:get-arg "-server"))
(server:client-setup db))
(set! keys (db:get-keys db))
(debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", "))
(sqlite3:finalize! db)
(set! *didsomething* #t)))
(if (args:get-arg "-gui")
(begin
(debug:print 0 "Look at the dashboard for now")
|
︙ | | | ︙ | |