Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -115,14 +115,15 @@ (set! res #t)))) (string-split patts ",")) res) #t)) +;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) (define (common:get-runconfig-targets) (sort (map car (hash-table->alist (read-config "runconfigs.config" - (make-hash-table) #f))) string ("A=%" "B=foo") -;; (keypatts (let ((pattstr (args:get-arg "-list-db-targets"))) -;; (if (equal? pattstr "-") -;; #f -;; (let ((all (string-split pattstr ","))) -;; (map (lambda (x) ;; A=% => (A "%") -;; (string-split x "=")) -;; all))))) -;; (runsdat (db:get-runs db "%" #f #f keypatts)) -;; (runs (cadr runsdat)) -;; (header (car runsdat)) -;; (seen (make-hash-table)) -;; (keysdat (db:get-keys db)) -;; (keys (map (lambda (x)(vector-ref x 0)) keysdat))) -;; -;; (for-each -;; (lambda (run) -;; (print (string-intersperse -;; (let loop ((key (car keys)) -;; (tal (cdr keys)) -;; (res '())) -;; (let ((val (db:get-value-by-header run header key))) -;; (if (null? tal) -;; (append res (list val)) -;; (loop (car tal)(cdr tal)(append res (list val)))))) -;; "/"))) -;; runs)))) - (if (args:get-arg "-list-disks") (begin (print (string-intersperse (map (lambda (x) @@ -373,10 +336,23 @@ (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") (server:client-launch))) + +;;====================================================================== +;; Weird special calls that need to run *after* the server has started? +;;====================================================================== + +(if (args:get-arg "-list-targets") + (let ((targets (common:get-runconfig-targets))) + (print "Found "(length targets) " targets") + (for-each (lambda (x) + (print "[" x "]")) + targets) + (set! *didsomething* #t))) + ;;====================================================================== ;; Remove old run(s) ;;====================================================================== @@ -427,11 +403,11 @@ (if (setup-for-run) (let* ((db #f) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") - "A long and rediculous test name that hopefully will never match")) + "%")) (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)) @@ -445,56 +421,52 @@ keynames) "/"))) (if db-targets (if (not (hash-table-ref/default seen targetstr #f)) (begin (hash-table-set! seen targetstr #t) - (print targetstr))) - (debug:print 1 - (if db-targets "" "Run: ") - targetstr - (if db-targets "" (conc " 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 '() '()))) - ;; 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)) - (exit))) + (print "[" targetstr "]")))) + (if (not db-targets) + (let* ((run-id (open-run-close db:get-value-by-header run header "id")) + (tests (open-run-close db:get-tests-for-run db run-id testpatt '() '()))) + (debug:print 1 "Run: " targetstr " 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" + (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)))) ;;====================================================================== ;; full run ;;======================================================================