Check-in [29dd546414]
Not logged in
Overview
SHA1 Hash:29dd5464142c05cbb2c19a4c341b6427644dc3d6
Date: 2012-02-29 17:56:50
User: mrwellan
Comment:minor improvements to server mode
Timelines: family | ancestors | descendants | both | trunk
Downloads: Tarball | ZIP archive
Other Links: files | file ages | manifest
Tags And Properties
Changes

Modified dashboard.scm from [3650032959812765] to [56cfd810b6a1c9e2].

74 74 75 (if (not (setup-for-run)) 75 (if (not (setup-for-run)) 76 (begin 76 (begin 77 (print "Failed to find megatest.config, exiting") 77 (print "Failed to find megatest.config, exiting") 78 (exit 1))) 78 (exit 1))) 79 79 80 (define *db* (open-db)) 80 (define *db* (open-db)) > 81 > 82 ;; HACK ALERT: this is a hack, please fix. > 83 (define *read-only* (file-read-access? (conc *toppath* "/megatest.db"))) 81 ;; (server:client-setup *db*) 84 ;; (server:client-setup *db*) 82 85 83 (define toplevel #f) 86 (define toplevel #f) 84 (define dlg #f) 87 (define dlg #f) 85 (define max-test-num 0) 88 (define max-test-num 0) 86 (define *keys* (rdb:get-keys *db*)) | 89 (define *keys* (rdb:get-keys *db*)) 87 (define *keys* (db:get-keys *db*)) | 90 ;; (define *keys* (db:get-keys *db*)) 88 (define *dbkeys* (map (lambda (x)(vector-ref x 0)) 91 (define *dbkeys* (map (lambda (x)(vector-ref x 0)) 89 (append *keys* (list (vector "runname" "blah"))))) 92 (append *keys* (list (vector "runname" "blah"))))) 90 (define *header* #f) 93 (define *header* #f) 91 (define *allruns* '()) 94 (define *allruns* '()) 92 (define *buttondat* (make-hash-table)) ;; <run-id color text test run-key> 95 (define *buttondat* (make-hash-table)) ;; <run-id color text test run-key> 93 (define *alltestnamelst* '()) 96 (define *alltestnamelst* '()) 94 (define *searchpatts* (make-hash-table)) 97 (define *searchpatts* (make-hash-table)) 95 (define *num-runs* 8) 98 (define *num-runs* 8) 96 (define *tot-run-count* (rdb:get-num-runs *db* "%")) 99 (define *tot-run-count* (rdb:get-num-runs *db* "%")) 97 (define *tot-run-count* (db:get-num-runs *db* "%")) | 100 ;; (define *tot-run-count* (db:get-num-runs *db* "%")) 98 (define *last-update* (current-seconds)) 101 (define *last-update* (current-seconds)) 99 (define *num-tests* 15) 102 (define *num-tests* 15) 100 (define *start-run-offset* 0) 103 (define *start-run-offset* 0) 101 (define *start-test-offset* 0) 104 (define *start-test-offset* 0) 102 (define *examine-test-dat* (make-hash-table)) 105 (define *examine-test-dat* (make-hash-table)) 103 (define *exit-started* #f) 106 (define *exit-started* #f) 104 (define *status-ignore-hash* (make-hash-table)) 107 (define *status-ignore-hash* (make-hash-table))

Modified db.scm from [f1afc66bda60f436] to [72acdb1ad4467de9].

1219 test-id)) 1219 test-id)) 1220 (db:get-test-data-by-id db test-id))) 1220 (db:get-test-data-by-id db test-id))) 1221 1221 1222 (define (rdb:get-keys db) 1222 (define (rdb:get-keys db) 1223 (if *runremote* 1223 (if *runremote* 1224 (let ((host (vector-ref *runremote* 0)) 1224 (let ((host (vector-ref *runremote* 0)) 1225 (port (vector-ref *runremote* 1))) 1225 (port (vector-ref *runremote* 1))) > 1226 (if *db-keys* *db-keys* 1226 ((rpc:procedure 'rdb:get-keys host port))) | 1227 (let ((keys ((rpc:procedure 'rdb:get-keys host port)))) > 1228 (set! *db-keys* keys) > 1229 keys))) 1227 (db:get-keys db))) 1230 (db:get-keys db))) 1228 1231 1229 (define (rdb:get-num-runs db runpatt) 1232 (define (rdb:get-num-runs db runpatt) 1230 (if *runremote* 1233 (if *runremote* 1231 (let ((host (vector-ref *runremote* 0)) 1234 (let ((host (vector-ref *runremote* 0)) 1232 (port (vector-ref *runremote* 1))) 1235 (port (vector-ref *runremote* 1))) 1233 ((rpc:procedure 'rdb:get-num-runs host port) runpatt)) 1236 ((rpc:procedure 'rdb:get-num-runs host port) runpatt))

Modified launch.scm from [fc84969590613384] to [e033088d6b399baf].

220 ( 220 ( 221 (debug:print 4 "Exit valu 221 (debug:print 4 "Exit valu 222 " this-step- 222 " this-step- 223 " next-statu 223 " next-statu 224 (case next-status 224 (case next-status 225 ((warn) 225 ((warn) 226 (set! rollup-status 2) 226 (set! rollup-status 2) > 227 ;; NB// test-set-statu 227 (test-set-status! db r 228 (test-set-status! db r 228 (if 229 (if 229 #f)) 230 #f)) 230 ((pass) 231 ((pass) 231 (test-set-status! db r 232 (test-set-status! db r 232 (else ;; 'fail 233 (else ;; 'fail 233 (set! rollup-status 1) 234 (set! rollup-status 1) ................................................................................................................................................................................ 282 (test-set-status! db run-id 283 (test-set-status! db run-id 283 itemdat ( 284 itemdat ( 284 (sqlite3:finalize! db) 285 (sqlite3:finalize! db) 285 (exit 1)))) 286 (exit 1)))) 286 (set! kill-tries (+ 1 kill-tries)) 287 (set! kill-tries (+ 1 kill-tries)) 287 (mutex-unlock! m))) 288 (mutex-unlock! m))) 288 (sqlite3:finalize! db) 289 (sqlite3:finalize! db) 289 (thread-sleep! (+ 8 (random 4))) ;; add s | 290 (thread-sleep! (+ 10 (random 10))) ;; add 290 (loop (calc-minutes))))))) 291 (loop (calc-minutes))))))) 291 (th1 (make-thread monitorjob)) 292 (th1 (make-thread monitorjob)) 292 (th2 (make-thread runit))) 293 (th2 (make-thread runit))) 293 (set! job-thread th2) 294 (set! job-thread th2) 294 (thread-start! th1) 295 (thread-start! th1) 295 (thread-start! th2) 296 (thread-start! th2) 296 (thread-join! th2) 297 (thread-join! th2)

Modified runs.scm from [8dbca061f3743676] to [25e1315b1dabc15b].

395 395 396 ;; Here is where the test_meta table is best updated 396 ;; Here is where the test_meta table is best updated 397 (runs:update-test_meta db test-name test-conf) 397 (runs:update-test_meta db test-name test-conf) 398 398 399 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season 399 ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season 400 (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat) 400 (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat) 401 (new-test-name (if (equal? item-path "") test-name (conc test-name "/ 401 (new-test-name (if (equal? item-path "") test-name (conc test-name "/ 402 (testdat (rdb:get-test-info db run-id test-name item-path))) | 402 (testdat (db:get-test-info db run-id test-name item-path))) 403 (if (not testdat) 403 (if (not testdat) 404 (begin 404 (begin 405 ;; ensure that the path exists before registering the test 405 ;; ensure that the path exists before registering the test 406 ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... 406 ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... 407 ;; (system (conc "mkdir -p " new-test-path)) 407 ;; (system (conc "mkdir -p " new-test-path)) 408 (rtests:register-test db run-id test-name item-path) 408 (rtests:register-test db run-id test-name item-path) 409 (set! testdat (rdb:get-test-info db run-id test-name item-path)))) | 409 (set! testdat (db:get-test-info db run-id test-name item-path)))) 410 (change-directory test-path) 410 (change-directory test-path) 411 (case (if force ;; (args:get-arg "-force") 411 (case (if force ;; (args:get-arg "-force") 412 'NOT_STARTED 412 'NOT_STARTED 413 (if testdat 413 (if testdat 414 (string->symbol (test:get-state testdat)) 414 (string->symbol (test:get-state testdat)) 415 'failed-to-insert)) 415 'failed-to-insert)) 416 ((failed-to-insert) 416 ((failed-to-insert)

Modified tests.scm from [70b97ad27cd879a4] to [536da0766162b5d1].

19 (list item-path) 19 (list item-path) 20 (list item-path "")))) 20 (list item-path "")))) 21 (for-each 21 (for-each 22 (lambda (pth) 22 (lambda (pth) 23 (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_t 23 (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_t 24 run-id 24 run-id 25 test-name 25 test-name 26 pth | 26 pth)) 27 ;; (conc "," (string-intersperse tags ",") ",") < 28 )) < 29 item-paths ))) 27 item-paths ))) 30 28 31 ;; get the previous record for when this test was run where all keys match but r 29 ;; get the previous record for when this test was run where all keys match but r 32 ;; returns #f if no such test found, returns a single test record if found 30 ;; returns #f if no such test found, returns a single test record if found 33 (define (test:get-previous-test-run-record db run-id test-name item-path) 31 (define (test:get-previous-test-run-record db run-id test-name item-path) 34 (let* ((keys (db:get-keys db)) 32 (let* ((keys (db:get-keys db)) 35 (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ", 33 (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",