Overview
Comment: | Merged v1.65 to trunk |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
22fac8b130cd3a3fcca1003f3a0cf166 |
User & Date: | mrwellan on 2019-04-01 08:33:06 |
Other Links: | manifest | tags |
Context
2019-06-06
| ||
14:06 | Merging v1.65 back to trunk check-in: 39a024c31f user: matt tags: trunk | |
2019-04-01
| ||
08:33 | Merged v1.65 to trunk check-in: 22fac8b130 user: mrwellan tags: trunk | |
08:32 | Merged trim sleeps check-in: db1d22eadb user: mrwellan tags: v1.65 | |
2019-03-12
| ||
21:30 | Merged v1.65 to trunk check-in: 367ba5c918 user: matt tags: trunk | |
Changes
Modified api.scm from [cf3fabb928] to [1958ec5960].
︙ | |||
47 48 49 50 51 52 53 54 55 56 57 58 59 60 | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | + | get-testinfo-state-status test-get-top-process-pid test-get-paths-matching-keynames-target-new get-prereqs-not-met get-count-tests-running-for-run-id get-run-info get-run-status get-run-state get-run-stats get-run-times get-targets get-target ;; register-run get-tests-tags get-test-times |
︙ | |||
78 79 80 81 82 83 84 | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | - + + - + | login tasks-get-last testmeta-get-record have-incompletes? synchash-get get-changed-record-ids get-run-record-ids |
︙ | |||
196 197 198 199 200 201 202 203 204 205 206 207 208 209 | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 | + | )) ((delete-test-records) (apply db:delete-test-records dbstruct params)) ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) ((test-set-state-status) (apply db:test-set-state-status dbstruct params)) ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) ((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params)) ((set-state-status-and-roll-up-run) (apply db:set-state-status-and-roll-up-run dbstruct params)) ((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params)) ((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params)) ;; RUNS ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((delete-run) (apply db:delete-run dbstruct params)) |
︙ | |||
274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 | 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 | + + + | ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ((get-not-completed-cnt) (apply db:get-not-completed-cnt dbstruct params)) ((synchash-get) (apply synchash:server-get dbstruct params)) ((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params)) ((get-test-times) (apply db:get-test-times dbstruct params)) ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) ((get-run-status) (apply db:get-run-status dbstruct params)) ((get-run-state) (apply db:get-run-state dbstruct params)) ((set-run-status) (apply db:set-run-status dbstruct params)) ((set-run-state-status) (apply db:set-run-state-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) ((simple-get-runs) (apply db:simple-get-runs dbstruct params)) ((get-num-runs) (apply db:get-num-runs dbstruct params)) |
︙ |
Modified common.scm from [c41ac723cd] to [b1d85b703a].
︙ | |||
316 317 318 319 320 321 322 | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 | - + + + + + + + | (define (common:version-changed?) (not (equal? (common:get-last-run-version) (common:version-signature)))) (define (common:api-changed?) (not (equal? (substring (->string megatest-version) 0 4) (substring (conc (common:get-last-run-version)) 0 4)))) |
︙ | |||
597 598 599 600 601 602 603 | 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 | - - - + + + - + + + | (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) ;; dot-locking egg seems not to work, using this for now ;; if lock is older than expire-time then remove it and try again ;; to get the lock ;; (define (common:simple-file-lock fname #!key (expire-time 300)) |
︙ | |||
935 936 937 938 939 940 941 | 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 | - + | ) ) 0) (define (std-signal-handler signum) ;; (signal-mask! signum) |
︙ |
Modified dashboard.scm from [067e696739] to [2679042d5f].
︙ | |||
155 156 157 158 159 160 161 162 163 164 165 166 167 168 | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | + | (debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost)))) ;; RA => Might require revert for filters ;; create a watch dog to move changes from lt/.db/*.db to megatest.db ;; ;;;(if (file-write-access? (conc *toppath* "/megatest.db")) ;;(debug:print-info 13 *default-log-port* "Before common:watchdog spawn") (thread-start! (make-thread common:watchdog "Watchdog thread")) ;;(debug:print-info 13 *default-log-port* "After common:watchdog spawn") ;; (if (not (args:get-arg "-use-db-cache")) ;; (begin ;; (debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db") ;; (hash-table-set! args:arg-hash "-use-db-cache" #t)));;;) ;;) |
︙ | |||
2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 | 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 | + + | result)) (tabs (apply iup:tabs #:tabchangepos-cb (lambda (obj curr prev) (debug:catch-and-dump (lambda () (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (dboard:tabdat-layout-update-ok-set! tabdat #f)) (dboard:commondat-curr-tab-num-set! commondat curr) (let* ((tab-num (dboard:commondat-curr-tab-num commondat)) (tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))) (dboard:commondat-please-update-set! commondat #t) (dboard:tabdat-layout-update-ok-set! tabdat #t))) "tabchangepos")) (dashboard:summary commondat stats-dat tab-num: 0) runs-view (dashboard:runs-summary commondat onerun-dat tab-num: 2) ;; (dashboard:new-view db data new-view-dat tab-num: 3) |
︙ |
Modified db.scm from [f74527238e] to [a146d876b8].
︙ | |||
311 312 313 314 315 316 317 | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 | + - + | ;; This routine creates the db if not already present. It is only called if the db is not already opened ;; (define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (if (stack? tmpdb-stack) (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used (let* ((max-stale-tmp (configf:lookup-number *configdat* "server" "filling-db-max-stale-seconds" default: 10)) |
︙ | |||
349 350 351 352 353 354 355 | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 | - + | (dbr:dbstruct-tmpdb-set! dbstruct tmpdb) (dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ? (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path) (dbr:dbstruct-refndb-set! dbstruct refndb) ;; (mutex-unlock! *rundb-mutex*) (if (and (or (not dbfexists) (and modtimedelta |
︙ | |||
1046 1047 1048 1049 1050 1051 1052 | 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 | - + + + + + | ;; kill servers ((killservers) (for-each (lambda (server) (match-let (((mod-time host port start-time pid) server)) (if (and host pid) (tasks:kill-server host pid)))) |
︙ | |||
2626 2627 2628 2629 2630 2631 2632 | 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 | - + + + + + + + + + + + + + + + + + + + + + + + | user (conc newlockval " " run-id)) (debug:print-info 1 *default-log-port* "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) (db:with-db dbstruct #f #f (lambda (db) |
︙ | |||
3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 | 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 | + + + + + + + + + + + + | run-id #f (lambda (db) (sqlite3:first-result db "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '') AND testname=?;" run-id testname)))) (define (db:get-not-completed-cnt dbstruct run-id) (db:with-db dbstruct run-id #f (lambda (db) ;(print "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=" run-id) (sqlite3:first-result db "SELECT count(id) FROM tests WHERE state not in ('COMPLETED', 'DELETED') AND run_id=?;" run-id)))) (define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup) (if (not jobgroup) 0 ;; (let ((testnames '())) ;; get the testnames (db:with-db dbstruct #f #f |
︙ | |||
3692 3693 3694 3695 3696 3697 3698 | 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 | - | ;; status is the priority rollup of all completed statesfu ;; ;; if test-name is an integer work off that instead of test-name test-path ;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment) ;; establish info on incoming test followed by info on top level test ;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met |
︙ | |||
3719 3720 3721 3722 3723 3724 3725 | 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 | + + + + + + + + + + + + + + + + + + + - - - - - - + + + + + + - - + - - - - - - - - - - - - - - + + + + + + + + + + + - - - - - - - - - - + + + + + + + + + + - - - - + + + - - - - - - - + + - - - - - + + + + - - + - - + - - - - - - - - - - + + + + + + + + + + + + + + - - - - - + + + + - - - - - + + + + + + + + + + + + + + + + | (sqlite3:with-transaction db (lambda () ;; NB// Pass the db so it is part fo the transaction (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path state status)) ;; item-path is used to exclude current state/status of THIS test (state-stauses (db:roll-up-rules state-status-counts state status)) (newstate (car state-stauses)) (newstatus (cadr state-stauses))) (debug:print 4 *default-log-port* "BB> tl-test-id="tl-test-id" ; "test-name":"item-path" newstate="newstate" newstatus="newstatus" len(sscs)="(length state-status-counts) " state-status-counts: " (apply conc (map (lambda (x) (conc (with-output-to-string (lambda () (pp (dbr:counts->alist x)))) " | ")) state-status-counts))); end debug:print (if tl-test-id (db:test-set-state-status db run-id tl-test-id newstate newstatus #f)) ;; we are still in the transaction - must access the db and not the dbstruct )))))) (mutex-unlock! *db-transaction-mutex*) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) tr-res))))) (define (db:roll-up-rules state-status-counts state status) |
︙ | |||
3889 3890 3891 3892 3893 3894 3895 | 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 | - + | (list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") ;; TESTS '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") ;; Test state and status '(set-test-state "UPDATE tests SET state=? WHERE id=?;") '(set-test-status "UPDATE tests SET state=? WHERE id=?;") |
︙ |
Modified launch.scm from [9f824ebdab] to [bd83b25556].
︙ | |||
468 469 470 471 472 473 474 | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 | - + + | ;; BB: question to Matt -- does the tests:test-state-status! encompass rollup to toplevel? If not, should it? (tests:test-set-status! run-id test-id "KILLED" "KILLED" (conc (args:get-arg "-m")" "kill-reason) #f)) ;; BB ADDED kill-reason -- confirm OK with Matt (begin (debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2) (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (conc (args:get-arg "-m")" "kill-reason) #f) ;; BB ADDED kill-reason -- confirm OK with Matt ))) (mutex-unlock! m) |
︙ | |||
805 806 807 808 809 810 811 | 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 | - - + | (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status |
︙ | |||
837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 | 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 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | )) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items run-id test-id test-name #f)) (tests:summarize-test run-id test-id) ;; don't force - just update if no (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) (mutex-unlock! m) (launch:end-of-run-check run-id ) (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n") (if (not (launch:einf-exit-status exit-info)) (exit 4)))) ))) ;; Spec for End of test ;; At end of each test call, after marking self as COMPLETED do run-state-status-rollup ;; At transition to run COMPLETED/X do hooks ;; Definition: test_dead if event_time + duration + 1 minute? < current_time AND ;; we can prove the process is not alive (ssh host pstree -A pid) ;; if dead safe to mark the test as killed in the db ;; State/status table ;; new ;; 100% COMPLETED/ (PASS,FAIL,ABORT etc.) ==> COMPLETED / X where X is same as itemized rollup ;; > 3 RUNNING with not test_dead do nothing (run should already be RUNNING/ na ;; > 0 RUNNING and test_dead then send KILLREQ ==> COMPLETED ;; 0 RUNNING ==> this is actually the first condition, should not get here (define (launch:end-of-run-check run-id ) (let* ((not-completed-cnt (rmt:get-not-completed-cnt run-id)) (running-cnt (rmt:get-count-tests-running-for-run-id run-id)) (all-test-launched (rmt:get-var (conc "lunch-complete-" run-id))) (current-state (rmt:get-run-state run-id)) (current-status (rmt:get-run-status run-id))) ;;get-vars run-id to query metadata table to check if all completed. if all-test-launched = yes then only not-completed-cnt = 0 means everyting is completed if no entry found in the table do nothing (debug:print 0 *default-log-port* "rollup run state/status") (rmt:set-state-status-and-roll-up-run run-id current-state current-status) (cond ((and all-test-launched (eq? not-completed-cnt 0) (equal? all-test-launched "yes" )) (debug:print 0 *default-log-port* "look for post hook.") (runs:run-post-hook run-id)) ((> running-cnt 3) (debug:print 0 *default-log-port* "There are " running-cnt " tests running." )) ((> running-cnt 0) (debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" ) (let ((kill-cnt (launch:kill-tests-if-dead run-id))) (if (and all-test-launched (equal? all-test-launched "yes") (eq? kill-cnt running-cnt)) (launch:end-of-run-check run-id)))) ;;todo (else (debug:print 0 *default-log-port* "Should it get here?? May be everything is not launched yet. Running test cnt:" running-cnt " Not completed test cnt:" not-completed-cnt) (let* ((not-completed-tests (rmt:get-tests-for-run run-id "%" `("NOT_STARTED" "RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f))) (if (> (length not-completed-tests) 0) (let loop ((running-test (car not-completed-tests)) (tal (cdr not-completed-tests))) (let* ((test-name (vector-ref running-test 2)) (item-path (vector-ref running-test 11))) (debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed") (if (not (null? tal)) (loop (car tal) (cdr tal))))))))))) (define (launch:is-test-alive host pid) (if (and host pid (not (equal? host "n/a"))) (let* ((cmd (conc "ssh " host " pstree -A " pid)) (output (with-input-from-pipe cmd read-lines))) (print "cmd: " cmd "\n op: " output ) (if(eq? (length output) 0) #f #t)) #t)) (define (launch:kill-tests-if-dead run-id) (let* ((running-tests (rmt:get-tests-for-run run-id "%" `("RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f))) (let loop ((running-test (car running-tests)) (tal (cdr running-tests)) (kill-cnt 0)) (let* ((test-name (vector-ref running-test 2)) (item-path (vector-ref running-test 11)) (test-id (vector-ref running-test 0)) (host (vector-ref running-test 6)) (pid (rmt:test-get-top-process-pid run-id test-id)) (event-time (vector-ref running-test 5)) (duration (vector-ref running-test 12)) (flag 0) (curr-time (current-seconds))) (if (and (< (+ event-time duration 600) curr-time) (not (launch:is-test-alive host pid))) ;;test has not updated duration in last 10 min then likely its not running but confirm before marking it as killed (begin (debug:print 0 *default-log-port* "test " test-name "/" item-path " needs to be killed") (set! flag 1) (rmt:set-state-status-and-roll-up-items run-id test-name item-path "KILLREQ" "n/a" #f))) (if (not (null? tal)) (loop (car tal) (cdr tal) (+ kill-cnt flag)) (+ kill-cnt flag)))))) ;; DO NOT USE - caching of configs is handled in launch:setup now. ;; (define (launch:cache-config) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg (if (and *configdat* (or (args:get-arg "-run") |
︙ |
Modified megatest-version.scm from [cc55965633] to [51f935afac].
︙ | |||
16 17 18 19 20 21 22 | 16 17 18 19 20 21 22 23 | - + | ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) |
Modified megatest.scm from [bd9e9c775d] to [8964e71ae0].
︙ | |||
107 108 109 110 111 112 113 | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | - - - + + + + - + | -manual : show the Megatest user manual -version : print megatest version (currently " megatest-version ") Launching and managing runs -run : run all tests or as specified by -testpatt -remove-runs : remove the data for a run, requires -runname and -testpatt Optionally use :state and :status, use -keep-records to remove only |
︙ | |||
355 356 357 358 359 360 361 362 363 364 365 366 367 368 | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 | + | "-prefix-target" "-src-target" "-src-runname" "-diff-email" "-sync-to" "-pgsync" "-kill-wait" ;; wait this long before removing test (default is 10 sec) "-diff-html" ) (list "-h" "-help" "--help" "-manual" "-version" "-force" "-xterm" |
︙ | |||
378 379 380 381 382 383 384 385 386 387 388 389 390 391 | 380 381 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 | + - + - - + + + | "-rerun-clean" "-rerun-all" "-clean-cache" "-no-cache" "-cache-db" "-use-db-cache" "-prepend-contour" ;; misc "-repl" "-lock" "-unlock" "-list-servers" "-kill-servers" "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) |
︙ | |||
420 421 422 423 424 425 426 427 428 429 430 431 432 433 | 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 | + | "-create-megatest-area" "-mark-incompletes" "-convert-to-norm" "-convert-to-old" "-import-megatest.db" "-sync-to-megatest.db" "-sync-brute-force" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only "-diff-rep" ) args:arg-hash |
︙ | |||
1238 1239 1240 1241 1242 1243 1244 | 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 | - + | (db:get-value-by-header run header x)) keys) "/")) (statuses (string-split (or (args:get-arg "-status") "") ",")) (run-id (db:get-value-by-header run header "id")) (runname (db:get-value-by-header run header "runname")) (states (string-split (or (args:get-arg "-state") "") ",")) (tests (if tests-spec |
︙ | |||
1374 1375 1376 1377 1378 1379 1380 | 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 | - + | (hash-table-set! data "targets" (cons targetstr (hash-table-ref/default data "targets" '()))) ))) (let* ((run-id (db:get-value-by-header run header "id")) (runname (db:get-value-by-header run header "runname")) (states (string-split (or (args:get-arg "-state") "") ",")) (statuses (string-split (or (args:get-arg "-status") "") ",")) (tests (if tests-spec |
︙ | |||
1499 1500 1501 1502 1503 1504 1505 | 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 | - + | (conc "\n rundir: " (get-value-by-fieldname test test-field-index "rundir")) ;; (db:test-get-rundir test) "") ;; "\n rundir: " (get-value-by-fieldname test test-field-index "") ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* ;; (db:test-get-rundir test) ;; ) ) ;; Each test ;; DO NOT remote run |
︙ | |||
2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 | 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 | + + + + | 'killservers 'dejunk 'adj-testids 'old2new ;; 'new2old ) (set! *didsomething* #t))) (when (args:get-arg "-sync-brute-force") ((server:get-bruteforce-syncer (db:setup #t) persist-until-sync: #t)) (set! *didsomething* #t)) (if (args:get-arg "-sync-to-megatest.db") (let* ((dbstruct (db:setup #f)) (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct))) (lockfile (conc tmpdbpth ".lock")) (locked (common:simple-file-lock lockfile)) (res (if locked |
︙ |
Modified mtut.scm from [de386c14ee] to [652f16f336].
︙ | |||
215 216 217 218 219 220 221 222 223 224 225 226 227 228 | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 | + + | ("-sync-to" . k) ("-new" . l) ;; l (see below) is new-ss ("-run-name" . n) ("-mode-patt" . o) ("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt" ("-status" . s) ("-target" . t) ("-reqtarg" . R) ("-tag-expr" . x) ;; misc ("-debug" . #f) ;; for *verbosity* > 2 ("-load" . #f) ;; load and exectute a scheme file ("-log" . #f) ("-override-user" . #f) ("-msg" . M) |
︙ | |||
239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 | + + + | ("-manual" . #f) ("-version" . #f) ;; misc ("-repl" . #f) ("-immediate" . I) ("-preclean" . r) ("-prepend-contour" . w) ("-force" . F) ("-list-pkt-keys" . #f) )) ;; alist to map actions to old megatest commands (define *action-keys* '((run . "-run") (rerun-clean . "-rerun-clean") (rerun-all . "-rerun-all") (kill-run . "-kill-runs") (kill-rerun . "-kill-rerun") (lock . "-lock") (unlock . "-unlock") (sync . "") (archive . "-archive") (set-ss . "-set-state-status") (remove . "-remove-runs"))) ;; manually keep this list updated from the keys to ;; the case *action* near the end of this file. |
︙ | |||
821 822 823 824 825 826 827 | 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 | - + + | ;; (use trace)(trace create-run-pkt) (define (contains list x) (cond ((null? list) #f) ((eq? (car list) x) #t) (else (contains (cdr list) x)))) ;; collect all needed data and create run pkts for contours with changed inputs ;; (define (generate-run-pkts mtconf toppath) |
︙ | |||
1002 1003 1004 1005 1006 1007 1008 1009 1010 | 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 | + + + + + + + + + + + - + + - + | ;; the script is called like this: scriptname contour runkey std-runname action extra_param1 extra_param2 ... (for-each (lambda (cmd) ;;(print "cmd: " cmd) ;;(print "Areas: " all-areas) (for-each (lambda (area) ;;(print "Area: " area) ;;(print "Target: " runkey) ;;(print "OR: " (or (string->number (if (configf:lookup mtconf "setup" "max_packets_per_run") (configf:lookup mtconf "setup" "max_packets_per_run") "10000" )))) ;;(print "Packets generated: " packets-generated) ;;(print "Comparison: " (< packets-generated 4)) ;;(print "Full Comparison: " ;; (and (< packets-generated (or (string->number (if (configf:lookup mtconf "setup" "max_packets_per_run") (configf:lookup mtconf "setup" "max_packets_per_run") "10000" )) 10000)) ;; (if (args:get-arg "-target") ;; (if (string= (args:get-arg "-target") runkey) (area-allowed? area "area-needs-to-be-run" runkey contour #f) #f) ;; (area-allowed? area "area-needs-to-be-run" runkey contour #f)))) ;;(print "Area Allowed: " (area-allowed? area "area-needs-to-be-run" runkey contour #f)) ;Add code to check whether area is valid (if |
︙ | |||
1089 1090 1091 1092 1093 1094 1095 | 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 | + - + - + + + - + | ;;(target . ,(list new-target)) ;; overriding with result from runing the script )) (aval (or (configf:lookup mtconf "areas" area) "")) (aval-alist (common:val->alist aval)) (targets (map-targets mtconf aval-alist runkey area contour))) (pp targets) (for-each (lambda (target) |
︙ | |||
1445 1446 1447 1448 1449 1450 1451 | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 | - + + | ; (hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log (print *default-log-port* "Sending log output to " logf) (set! *default-log-port* oup) ))) (if *action* (case (string->symbol *action*) |
︙ |
Modified rmt.scm from [bc89e0120c] to [4dc97a8297].
︙ | |||
674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 | + + + + + + + + | ;; (rmt:send-receive #f 'get-run-ids-matching (list keynames target res))) (define (rmt:get-prereqs-not-met run-id waitons ref-test-name ref-item-path #!key (mode '(normal))(itemmaps #f)) (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-test-name ref-item-path mode itemmaps))) (define (rmt:get-count-tests-running-for-run-id run-id) (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) (define (rmt:get-not-completed-cnt run-id) (rmt:send-receive 'get-not-completed-cnt run-id (list run-id))) ;; Statistical queries (define (rmt:get-count-tests-running run-id) (rmt:send-receive 'get-count-tests-running run-id (list run-id))) (define (rmt:get-count-tests-running-for-testname run-id testname) (rmt:send-receive 'get-count-tests-running-for-testname run-id (list run-id testname))) (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) ;; state and status are extra hints not usually used in the calculation ;; (define (rmt:set-state-status-and-roll-up-items run-id test-name item-path state status comment) (rmt:send-receive 'set-state-status-and-roll-up-items run-id (list run-id test-name item-path state status comment))) (define (rmt:set-state-status-and-roll-up-run run-id state status) (rmt:send-receive 'set-state-status-and-roll-up-run run-id (list run-id state status))) (define (rmt:update-pass-fail-counts run-id test-name) (rmt:general-call 'update-pass-fail-counts run-id test-name test-name test-name)) (define (rmt:top-test-set-per-pf-counts run-id test-name) (rmt:send-receive 'top-test-set-per-pf-counts run-id (list run-id test-name))) |
︙ | |||
750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 | 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 | + + + + + + + + | (define (rmt:lock/unlock-run run-id lock unlock user) (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) ;; set/get status (define (rmt:get-run-status run-id) (rmt:send-receive 'get-run-status #f (list run-id))) (define (rmt:get-run-state run-id) (rmt:send-receive 'get-run-state #f (list run-id))) (define (rmt:set-run-status run-id run-status #!key (msg #f)) (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:set-run-state-status run-id state status ) (rmt:send-receive 'set-run-state-status #f (list run-id state status))) (define (rmt:update-run-event_time run-id) (rmt:send-receive 'update-run-event_time #f (list run-id))) (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-runs-update #!key (sort-order "asc")) ;; fields of #f uses default (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order))) |
︙ |
Modified runs.scm from [e77bf1baa0] to [c9b27c71eb].
︙ | |||
518 519 520 521 522 523 524 | 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 | - + + + | ;; Ensure all tests are registered in the test_meta table (runs:update-all-test_meta #f) ;; run the run prehook if there are no tests yet run for this run: ;; (runs:run-pre-hook run-id) |
︙ | |||
672 673 674 675 676 677 678 | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 | - - - - - - + + + + + + | (if (not (hash-table-ref/default flags "-rerun" #f)) (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS")) ;; recursive call to self (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))))) (debug:print-info 0 *default-log-port* "No tests to run"))) (debug:print-info 4 *default-log-port* "All done by here") ;; TODO: try putting post hook call here |
︙ | |||
1645 1646 1647 1648 1649 1650 1651 | 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 | + + - + | (debug:print-info 4 *default-log-port* "cond branch - " "rtq-8") (debug:print-info 0 *default-log-port* "Have leftovers!") (loop (car reg)(cdr reg) '() reruns)) (else (debug:print-info 4 *default-log-port* "cond branch - " "rtq-9") (debug:print-info 4 *default-log-port* "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) ))) ;; end loop on sorted test names ;; this is the point where everything is launced and now you can mark the run in metadata table as all launced (rmt:set-var (conc "lunch-complete-" run-id) "yes") |
︙ | |||
2005 2006 2007 2008 2009 2010 2011 | 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 | - + + + + | (lambda (action) (case action ((print) (print " " (simple-run-runname run) " " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S") " " (if remove "REMOVE" ""))) ((remove-runs) |
︙ | |||
2142 2143 2144 2145 2146 2147 2148 | 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 | - + | (> (string-length dira)(string-length dirb)) #f)))))) (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests (test-retry-time (make-hash-table)) (backgrounded-remove-status (make-hash-table)) (backgrounded-remove-last-visit (make-hash-table)) (backgrounded-remove-result (make-hash-table)) |
︙ | |||
2489 2490 2491 2492 2493 2494 2495 | 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 | - + + + + + - + - + + + | (define (runs:handle-locking target keys runname lock unlock user) (let* ((db #f) (rundat (mt:get-runs-by-patt keys runname target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1))) (for-each (lambda (run) |
︙ |
Modified server.scm from [8ce184eea5] to [868645b72c].
︙ | |||
326 327 328 329 330 331 332 | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 | - + | (else 600)) (random 5))) ;; add a small random number just in case a lot of jobs hit the work hosts simultaneously (lock-file (conc areapath "/logs/server-start.lock"))) (if (> (- (current-seconds) when-run) run-delay) (begin (common:simple-file-lock-and-wait lock-file expire-time: 15) (server:run areapath) |
︙ | |||
498 499 500 501 502 503 504 | 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 | - - + + - - + - - - + + + + + + + - - - + - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - + + + - - - - - + - - - - - + + + + - - - - - - - + - - - - - - - - - - + - - - - - + + + - - - - - - - - - + + + + + + + + + + + + + - - - - - - - - - - - - - - - + + + + + + - - - - - - + + - - - - - + + - - - - - - + + + + + + + + + - - - + - - - - - - - - + + + - - - - - - - - - - - - - - - - - - - - - - + - - - - - - - - - + + - - - - - - - - - + - - + - - - - - - - - - - - - - - - - - + + - - - - - - - - - - - - - - + + + + + + + | ;; (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180))) ;; (server:release-sync-lock) ;; (server:have-sync-lock?)) ;; (else #f)))) ;; moving this here as it needs access to db and cannot be in common. ;; |
Modified tasks.scm from [9a414ee32a] to [31f7d3eb33].
︙ | |||
991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 | 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 | + | ;; get runs changed since last sync ;; (define (tasks:sync-test-data dbh cached-info area-info) ;; (let* (( (define (tasks:sync-to-postgres configdat dest) (print "In sync") (let* ((dbh (pgdb:open configdat dbname: dest)) (area-info (pgdb:get-area-by-path dbh *toppath*)) (cached-info (make-hash-table)) (start (current-seconds)) (test-patt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) |
︙ | |||
1012 1013 1014 1015 1016 1017 1018 | 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 | - + + + + - + | (begin (print "Error: Provide runname") (exit 1))) (if (and (not target) run-name) (begin (print "Error: Provide target") (exit 1))) |
Modified tests.scm from [c7490d0df8] to [3fce4840b2].
︙ | |||
483 484 485 486 487 488 489 | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 | + + + - + | tol "," units "," dcomment ",," ;; extra comma for status type ))) ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment. (rmt:csv->test-data run-id test-id dat) ;; This was added in check-in a5adfa3f9a. Message was: "...added delay in set-values to allow for delayed write on server start" ;; I'm inserting an arbitrary rmt: call to force/ensure that the server is available to (hopefully) prevent a communication issue. (rmt:get-var "MEGATEST_VERSION") ;; this does NOTHING but ensure the server is reachable. This is almost certainly NOT needed :) |
︙ |