1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
-
+
|
;; Copyright 2006-2011, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; (include "common.scm")
;; (include "megatest-version.scm")
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos) ;; (srfi 18) extras)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
|
| ︙ | | |
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
|
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
|
+
-
+
+
|
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;;======================================================================
(if (and (args:get-arg "-server")
(not (or (args:get-arg "-runall")
(args:get-arg "-runtests"))))
(let* ((toppath (setup-for-run))
(db (if toppath (open-db) #f)))
(debug:print 0 "INFO: Starting the standalone server")
(if db
(server:start db (args:get-arg "-server"))
(let ((th2 (server:start db (args:get-arg "-server"))))
(thread-join! th2))
(debug:print 0 "ERROR: Failed to setup for megatest"))))
;;======================================================================
;; full run
;;======================================================================
;; get lock in db for full run for this directory
|
| ︙ | | |
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
|
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
|
-
+
-
+
|
(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)))
(paths (rdb:test-get-paths-matching db keynames target)))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
paths)))
;; else do a general-run-call
(general-run-call
"-test-paths"
"Get paths to tests"
(lambda (db target runname keys keynames keyvallst)
(let* ((itempatt (args:get-arg "-itempatt"))
(paths (db:test-get-paths-matching db keynames target)))
(paths (rdb:test-get-paths-matching db keynames target)))
(for-each (lambda (path)
(print path))
paths))))))
;;======================================================================
;; Archive tests
;;======================================================================
|
| ︙ | | |
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
|
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
|
+
-
+
-
+
-
+
|
(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 (args:get-arg "-load-test-data")
;; has sub commands that are rdb:
(db:load-test-data db run-id test-name itemdat))
(if (args:get-arg "-setlog")
(test-set-log! db run-id test-name itemdat (args:get-arg "-setlog")))
(rdb:test-set-log! db run-id test-name itemdat (args:get-arg "-setlog")))
(if (args:get-arg "-set-toplog")
(test-set-toplog! db run-id test-name (args:get-arg "-set-toplog")))
(rdb: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
(rdb:tests:summarize-items db run-id test-name #t)) ;; do force here
(if (args:get-arg "-runstep")
(if (null? remargs)
(begin
(debug:print 0 "ERROR: nothing specified to run!")
(sqlite3:finalize! db)
(exit 6))
(let* ((stepname (args:get-arg "-runstep"))
|
| ︙ | | |
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
|
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
|
-
+
|
(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)
(test-set-log! db run-id test-name itemdat htmllogfile)))
(rdb:test-set-log! db run-id test-name itemdat htmllogfile)))
(rdb:teststep-set-status! db run-id test-name stepname "end" exitstat itemdat (args:get-arg "-m") 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
)))
|
| ︙ | | |
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
|
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
|
-
+
|
(if (and (args:get-arg "-test-status")
(or (not state)
(not status)))
(begin
(debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help)
(sqlite3:finalize! db)
(exit 6)))
(test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m") otherdata)))
(rtests:test-set-status! db run-id test-name state newstatus itemdat (args:get-arg "-m") otherdata)))
(sqlite3:finalize! db)
(set! *didsomething* #t))))
(if (args:get-arg "-showkeys")
(let ((db #f)
(keys #f))
(if (not (setup-for-run))
|
| ︙ | | |