| ︙ | | |
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
417
418
419
420
421
|
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
|
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(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)
(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)))))))))
|
| ︙ | | |
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
|
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
|
-
+
|
(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")
|
| ︙ | | |
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
|
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
|
-
+
|
;;======================================================================
;; 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* ((db (make-dbr:dbstruct path: *toppath* local: #t))
(runpatt (args:get-arg "-list-runs"))
(testpatt (if (args:get-arg "-testpatt")
(args:get-arg "-testpatt")
"%"))
(runsdat (db:get-runs db runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
|
| ︙ | | |
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
|
784
785
786
787
788
789
790
791
792
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
|
-
+
-
+
-
+
+
-
+
-
+
|
(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))
;; (db (make-dbr:dbstruct path: *))
(state (args:get-arg ":state"))
(status (args:get-arg ":status"))
(target (args:get-arg "-target")))
(change-directory testpath)
;; (set! *runremote* runremote)
;; (set! *transport-type* (string->symbol transport))
(if (not target)
(begin
(debug:print 0 "ERROR: -target is required.")
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -archive, exiting")
(exit 1)))
(let* ((keys (db:get-keys db))
;; DO NOT run remote
(paths (db:test-get-paths-matching db keys target)))
(paths (rmt:test-get-paths-matching keys target)))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
paths))
(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))
(let* ((db (make-dbr:dbstruct path: *toppath* local: #t))
;; DO NOT run remote
(paths (db:test-get-paths-matching db keys target)))
(for-each (lambda (path)
(print path))
paths)
(sqlite3:finalize! db))))))
;;======================================================================
;; Extract a spreadsheet from the runs database
;;======================================================================
(if (args:get-arg "-extract-ods")
(general-run-call
"-extract-ods"
"Make ods spreadsheet"
(lambda (target runname keys keyvals)
(let ((db (open-db))
(let ((db (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)
|
| ︙ | | |
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
|
1126
1127
1128
1129
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
|
-
+
+
-
+
|
;;======================================================================
;; Start a repl
;;======================================================================
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (setup-for-run))
(db (if toppath (open-db) #f)))
(db (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
(if db
(begin
(set! *db* db)
(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"))))
(exit))
(set! *didsomething* #t)))
(if (args:get-arg "-convert-to-norm")
(let* ((toppath (setup-for-run))
(db (if toppath (open-db) #f)))
(db (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)))
|
| ︙ | | |