Overview
| SHA1 Hash: | f07eeb7fa58cddf3f63f5a4d62785ae4cc6915fa |
|---|---|
| Date: | 2012-04-03 00:46:44 |
| User: | matt |
| Comment: | Adding locking of runs. -remove-runs skips runs with state of locked |
| Timelines: | family | ancestors |
| Diffs: | root of this branch |
| Downloads: | Tarball | ZIP archive |
| Other Links: | files | file ages | manifest |
Tags And Properties
- branch=lock-runs propagates to descendants
- closed cancelled by [bff9316a54] on 2012-04-03 22:48:04
- sym-lock-runs cancelled by [a222c53f4d] on 2012-04-03 22:43:10
- sym-trunk cancelled
Changes
Modified megatest.scm from [02de8ae88ca91ed1] to [ff470856491ab037].
87 and :runname ,-testpatt and -itempatt 87 and :runname ,-testpatt and -itempatt 88 and -testpatt 88 and -testpatt 89 -rerun FAIL,WARN... : re-run if called on a test that previously ran (null 89 -rerun FAIL,WARN... : re-run if called on a test that previously ran (null 90 if -keepgoing is also specified) 90 if -keepgoing is also specified) 91 -rebuild-db : bring the database schema up to date 91 -rebuild-db : bring the database schema up to date 92 -rollup : fill run (set by :runname) with latest test(s) from 92 -rollup : fill run (set by :runname) with latest test(s) from 93 prior runs with same keys 93 prior runs with same keys > 94 -lock : lock the run specified by target and runname as lock > 95 which prevents -remove-runs from removing the run 94 -update-meta : update the tests metadata for all tests 96 -update-meta : update the tests metadata for all tests 95 -env2file fname : write the environment to fname.csh and fname.sh 97 -env2file fname : write the environment to fname.csh and fname.sh 96 -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these a 98 -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these a 97 overwritten by values set in config files. 99 overwritten by values set in config files. 98 -archive : archive tests, use -target, :runname, -itempatt and 100 -archive : archive tests, use -target, :runname, -itempatt and 99 -server -|hostname : start the server (reduces contention on megatest.db) 101 -server -|hostname : start the server (reduces contention on megatest.db) 100 - to automatically figure out hostname 102 - to automatically figure out hostname ................................................................................................................................................................................ 174 "-set-values" 176 "-set-values" 175 "-load-test-data" 177 "-load-test-data" 176 "-summarize-items" 178 "-summarize-items" 177 "-gui" 179 "-gui" 178 ;; misc 180 ;; misc 179 "-archive" 181 "-archive" 180 "-repl" 182 "-repl" > 183 "-lock" 181 ;; queries 184 ;; queries 182 "-test-paths" ;; get path(s) to a test, ordered by young 185 "-test-paths" ;; get path(s) to a test, ordered by young 183 186 184 "-runall" ;; run all tests 187 "-runall" ;; run all tests 185 "-remove-runs" 188 "-remove-runs" 186 "-keepgoing" 189 "-keepgoing" 187 "-usequeue" 190 "-usequeue"
Modified runs.scm from [dcd447f66fd240dd] to [f5e1ed9051f1eee8].
502 (runs (vector-ref rundat 1))) 502 (runs (vector-ref rundat 1))) 503 (debug:print 1 "Header: " header) 503 (debug:print 1 "Header: " header) 504 (for-each 504 (for-each 505 (lambda (run) 505 (lambda (run) 506 (let ((runkey (string-intersperse (map (lambda (k) 506 (let ((runkey (string-intersperse (map (lambda (k) 507 (db:get-value-by-header run head 507 (db:get-value-by-header run head 508 (dirs-to-remove (make-hash-table))) 508 (dirs-to-remove (make-hash-table))) 509 (let* ((run-id (db:get-value-by-header run header "id") ) | 509 (let* ((run-id (db:get-value-by-header run header "id")) > 510 (run-state (db:get-value-by-header run header "state")) > 511 (tests (if (not (equal? run-state "locked")) 510 (tests (rdb:get-tests-for-run db (db:get-value-by-header run he | 512 (rdb:get-tests-for-run db (db:get-value-by-header > 513 '())) 511 (lasttpath "/does/not/exist/I/hope")) 514 (lasttpath "/does/not/exist/I/hope")) 512 < 513 (if (not (null? tests)) < > 515 (if (not (equal? run-state "locked")) 514 (begin 516 (begin > 517 (if (not (null? tests)) > 518 (begin 515 (debug:print 1 "Removing tests for run: " runkey " " (db:get-va | 519 (debug:print 1 "Removing tests for run: " runkey " " (db: 516 (for-each | 520 (for-each 517 (lambda (test) | 521 (lambda (test) 518 (let* ((item-path (db:test-get-item-path test)) | 522 (let* ((item-path (db:test-get-item-path test)) 519 (test-name (db:test-get-testname test)) | 523 (test-name (db:test-get-testname test)) 520 (run-dir (db:test-get-rundir test))) | 524 (run-dir (db:test-get-rundir test))) 521 (debug:print 1 " " (db:test-get-testname test) " id: " (d | 525 (debug:print 1 " " (db:test-get-testname test) " id 522 (rdb:delete-test-records db (db:test-get-id test)) | 526 (rdb:delete-test-records db (db:test-get-id test)) 523 (if (> (string-length run-dir) 5) ;; bad heuristic but sho | 527 (if (> (string-length run-dir) 5) ;; bad heuristic b 524 (let ((fullpath run-dir)) ;; "/" (db:test-get-item-pat | 528 (let ((fullpath run-dir)) ;; "/" (db:test-get-it 525 (set! lasttpath fullpath) | 529 (set! lasttpath fullpath) 526 (hash-table-set! dirs-to-remove fullpath #t) | 530 (hash-table-set! dirs-to-remove fullpath #t) 527 ;; The following was the safe delete code but it was | 531 ;; The following was the safe delete code but 528 ;; (let* ((dirs-count (+ 1 (length keys)(length (str | 532 ;; (let* ((dirs-count (+ 1 (length keys)(lengt 529 ;; (dir-to-rem (get-dir-up-n fullpath dirs-co | 533 ;; (dir-to-rem (get-dir-up-n fullpath d 530 ;; (remainingd (string-substitute (regexp (co | 534 ;; (remainingd (string-substitute (rege 531 ;; (cmd (conc "cd " dir-to-rem "; rmdir -p " | 535 ;; (cmd (conc "cd " dir-to-rem "; rmdir 532 ;; (if (file-exists? fullpath) | 536 ;; (if (file-exists? fullpath) 533 ;; (begin | 537 ;; (begin 534 ;; (debug:print 1 cmd) | 538 ;; (debug:print 1 cmd) 535 ;; (system cmd))) | 539 ;; (system cmd))) 536 ;; )) | 540 ;; )) 537 )))) | 541 )))) 538 tests))) | 542 tests))) 539 543 540 ;; look though the dirs-to-remove for candidates for removal. Do this | 544 ;; look though the dirs-to-remove for candidates for removal. D 541 ;; for each test in case we get killed. That should minimize the detr | 545 ;; for each test in case we get killed. That should minimize th 542 ;; process the dirs from longest string length to shortest | 546 ;; process the dirs from longest string length to shortest 543 (for-each | 547 (for-each 544 (lambda (dir-to-remove) | 548 (lambda (dir-to-remove) 545 (if (file-exists? dir-to-remove) | 549 (if (file-exists? dir-to-remove) 546 (let ((dir-in-db '())) | 550 (let ((dir-in-db '())) 547 (sqlite3:for-each-row | 551 (sqlite3:for-each-row 548 (lambda (dir) | 552 (lambda (dir) 549 (set! dir-in-db (cons dir dir-in-db))) | 553 (set! dir-in-db (cons dir dir-in-db))) 550 db "SELECT rundir FROM tests WHERE rundir LIKE ?;" | 554 db "SELECT rundir FROM tests WHERE rundir LIKE ?;" 551 (conc "%" dir-to-remove "%")) ;; yes, I'm going to bail if | 555 (conc "%" dir-to-remove "%")) ;; yes, I'm going to ba 552 (if (null? dir-in-db) | 556 (if (null? dir-in-db) 553 (begin | 557 (begin 554 (debug:print 2 "Removing directory with zero db refere | 558 (debug:print 2 "Removing directory with zero db 555 (system (conc "rm -rf " dir-to-remove)) | 559 (system (conc "rm -rf " dir-to-remove)) 556 (hash-table-delete! dirs-to-remove dir-to-remove)) | 560 (hash-table-delete! dirs-to-remove dir-to-remove 557 (debug:print 2 "Skipping removal of " dir-to-remove " fo | 561 (debug:print 2 "Skipping removal of " dir-to-remov 558 (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string-lengt | 562 (sort (hash-table-keys dirs-to-remove) (lambda (a b)(> (string 559 563 560 ;; remove the run if zero tests remain | 564 ;; remove the run if zero tests remain 561 (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-header run | 565 (let ((remtests (rdb:get-tests-for-run db (db:get-value-by-head 562 (if (null? remtests) ;; no more tests remaining | 566 (if (null? remtests) ;; no more tests remaining 563 (let* ((dparts (string-split lasttpath "/")) | 567 (let* ((dparts (string-split lasttpath "/")) 564 (runpath (conc "/" (string-intersperse | 568 (runpath (conc "/" (string-intersperse 565 (take dparts (- (length dparts) 1)) | 569 (take dparts (- (length dparts 566 "/")))) | 570 "/")))) 567 (debug:print 1 "Removing run: " runkey " " (db:get-value-by-h | 571 (debug:print 1 "Removing run: " runkey " " (db:get-valu 568 (db:delete-run db run-id) | 572 (db:delete-run db run-id) 569 ;; need to figure out the path to the run dir and remove it i | 573 ;; need to figure out the path to the run dir and remov 570 ;; (if (null? (glob (conc runpath "/*"))) | 574 ;; (if (null? (glob (conc runpath "/*"))) 571 ;; (begin | 575 ;; (begin 572 ;; (debug:print 1 "Removing run dir " runpath) | 576 ;; (debug:print 1 "Removing run dir " runpath) 573 ;; (system (conc "rmdir -p " runpath)))) | 577 ;; (system (conc "rmdir -p " runpath)))) 574 )))) | 578 )))) 575 )) | 579 )))) 576 runs))) 580 runs))) 577 581 578 ;;====================================================================== 582 ;;====================================================================== 579 ;; Routines for manipulating runs 583 ;; Routines for manipulating runs 580 ;;====================================================================== 584 ;;====================================================================== 581 585 582 ;; Since many calls to a run require pretty much the same setup 586 ;; Since many calls to a run require pretty much the same setup