| ︙ | | |
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
|
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
|
-
+
|
(if (and (not (null? remargs))
(not (or
(args:get-arg "-runstep")
(args:get-arg "-envcap")
(args:get-arg "-envdelta")
)
))
(debug:print 0 *default-log-port* "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
(debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
;; immediately set MT_TARGET if -reqtarg or -target are available
;;
(let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target"))))
(if targ (setenv "MT_TARGET" targ)))
;; The watchdog is to keep an eye on things like db sync etc.
|
| ︙ | | |
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
|
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
|
-
+
|
(print help)
(exit)))
(if (args:get-arg "-start-dir")
(if (file-exists? (args:get-arg "-start-dir"))
(change-directory (args:get-arg "-start-dir"))
(begin
(debug:print 0 *default-log-port* "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
(debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
(exit 1))))
(if (args:get-arg "-version")
(begin
(print (common:version-signature)) ;; (print megatest-version)
(exit)))
|
| ︙ | | |
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
|
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
|
-
-
+
+
|
(for-each
(lambda (f)
(handle-exceptions
exn
(debug:print 0 *default-log-port* "WARNING: Failed to remove file " f)
(delete-file f)))
files))))
(debug:print 0 *default-log-port* "ERROR: -clean-cache requires -runname."))
(debug:print 0 *default-log-port* "ERROR: -clean-cache requires -target or -reqtarg"))))
(debug:print-error 0 *default-log-port* "-clean-cache requires -runname."))
(debug:print-error 0 *default-log-port* "-clean-cache requires -target or -reqtarg"))))
(if (args:get-arg "-env2file")
(begin
(save-environment-as-files (args:get-arg "-env2file"))
(set! *didsomething* #t)))
|
| ︙ | | |
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
|
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
|
-
+
-
+
|
(with-output-to-file
(args:get-arg "-o")
(lambda ()
(env:print added removed changed)))
(env:print added removed changed))
(env:close-database db)
(set! *didsomething* #t))
(debug:print 0 *default-log-port* "ERROR: Parameter to -envdelta should be new=star-end")))))
(debug:print-error 0 *default-log-port* "Parameter to -envdelta should be new=star-end")))))
;;======================================================================
;; Start the server - can be done in conjunction with -runall or -runtests (one day...)
;; we start the server if not running else start the client thread
;;======================================================================
(if (args:get-arg "-server")
;; Server? Start up here.
;;
(let ((tl (launch:setup))
(run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id")))))
(if run-id
(begin
(server:launch run-id)
(set! *didsomething* #t))
(debug:print 0 *default-log-port* "ERROR: server requires run-id be specified with -run-id")))
(debug:print-error 0 *default-log-port* "server requires run-id be specified with -run-id")))
;; Not a server? This section will decide how to communicate
;;
;; Setup client for all expect listed here
(if (null? (lset-intersection
equal?
(hash-table-keys args:arg-hash)
|
| ︙ | | |
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
|
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
|
-
+
|
(for-each (lambda (x)
;; (print "[" x "]"))
(print x))
targets))
((json)
(json-write targets))
(else
(debug:print 0 *default-log-port* "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
(debug:print-error 0 *default-log-port* "dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets")))
(set! *didsomething* #t)))
;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig
;;
(define (full-runconfigs-read)
;; in the envprocessing branch the below code replaces the further below code
;; (if (eq? *configstatus* 'fulldata)
|
| ︙ | | |
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
|
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
|
-
+
|
((not (args:get-arg "-dumpmode"))
(pp (hash-table->alist data)))
((string=? (args:get-arg "-dumpmode") "json")
(json-write data))
((string=? (args:get-arg "-dumpmode") "ini")
(configf:config->ini data))
(else
(debug:print 0 *default-log-port* "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
(debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
(set! *didsomething* #t))
(pop-directory)))
(if (args:get-arg "-show-config")
(let ((tl (launch:setup))
(data *configdat*)) ;; (read-config "megatest.config" #f #t)))
(push-directory *toppath*)
|
| ︙ | | |
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
|
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
|
-
+
|
((not (args:get-arg "-dumpmode"))
(pp (hash-table->alist data)))
((string=? (args:get-arg "-dumpmode") "json")
(json-write data))
((string=? (args:get-arg "-dumpmode") "ini")
(configf:config->ini data))
(else
(debug:print 0 *default-log-port* "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
(debug:print-error 0 *default-log-port* "-dumpmode of " (args:get-arg "-dumpmode") " not recognised")))
(set! *didsomething* #t)
(pop-directory)))
(if (args:get-arg "-show-cmdinfo")
(if (or (args:get-arg ":value")(getenv "MT_CMDINFO"))
(let ((data (common:read-encoded-string (or (args:get-arg ":value")(getenv "MT_CMDINFO")))))
(if (equal? (args:get-arg "-dumpmode") "json")
|
| ︙ | | |
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
|
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
|
-
+
-
+
-
+
-
+
|
;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action)
(let* ((runrec (runs:runrec-make-record))
(target (common:args-get-target)))
(cond
((not target)
(debug:print 0 *default-log-port* "ERROR: Missing required parameter for " action ", you must specify -target or -reqtarg")
(debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify -target or -reqtarg")
(exit 1))
((not (or (args:get-arg ":runname")
(args:get-arg "-runname")))
(debug:print 0 *default-log-port* "ERROR: Missing required parameter for " action ", you must specify the run name pattern with -runname patt")
(debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the run name pattern with -runname patt")
(exit 2))
((not (args:get-arg "-testpatt"))
(debug:print 0 *default-log-port* "ERROR: Missing required parameter for " action ", you must specify the test pattern with -testpatt")
(debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the test pattern with -testpatt")
(exit 3))
(else
(if (not (car *configinfo*))
(begin
(debug:print 0 *default-log-port* "ERROR: Attempted " action "on test(s) but run area config file not found")
(debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
(exit 1))
;; put test parameters into convenient variables
(begin
;; check for correct version, exit with message if not correct
(common:exit-on-version-changed)
(runs:operate-on action
target
|
| ︙ | | |
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
|
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
|
-
+
|
;; generate the lookup map test-field-name => index-number
(let loop ((hed (car adj-tests-spec))
(tal (cdr adj-tests-spec))
(idx 0))
(hash-table-set! test-field-index hed idx)
(if (not (null? tal))(loop (car tal)(cdr tal)(+ idx 1))))
(begin
(debug:print 0 *default-log-port* "ERROR: Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
(debug:print-error 0 *default-log-port* "Invalid test fields specified: " (string-intersperse invalid-tests-spec ", "))
(exit)))))
;; Each run
(for-each
(lambda (run)
(let ((targetstr (string-intersperse (map (lambda (x)
(db:get-value-by-header run header x))
|
| ︙ | | |
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
|
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
|
-
+
|
(newline)))))
(for-each
(lambda (test)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "ERROR: Bad data in test record? " test)
(debug:print-error 0 *default-log-port* "Bad data in test record? " test)
(print "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port)))
(let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
(testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
(itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
(comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test))
|
| ︙ | | |
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
|
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
|
-
+
|
(state (args:get-arg ":state"))
(status (args:get-arg ":status"))
(target (args:get-arg "-target"))
(toppath (assoc/default 'toppath cmdinfo)))
(change-directory toppath)
(if (not target)
(begin
(debug:print 0 *default-log-port* "ERROR: -target is required.")
(debug:print-error 0 *default-log-port* "-target is required.")
(exit 1)))
(if (not (launch:setup))
(begin
(debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting")
(exit 1)))
(let* ((keys (rmt:get-keys))
;; db:test-get-paths must not be run remote
|
| ︙ | | |
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
|
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
|
-
+
-
+
|
(let ((run-id (string->number (car params)))
(test-id (string->number (cadr params))))
(if (and run-id test-id)
(begin
(launch:recover-test run-id test-id)
(set! *didsomething* #t))
(begin
(debug:print 0 *default-log-port* "ERROR: bad run-id or test-id, must be integers")
(debug:print-error 0 *default-log-port* "bad run-id or test-id, must be integers")
(exit 1)))))))
;;======================================================================
;; Test commands (i.e. for use inside tests)
;;======================================================================
(define (megatest:step step state status logfile msg)
(if (not (getenv "MT_CMDINFO"))
(begin
(debug:print 0 *default-log-port* "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!")
(exit 5))
(let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
|
| ︙ | | |
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
|
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
|
-
+
|
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(if (and state status)
(let ((comment (launch:load-logpro-dat run-id test-id step)))
;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
(rmt:teststep-set-status! run-id test-id step state status (or comment msg) logfile))
(begin
(debug:print 0 *default-log-port* "ERROR: You must specify :state and :status with every call to -step")
(debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -step")
(exit 6))))))
(if (args:get-arg "-step")
(begin
(megatest:step
(args:get-arg "-step")
(or (args:get-arg "-state")(args:get-arg ":state"))
|
| ︙ | | |
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
|
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
|
-
+
|
(args:get-arg "-test-status")
(args:get-arg "-set-values")
(args:get-arg "-load-test-data")
(args:get-arg "-runstep")
(args:get-arg "-summarize-items"))
(if (not (getenv "MT_CMDINFO"))
(begin
(debug:print 0 *default-log-port* "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
(debug:print-error 0 *default-log-port* "MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!")
(exit 5))
(let* ((startingdir (current-directory))
(cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO")))
(transport (assoc/default 'transport cmdinfo))
(testpath (assoc/default 'testpath cmdinfo))
(test-name (assoc/default 'test-name cmdinfo))
(runscript (assoc/default 'runscript cmdinfo))
|
| ︙ | | |
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
|
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
|
-
+
|
(tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
(if (args:get-arg "-summarize-items")
;; DO NOT run remote
(tests:summarize-items run-id test-id test-name #t)) ;; do force here
(if (args:get-arg "-runstep")
(if (null? remargs)
(begin
(debug:print 0 *default-log-port* "ERROR: nothing specified to run!")
(debug:print-error 0 *default-log-port* "nothing specified to run!")
(if db (sqlite3:finalize! db))
(exit 6))
(let* ((stepname (args:get-arg "-runstep"))
(logprofile (args:get-arg "-logpro"))
(logfile (conc stepname ".log"))
(cmd (if (null? remargs) #f (car remargs)))
(params (if cmd (cdr remargs) '()))
|
| ︙ | | |
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
|
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
|
-
+
|
(hash-table-set! res key (args:get-arg key))))
(list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable"))
res)))
(if (and (args:get-arg "-test-status")
(or (not state)
(not status)))
(begin
(debug:print 0 *default-log-port* "ERROR: You must specify :state and :status with every call to -test-status\n" help)
(debug:print-error 0 *default-log-port* "You must specify :state and :status with every call to -test-status\n" help)
(if (sqlite3:database? db)(sqlite3:finalize! db))
(exit 6)))
(let* ((msg (args:get-arg "-m"))
(numoth (length (hash-table-keys otherdata))))
;; Convert to rpc inside the tests:test-set-status! call, not here
(tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area))))
(if (sqlite3:database? db)(sqlite3:finalize! db))
|
| ︙ | | |