| ︙ | | | ︙ | |
269
270
271
272
273
274
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
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
|
(operate-on 'set-state-status))))
;;======================================================================
;; Query runs
;;======================================================================
(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))
(sqlite3:finalize! db)
(set! db #f)
;; 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 (open-run-close db:get-value-by-header run header "id")))
(let ((tests (open-run-close 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) "")
""
(conc "(" (db:test-get-item-path test) ")")))
(db:test-get-state test)
(db:test-get-status test)
(db:test-get-run_duration test)
(db:test-get-event_time test)
(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)
)
;; Each test
(let ((steps (open-run-close db:get-steps-for-test db (db:test-get-id test))))
(for-each
(lambda (step)
(format #t
" Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
(db:step-get-stepname step)
(db:step-get-state step)
(db:step-get-status step)
(db:step-get-event_time step)))
steps)))))
tests))))
runs)
(set! *didsomething* #t)
))
|
<
|
|
|
|
|
|
|
|
|
|
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
269
270
271
272
273
274
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
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
|
(operate-on 'set-state-status))))
;;======================================================================
;; Query runs
;;======================================================================
(if (args:get-arg "-list-runs")
(if (setup-for-run)
(let* ((db #f)
(runpatt (args:get-arg "-list-runs"))
(testpatt (args:get-arg "-testpatt"))
(itempatt (args:get-arg "-itempatt"))
(runsdat (open-run-close db:get-runs db runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(keys (open-run-close db:get-keys db))
(keynames (map key:get-fieldname keys)))
;; 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 (open-run-close db:get-value-by-header run header "id")))
(let ((tests (open-run-close 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) "")
""
(conc "(" (db:test-get-item-path test) ")")))
(db:test-get-state test)
(db:test-get-status test)
(db:test-get-run_duration test)
(db:test-get-event_time test)
(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)
)
;; Each test
(let ((steps (open-run-close db:get-steps-for-test db (db:test-get-id test))))
(for-each
(lambda (step)
(format #t
" Step: ~20a State: ~10a Status: ~10a Time ~22a\n"
(db:step-get-stepname step)
(db:step-get-state step)
(db:step-get-status step)
(db:step-get-event_time step)))
steps)))))
tests))))
runs)
(set! *didsomething* #t)
)))
;;======================================================================
;; 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"))))
|
| ︙ | | | ︙ | |
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
|
(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 -test-paths or -test-files, exiting")
(exit 1)))
(set! db (open-db))
(if (not (args:get-arg "-server"))
(server:client-setup db)
(begin
(sqlite3:finalize! db)
(set! db #f)))
|
<
<
<
<
<
<
|
470
471
472
473
474
475
476
477
478
479
480
481
482
483
|
(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 -test-paths or -test-files, exiting")
(exit 1)))
(let* ((itempatt (args:get-arg "-itempatt"))
(keys (open-run-close db:get-keys db))
(keynames (map key:get-fieldname keys))
(paths (open-run-close db:test-get-paths-matching db keynames target (args:get-arg "-test-files"))))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
|
| ︙ | | | ︙ | |
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
|
(status (args:get-arg ":status"))
(logfile (args:get-arg "-setlog")))
(change-directory testpath)
(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)
(begin
(sqlite3:finalize! db)
(set! db #f)))
|
<
<
<
<
<
<
|
595
596
597
598
599
600
601
602
603
604
605
606
607
608
|
(status (args:get-arg ":status"))
(logfile (args:get-arg "-setlog")))
(change-directory testpath)
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(if (and state status)
(open-run-close 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)))
(if db (sqlite3:finalize! db))
(set! *didsomething* #t))))
|
| ︙ | | | ︙ | |
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
|
(state (args:get-arg ":state"))
(status (args:get-arg ":status")))
(change-directory testpath)
(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)
(begin
(sqlite3:finalize! db)
(set! db #f)))
|
|
|
|
|
<
<
|
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
|
(state (args:get-arg ":state"))
(status (args:get-arg ":status")))
(change-directory testpath)
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; can setup as client for server mode now
(server:client-setup)
(if (args:get-arg "-load-test-data")
;; has sub commands that are rdb:
(open-run-close db:load-test-data db test-id))
(if (args:get-arg "-setlog")
(let ((logfname (args:get-arg "-setlog")))
(open-run-close db:test-set-log! db test-id logfname)))
(if (args:get-arg "-set-toplog")
|
| ︙ | | | ︙ | |
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
|
(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)))
(let ((msg (args:get-arg "-m")))
;; Convert to rpc
(rdb:open-run-close 'tests:test-set-status! #f test-id state newstatus msg otherdata))))
(if db (sqlite3:finalize! db))
(set! *didsomething* #t))))
;;======================================================================
;; Various helper commands can go below here
;;======================================================================
(if (args:get-arg "-showkeys")
(let ((db #f)
(keys #f))
(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)
(begin
(sqlite3:finalize! db)
(set! db #f)))
|
|
>
<
<
<
<
<
<
|
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
|
(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)))
(let ((msg (args:get-arg "-m")))
;; Convert to rpc
;; (rdb:open-run-close 'tests:test-set-status! #f test-id state newstatus msg otherdata))))
(tests:test-set-status! db test-id state newstatus msg otherdata))))
(if db (sqlite3:finalize! db))
(set! *didsomething* #t))))
;;======================================================================
;; Various helper commands can go below here
;;======================================================================
(if (args:get-arg "-showkeys")
(let ((db #f)
(keys #f))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! keys (open-run-close db:get-keys db))
(debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", "))
(if db (sqlite3:finalize! db))
(set! *didsomething* #t)))
(if (args:get-arg "-gui")
(begin
|
| ︙ | | | ︙ | |
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
|
(if (args:get-arg "-update-meta")
(begin
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; now can find our db
(set! db (open-db))
(if (not (args:get-arg "-server"))
(server:client-setup db)
(begin
(sqlite3:finalize! db)
(set! db #f)))
(if db (sqlite3:finalize! db))
|
<
<
<
<
<
<
<
|
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
|
(if (args:get-arg "-update-meta")
(begin
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; now can find our db
(open-run-close runs:update-all-test_meta db)
(set! *didsomething* #t)))
;;======================================================================
;; Start a repl
;;======================================================================
(if (args:get-arg "-repl")
|
| ︙ | | | ︙ | |