| ︙ | | |
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
+
+
|
(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
(declare (uses daemon))
(declare (uses db))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
|
| ︙ | | |
237
238
239
240
241
242
243
244
245
246
247
248
249
250
|
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
|
+
+
+
+
|
"-rebuild-db"
"-cleanup-db"
"-rollup"
"-update-meta"
"-gen-megatest-area"
"-mark-incompletes"
"-convert-to-norm"
"-convert-to-old"
"-import-megatest.db"
"-logging"
"-v" ;; verbose 2, more than normal (normal is 1)
"-q" ;; quiet 0, errors/warnings only
)
args:arg-hash
0))
|
| ︙ | | |
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
|
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
|
-
+
+
-
+
|
;;
;; Setup client for all expect listed here
(if (null? (lset-intersection
equal?
(hash-table-keys args:arg-hash)
'("-list-servers"
"-stop-server"
"-show-cmdinfo")))
"-show-cmdinfo"
"-list-runs")))
(if (setup-for-run)
(begin
;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
;; if not list or kill then start a client (if appropriate)
(if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
(eq? (length (hash-table-keys args:arg-hash)) 0))
(debug:print-info 1 "Server connection not needed")
;; ok, so lets connect to the server
(let* ((transport-from-config (configf:lookup *configdat* "setup" "transport"))
(transport-from-cmdln (args:get-arg "-transport"))
|
| ︙ | | |
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
|
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
|
+
+
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
transport-from-config
"fs"))))
(debug:print 2 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo)
(case chosen-transport
((http)
(set! *transport-type 'http)
(server:ensure-running)
;; Get rid of this
(client:launch))
(else ;; (fs)
(debug:print 0 "ERROR: Should NOT be getting here! fs transport is no longer supported")
(set! *transport-type* 'fs)
(set! *megatest-db* (open-db))))))))))
(set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))
;; (cond
;; ;; command line overrides other mechanisms
;; (transport-from-cmdln
;; (if (equal? transport-from-cmdln "fs")
;; (set! *transport-type* 'fs)
;; (begin
;; (server:ensure-running)
;; (client:launch))))
;; ;; cmdinfo is second priority
;; (transport-from-cmdinfo
;; (if (equal? transport-from-cmdinfo "fs")
;; (set! *transport-type* 'fs)
;; (begin
;; (server:ensure-running)
;; (client:launch))))
;; ;; config file is next highest priority for determinining transport
;; (transport-from-config
;; (if (equal? transport-from-config "fs")
;; (set! *transport-type* 'fs)
;; (begin
;; (server:ensure-running)
;; (client:launch))))
;; (else
;; (set! *transport-type* 'fs)))))))))
|
| ︙ | | |
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
|
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
|
-
+
|
(interface (vector-ref server 3))
(pullport (vector-ref server 4))
(pubport (vector-ref server 5))
(start-time (vector-ref server 6))
(priority (vector-ref server 7))
(state (vector-ref server 8))
(mt-ver (vector-ref server 9))
(last-update (vector-ref server 10)) ;; (open-run-close tasks:server-alive? tasks:open-db #f hostname: hostname port: port))
(last-update (vector-ref server 10))
(transport (vector-ref server 11))
(killed #f)
(status (< last-update 20)))
;; (zmq-sockets (if status (server:client-connect hostname port) #f)))
;; no need to login as status of #t indicates we are connecting to correct
;; server
(if (equal? state "dead")
|
| ︙ | | |
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
|
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
|
-
+
+
-
+
+
+
+
-
-
+
|
;;======================================================================
;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
(if (or (args:get-arg "-list-runs")
(args:get-arg "-list-db-targets"))
(if (setup-for-run)
(let* ((db (open-db))
(let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
(runpatt (args:get-arg "-list-runs"))
(testpatt (if (args:get-arg "-testpatt")
(args:get-arg "-testpatt")
"%"))
(keys (db:get-keys dbstruct))
(runsdat (db:get-runs db runpatt #f #f '()))
;; (runsdat (db:get-runs dbstruct runpatt #f #f '()))
(runsdat (db:get-runs-by-patt dbstruct keys runpatt (or (args:get-arg "-target")
(args:get-arg "-reqtarg")) #f #f))
;; (cdb:remote-run db:get-runs #f runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(keys (db:get-keys db))
(tests (db:get-tests-for-run db run-id testpatt '() '() #f #f #f 'testname 'asc #f)))
(tests (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f)))
(print "Run: " targetstr "/" (db:get-value-by-header run header "runname")
" status: " (db:get-value-by-header run header "state")
" run-id: " run-id ", number tests: " (length tests))
(for-each
(lambda (test)
(format #t
" Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n"
|
| ︙ | | |
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
|
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
|
-
-
+
+
+
+
-
+
+
-
+
|
(db:test-get-host test))
(if (not (or (equal? (db:test-get-status test) "PASS")
(equal? (db:test-get-status test) "WARN")
(equal? (db:test-get-state test) "NOT_STARTED")))
(begin
(print " cpuload: " (db:test-get-cpuload test)
"\n diskfree: " (db:test-get-diskfree test)
"\n uname: " (db:test-get-uname test)
"\n rundir: " (db:test-get-rundir test)
"\n uname: " ;; (sdb:qry 'getstr
(db:test-get-uname test) ;; )
"\n rundir: " ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb*
(db:test-get-rundir test) ;; )
)
;; Each test
;; DO NOT remote run
(let ((steps (db:get-steps-for-test db (db:test-get-id test))))
(let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test))))
(for-each
(lambda (step)
(format #t
" Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
(tdb:step-get-stepname step)
(tdb:step-get-state step)
(tdb:step-get-status step)
(tdb:step-get-event_time step)))
steps)))))
tests)))))
runs)
(db:close-all dbstruct)
(set! *didsomething* #t))))
(set! *didsomething* #t))))
;;======================================================================
;; full run
;;======================================================================
;; get lock in db for full run for this directory
;; for all tests with deps
|
| ︙ | | |
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
|
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
|
-
-
+
-
+
|
(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))
(run-id (assoc/default 'run-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(db #f)
(paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files"))))
(paths (tests:test-get-paths-matching keys 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 (target runname keys keyvals)
(let* ((db #f)
;; DO NOT run remote
(paths (db:test-get-paths-matching db keys target (args:get-arg "-test-files"))))
(paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files"))))
(for-each (lambda (path)
(print path))
paths))))))
;;======================================================================
;; Archive tests
;;======================================================================
|
| ︙ | | |
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
|
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
|
-
-
+
-
-
+
-
+
+
-
-
-
+
-
+
-
-
+
-
-
+
+
|
(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))
(run-id (assoc/default 'run-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(db (open-db))
(let* ((keys (db:get-keys db))
(let* ((keys (rmt:get-keys))
;; DO NOT run remote
(paths (db:test-get-paths-matching db keys target)))
(if (sqlite3:database? db)(sqlite3:finalize! db)))
;; (if (sqlite3:database? db)(sqlite3:finalize! db))
)
;; else do a general-run-call
(general-run-call
"-test-paths"
"Get paths to tests"
(lambda (target runname keys keyvals)
(let* ((db (open-db))
;; DO NOT run remote
(paths (db:test-get-paths-matching db keys target)))
paths)
paths))))))
(sqlite3:finalize! db))))))
(let ((db (open-db))
(let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t))
(outputfile (args:get-arg "-extract-ods"))
(runspatt (args:get-arg ":runname"))
(pathmod (args:get-arg "-pathmod")))
;; (keyvalalist (keys->alist keys "%")))
(debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals)
(db:extract-ods-file db outputfile keyvals (if runspatt runspatt "%") pathmod)
(sqlite3:finalize! db)
(db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod)
(db:close-all dbstruct)
(set! *didsomething* #t)))))
;;======================================================================
;; execute the test
;; - gets called on remote host
;; - receives info from the -execute param
;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
|
| ︙ | | |
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
|
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
|
-
+
|
;; The transport is handled earlier in the loading process of megatest.
;; (set! *transport-type* (string->symbol transport))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (and state status)
(rmt:teststep-set-status! test-id step state status msg logfile)
(rmt:teststep-set-status! run-id test-id step state status msg logfile)
(begin
(debug:print 0 "ERROR: You must specify :state and :status with every call to -step")
(exit 6))))))
(if (args:get-arg "-step")
(begin
(megatest:step
|
| ︙ | | |
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
|
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
|
-
+
+
-
+
|
(change-directory work-area)
;; can setup as client for server mode now
;; (client:setup)
(if (args:get-arg "-load-test-data")
;; has sub commands that are rdb:
;; DO NOT put this one into either cdb:remote-run or open-run-close
(tdb:load-test-data test-id))
(tdb:load-test-data run-id test-id))
(if (args:get-arg "-setlog")
(let ((logfname (args:get-arg "-setlog")))
;; (cdb:test-set-log! *runremote* test-id (sdb:qry 'getid logfname))))
(rmt:test-set-log! test-id logfname)))
(rmt:test-set-log! run-id test-id logfname)))
(if (args:get-arg "-set-toplog")
;; DO NOT run remote
(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 db run-id test-id test-name #t)) ;; do force here
(if (args:get-arg "-runstep")
|
| ︙ | | |
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
|
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
|
-
+
+
-
+
-
+
|
((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
(rmt:teststep-set-status! test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
(rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile)
;; run the test step
(debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir)
(change-directory startingdir)
(set! exitstat (system fullcmd))
(set! *globalexitstatus* exitstat)
;; (change-directory testpath)
;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log"))
(if logprofile
(let* ((htmllogfile (conc stepname ".html"))
(oldexitstat exitstat)
(cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
(debug:print-info 2 "running \"" cmd "\"")
(change-directory startingdir)
(set! exitstat (system cmd))
(set! *globalexitstatus* exitstat) ;; no necessary
(change-directory testpath)
;; (cdb:test-set-log! *runremote* test-id (sdb:qry 'getid htmllogfile))))
(rmt:test-set-log! test-id htmllogfile)))
(rmt:test-set-log! run-id test-id htmllogfile)))
(let ((msg (args:get-arg "-m")))
(rmt:teststep-set-status! test-id stepname "end" exitstat msg logfile))
(rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile))
)))
(if (or (args:get-arg "-test-status")
(args:get-arg "-set-values"))
(let ((newstatus (cond
((number? status) (if (equal? status 0) "PASS" "FAIL"))
((and (string? status)
(string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL"))
|
| ︙ | | |
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
|
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
|
-
+
|
(begin
(debug:print 0 "ERROR: 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! test-id state newstatus msg otherdata work-area: work-area))))
(tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area))))
(if (sqlite3:database? db)(sqlite3:finalize! db))
(set! *didsomething* #t))))
;;======================================================================
;; Various helper commands can go below here
;;======================================================================
|
| ︙ | | |
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
|
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
|
-
-
+
+
-
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;; Start a repl
;;======================================================================
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (setup-for-run))
(db (if toppath (open-db) #f)))
(if db
(dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
(if dbstruct
(begin
(set! *db* db)
(set! *db* dbstruct)
(set! *client-non-blocking-mode* #t)
(import readline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(gnu-history-install-file-manager
(string-append
(or (get-environment-variable "HOME") ".") "/.megatest_history"))
(current-input-port (make-gnu-readline-port "megatest> "))
(if (args:get-arg "-repl")
(repl)
(load (args:get-arg "-load"))))
(load (args:get-arg "-load")))
(db:close-all dbstruct))
(exit))
(set! *didsomething* #t)))
;; Not converted to use dbstruct yet
;;
(if (args:get-arg "-convert-to-norm")
(let* ((toppath (setup-for-run))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t))))
(for-each
(lambda (field)
(let ((dat '()))
(debug:print-info 0 "Getting data for field " field)
(sqlite3:for-each-row
(lambda (id val)
(set! dat (cons (list id val) dat)))
(get-db db run-id)
(conc "SELECT id," field " FROM tests;"))
(debug:print-info 0 "found " (length dat) " items for field " field)
(let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;"))))
(for-each
(lambda (item)
(let ((newval ;; (sdb:qry 'getid
(cadr item))) ;; )
(if (not (equal? newval (cadr item)))
(debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item)))
(sqlite3:execute qry newval (car item))))
dat)
(sqlite3:finalize! qry))))
(db:close-all dbstruct)
(list "uname" "rundir" "final_logf" "comment"))
(set! *didsomething* #t)))
(if (args:get-arg "-import-megatest.db")
(let* ((toppath (setup-for-run))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f))
(mtdb (if toppath (db:open-megatest-db)))
(run-ids (if toppath (db:get-run-ids mtdb))))
;; sync runs, test_meta etc.
(db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f))
(for-each
(lambda (run-id)
(let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
(debug:print 0 "INFO: Updating " (length testrecs) " records for run-id=" run-id)
(db:replace-test-records dbstruct run-id testrecs)))
run-ids)
(set! *didsomething* #t)
(db:close-all dbstruct)))
;;======================================================================
;; Exit and clean up
;;======================================================================
(if *runremote* (close-all-connections!))
;; this is the socket if we are a client
;; (if (and *runremote*
;; (socket? *runremote*))
;; (close-socket *runremote*))
;; (if sdb:qry (sdb:qry 'finalize #f))
;; (if *fdb* (filedb:finalize-db! *fdb*))
(if (not *didsomething*)
(debug:print 0 help))
;; (if *runremote* (rpc:close-all-connections!))
(if (not (eq? *globalexitstatus* 0))
(if (or (args:get-arg "-runtests")(args:get-arg "-runall"))
|
| ︙ | | |