Comment: | merged v1.64-new-pkts |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.64 |
Files: | files | file ages | folders |
SHA1: |
77cb77fb6af73ab821a7a28091f645c5 |
User & Date: | bjbarcla on 2017-03-20 15:15:26 |
Other Links: | branch diff | manifest | tags |
2017-03-20
| ||
17:56 | Support for /QUICK check-in: b93c0e396c user: matt tags: v1.64 | |
15:15 | merged v1.64-new-pkts check-in: 77cb77fb6a user: bjbarcla tags: v1.64 | |
15:14 | fixed issues related to PWD not matching -start-dir argument check-in: 75dc576fb1 user: bjbarcla tags: v1.64 | |
13:35 | Merged server-fix Closed-Leaf check-in: 1de85e740b user: matt tags: v1.64-new-pkts | |
Modified api.scm from [e21b71bae7] to [f1d46841da].
︙ | |||
116 117 118 119 120 121 122 | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 | - + | ;; - returns #( flag result ) ;; (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain)) ) |
︙ | |||
148 149 150 151 152 153 154 | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 | - + | ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl ;; SERVERS ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ;; TESTS |
︙ |
Modified archive.scm from [31c5249136] to [7dd47285c1].
︙ | |||
109 110 111 112 113 114 115 | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | - + | (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)) (archive-dir (if archive-info (cdr archive-info) #f)) (archive-id (if archive-info (car archive-info) -1)) (disk-groups (make-hash-table)) (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (compress (or (configf:lookup *configdat* "archive" "compress") "9")) |
︙ | |||
209 210 211 212 213 214 215 | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 | - + | (hash-table-keys disk-groups)) #t)) (define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) |
︙ |
Modified client.scm from [d740aa52d4] to [19d242e4dd].
︙ | |||
93 94 95 96 97 98 99 | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | - + | (if (and host port) (let* ((start-res (case *transport-type* ((http)(http-transport:client-connect host port)))) (ping-res (case *transport-type* ((http)(rmt:login-no-auto-client-setup start-res))))) (if (and start-res ping-res) |
︙ |
Modified common.scm from [525a5df01c] to [eab4c1e605].
︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | + + + - - - - - - + + + + + + + | (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit common)) (declare (uses keys)) (include "common_records.scm") ;; (require-library margs) ;; (include "margs.scm") ;; (define old-exit exit) ;; ;; (define (exit . code) ;; (if (null? code) ;; (old-exit) ;; (old-exit code))) (define getenv get-environment-variable) (define (safe-setenv key val) (if (substring-index ":" key) ;; variables containing : are for internal use and cannot be environment variables. (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\"") |
︙ | |||
950 951 952 953 954 955 956 | 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 | - - + + + + + + + | ((and (equal? args-testpatt "%") rtestpatt) (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) rtestpatt) (else args-testpatt)))) (define (common:get-linktree) (or (getenv "MT_LINKTREE") |
︙ | |||
1008 1009 1010 1011 1012 1013 1014 | 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 | + + + + + + + + + + + + - - - - - - - - - - - - + + + + + + + + + + + + | (common:get-homehost trynum: (- trynum 1))) #f)) (else (let* ((currhost (get-host-name)) (bestadrs (server:get-best-guess-address currhost)) ;; first look in config, then look in file .homehost, create it if not found (homehost (or (configf:lookup *configdat* "server" "homehost" ) (handle-exceptions exn (if (> trynum 0) (let ((delay-time (* (- 5 trynum) 5))) (mutex-unlock! *homehost-mutex*) (debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file, delaying " delay-time " seconds and trying again, message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! delay-time) (common:get-homehost trynum: (- trynum 1))) (begin (mutex-unlock! *homehost-mutex*) (debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1))) |
︙ | |||
1200 1201 1202 1203 1204 1205 1206 | 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 | - - - + + + - - - + + + - - + + | ;; S Y S T E M S T U F F ;;====================================================================== ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 ;; (define (common:lazy-modification-time fpath) (handle-exceptions |
︙ | |||
1609 1610 1611 1612 1613 1614 1615 | 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 | - + + | (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) |
︙ |
Modified common_records.scm from [7a47b5d16a] to [0a5321af09].
︙ | |||
24 25 26 27 28 29 30 | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | - - - + + + + + + + + + + + + + + + + + | ;; (define-syntax define-simple-syntax (syntax-rules () ((_ (name arg ...) body ...) (define-syntax name (syntax-rules () ((name arg ...) (begin body ...))))))) |
︙ | |||
95 96 97 98 99 100 101 | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | - + | (member n *verbosity*)) ((and (list? *verbosity*) ;; list list (list? n)) (not (null? (lset-intersection! eq? *verbosity* n)))) ((and (number? *verbosity*) (list? n)) (member *verbosity* n)))) |
︙ |
Modified configf.scm from [c034045a40] to [346c0caf52].
︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | + | ;; Config file handling ;;====================================================================== (use regex regex-case) ;; directory-utils) (declare (unit configf)) (declare (uses process)) (declare (uses env)) (declare (uses keys)) (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) |
︙ | |||
651 652 653 654 655 656 657 658 | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 | + + + + - - + + + - - - - + + + + + + + + + + + | (let ((ht (make-hash-table))) (for-each (lambda (section) (hash-table-set! ht (car section)(cdr section))) adat) ht)) ;; if (define (configf:read-alist fname) (handle-exceptions exn #f |
︙ |
Modified dashboard-tests.scm from [84e8bdf580] to [54ccc9758e].
︙ | |||
472 473 474 475 476 477 478 | 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 | - + - + | #f ;; do nothing, just keep on trucking .... (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring)) (make-hash-table)))) (testconfig (begin ;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) (runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process (handle-exceptions |
︙ |
Modified dashboard.scm from [9c476b54db] to [2ddcbd2dba].
︙ | |||
2710 2711 2712 2713 2714 2715 2716 | 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 | - + | (> modtime (- last-db-update-time 3)) ;; add three seconds of margin (> (current-seconds)(+ last-db-update-time 1))))) ;; (define *monitor-db-path* #f) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. |
︙ |
Modified db.scm from [9faf096d03] to [3398d87de1].
︙ | |||
896 897 898 899 900 901 902 | 896 897 898 899 900 901 902 903 904 905 906 907 908 909 | - | (define (db:multi-db-sync dbstruct . options) (if (not (launch:setup)) (debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.") (let* ((mtdb (dbr:dbstruct-mtdb dbstruct)) (tmpdb (db:get-db dbstruct)) (refndb (dbr:dbstruct-refndb dbstruct)) (allow-cleanup #t) ;; (if run-ids #f #t)) |
︙ | |||
2578 2579 2580 2581 2582 2583 2584 | 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 | + + - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + | ;; AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) ;; (debug:print 0 *default-log-port* "QRY: " qry) ;; (db:delay-if-busy) ;; ;; NB// This call only operates on toplevel tests. Consider replacing it with more general call ;; (define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus) (let ((test-ids '())) (for-each |
︙ |
Modified dcommon.scm from [4355903cc1] to [19df68b7a1].
︙ | |||
607 608 609 610 611 612 613 | 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 | - - + - | ;; (set! dashboard:update-summary-tab updater) (iup:attribute-set! stats-matrix "WIDTHDEF" "40") (iup:vbox ;; (iup:label "Run statistics" #:expand "HORIZONTAL") stats-matrix))) (define (dcommon:servers-table commondat tabdat) |
︙ |
Modified http-transport.scm from [44c2ce6eea] to [a75c26faf4].
︙ | |||
55 56 57 58 59 60 61 | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | - + | (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (portlogger:open-run-close portlogger:find-port)) |
︙ | |||
110 111 112 113 114 115 116 | 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 143 144 145 146 147 148 149 150 151 152 153 | - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | ;; This is recursively run by http-transport:run until sucessful ;; (define (http-transport:try-start-server ipaddrstr portnum) (let ((config-hostname (configf:lookup *configdat* "server" "hostname"))) (debug:print-info 0 *default-log-port* "http-transport:try-start-server time=" (seconds->time-string (current-seconds)) " ipaddrsstr=" ipaddrstr " portnum=" portnum " config-hostname=" config-hostname) (handle-exceptions |
︙ | |||
227 228 229 230 231 232 233 | 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 | - - - - - - - - - - + + + + + + + + + + - - - - - - - + + + + + + + | (mutex-lock! *http-mutex*) ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines) ;; ((exn http client-error) e (print e))) (set! res (vector success (db:string->obj (handle-exceptions |
︙ | |||
438 439 440 441 442 443 444 | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 | - + - | (change-file-times server-log-file curr-time curr-time))) (loop 0 server-state bad-sync-count (current-milliseconds))) (else (debug:print-info 0 *default-log-port* "Server timed out. seconds since last db access: " (- (current-seconds) last-access)) (http-transport:server-shutdown port))))))) (define (http-transport:server-shutdown port) |
︙ |
Modified launch.scm from [e503042943] to [b27c32acbe].
︙ | |||
10 11 12 13 14 15 16 | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | - + | ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv) |
︙ | |||
411 412 413 414 415 416 417 | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 | - + - + + + | (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) |
︙ | |||
441 442 443 444 445 446 447 448 449 450 451 452 453 454 | 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path ) ;; (rollup-status 0) (if contour (setenv "MT_CONTOUR" contour)) ;; On NFS it can be slow and unreliable to get needed startup information. ;; i. Check if we are on the homehost, if so, proceed ;; ii. Check if host and port passed in via CMDINFO are valid and if ;; possible use them. (let ((bestadrs (server:get-best-guess-address (get-host-name))) (needcare #f)) (if (equal? homehost bestadrs) ;; we are likely on the homehost (debug:print-info 0 *default-log-port* "test " test-name " appears to be running on the homehost " homehost) (let ((host-port (if serverurl (string-split serverurl ":") #f))) (if (not *runremote*)(set! *runremote* (make-remote))) ;; init *runremote* (if (string? homehost) (if (and host-port (> (length host-port) 1)) (let* ((host (car host-port)) (port (cadr host-port)) (start-res (http-transport:client-connect host port)) (ping-res (rmt:login-no-auto-client-setup start-res))) (if (and start-res ping-res) (let ((url (http-transport:server-dat-make-url start-res))) (remote-conndat-set! *runremote* start-res) (remote-server-url-set! *runremote* url) (debug:print-info 0 *default-log-port* "connected to " url " using CMDINFO data.")) (debug:print-info 0 *default-log-port* "received " host ":" port " for url but could not connect.") )) (begin (debug:print-info 0 *default-log-port* (if host-port (conc "received invalid host-port information " host-port) "no host-port information received")) ;; potential for bad situation if simultaneous starting of hundreds of jobs on servers, set needcare. (set! needcare #t))) (begin (debug:print-info 0 *default-log-port* "received no homehost information. Please report this to support as it should not happen.") (set! needcare #t))))) (if needcare ;; due to very slow NFS we will do a brute force mkdir to ensure that the directory inode it truly available on this host (let ((logdir (conc top-path "/logs"))) ;; we'll try to create this directory (handle-exceptions exn (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn)) (create-directory logdir #t))))) ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? top-path) (> count 10)) (change-directory top-path) (begin (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " top-path " not found") |
︙ | |||
574 575 576 577 578 579 580 | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 | - + | (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) |
︙ | |||
680 681 682 683 684 685 686 | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 | - + | (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") (args:get-arg "-runtests") (args:get-arg "-execute"))) |
︙ | |||
740 741 742 743 744 745 746 | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 | - + | res))) (define (launch:setup-body #!key (force #f) (areapath #f)) (let* ((toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath (runname (common:args-get-runname)) (target (common:args-get-target exit-if-bad: #t)) (linktree (common:get-linktree)) |
︙ | |||
798 799 800 801 802 803 804 | 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 | + - - + + + + | (begin (debug:print-error 0 *default-log-port* "you are not in a megatest area!") (exit 1))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it (let* ((keys (rmt:get-keys)) (key-vals (keys:target->keyval keys target)) (linktree (common:get-linktree)) |
︙ | |||
838 839 840 841 842 843 844 | 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 | - + - | (set! *runconfigdat* rdat) (set! *toppath* toppath) (set! *configstatus* 'partial)) (begin (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") (exit 2)))))) ;; additional house keeping |
︙ | |||
915 916 917 918 919 920 921 | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 | - + + - - + + + | (define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2)) (let* ((item-path (if (string? itemdat) itemdat (item-list->path itemdat))) ;; if pass in string - just use it (runname (if (string? run-info) ;; if we pass in a string as run-info use it as run-name. run-info (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname"))) |
︙ | |||
1086 1087 1088 1089 1090 1091 1092 | 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 | - + | ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex (let* ((item-path (item-list->path itemdat)) |
︙ | |||
1183 1184 1185 1186 1187 1188 1189 | 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 | - + + + + + + + + | (create-directory work-area #t) (debug:print 0 *default-log-port* "WARNING: No disk work area specified - running in the test directory under tmp_run"))) (set! cmdparms (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) |
︙ |
Modified megatest.scm from [564c08894e] to [f0fc76328a].
︙ | |||
528 529 530 531 532 533 534 | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 | - + | ;; (if (args:get-arg "-clean-cache") (begin (set! *didsomething* #t) ;; suppress the help output. (if (getenv "MT_TARGET") ;; no point in trying if no target (if (args:get-arg "-runname") (let* ((toppath (launch:setup)) |
︙ | |||
783 784 785 786 787 788 789 | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 | - + - | (set! *didsomething* #t))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server") (args:get-arg "-kill-server")) (let ((tl (launch:setup))) (if tl |
︙ | |||
812 813 814 815 816 817 818 | 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 | - - - - - + + + + + | (last-update (vector-ref server 10)) (transport (vector-ref server 11)) (killed #f) (status (< last-update 20))) ;; (zmq-sockets (if status (server:client-connect hostname port) #f))) ;; no need to login as status of #t indicates we are connecting to correct ;; server |
︙ | |||
1181 1182 1183 1184 1185 1186 1187 | 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 | - + | (display (conc "target: " targetstr " ")) (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " ")))) runs-spec) (newline))))) (for-each (lambda (test) |
︙ |
Modified mt.scm from [0a710abd80] to [410c526eee].
︙ | |||
206 207 208 209 210 211 212 | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 | - + | (let ((test-dirs (tests:get-tests-search-path *configdat*))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (file-exists? tconfig-file) (file-read-access? tconfig-file)) |
︙ |
Modified mtut.scm from [08476a2140] to [9e88c442a2].
︙ | |||
10 11 12 13 14 15 16 | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | - + | ;; (include "common.scm") ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) |
︙ | |||
341 342 343 344 345 346 347 | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | - + - + | (lambda (pkt) (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) (exists (lookup-by-uuid pdb uuid #f))) (if (not exists) (let* ((pktdat (string-intersperse (with-input-from-file pkt read-lines) "\n")) |
︙ | |||
389 390 391 392 393 394 395 | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 | - + + | (let* ((sched (cond ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time ((number? sched-in) sched-in) (else (current-seconds)))) (args-data (if args-alist args-alist (hash-table->alist args:arg-hash))) |
︙ | |||
759 760 761 762 763 764 765 | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 | - + | (fold (lambda (a res) (let* ((key (car a)) ;; get the key name (val (cdr a)) (par (lookup-param-by-key key))) ;; (print "key: " key " val: " val " par: " par) (if par (conc res " " (param-translate par) " " val) |
︙ | |||
805 806 807 808 809 810 811 | 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 | - + | (areas (configf:get-section mtconf "areas")) (contours (configf:get-section mtconf "contours")) (pkts (find-pkts pdb '(cmd) '())) (torun (make-hash-table)) ;; target => ( ... info ... ) (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering (for-each (lambda (pktdat) |
︙ |
Modified portlogger.scm from [fd5d390b65] to [e604a481b0].
︙ | |||
48 49 50 51 52 53 54 | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | - - - - - - - - - + + + + + + + + + + + + - + + | fail_count INTEGER DEFAULT 0, update_time TIMESTAMP DEFAULT (strftime('%s','now')) );") db)) (define (portlogger:open-run-close proc . params) (let* ((fname (conc "/tmp/." (current-user-name) "-portlogger.db")) (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away |
︙ | |||
97 98 99 100 101 102 103 | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | - - - - - - - - - - - - - - + + + + + + + + + + + + + + | (sqlite3:finalize! qry1) (sqlite3:finalize! qry2) (sqlite3:finalize! qry3) res)) (define (portlogger:get-prev-used-port db) (handle-exceptions |
︙ |
Modified rmt.scm from [fb0a2ceccb] to [5167aff935].
︙ | |||
31 32 33 34 35 36 37 | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | + - - - - - - - + + + + + + + | ;;====================================================================== ;; if a server is either running or in the process of starting call client:setup ;; else return #f to let the calling proc know that there is no server available ;; (define (rmt:get-connection-info areapath #!key (area-dat #f)) ;; TODO: push areapath down. (let* ((runremote (or area-dat *runremote*)) (cinfo (if (remote? runremote) |
︙ | |||
444 445 446 447 448 449 450 | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 | - + | (debug:print 3 *default-log-port* "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) |
︙ |
Modified runconfigs.config from [5d4a6b6df5] to [54666c6a32].
|
Modified runs.scm from [1011cd6b97] to [8959c65de3].
︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | + | (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) (declare (uses archive)) (declare (uses keys)) ;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") |
︙ | |||
54 55 56 57 58 59 60 | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | - + | (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) (let* ((target (or intarget (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) |
︙ | |||
209 210 211 212 213 214 215 | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | - + | (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) (required-tests #f) ;; Put fully qualified test/testpath names in this list to be done (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) |
︙ | |||
235 236 237 238 239 240 241 | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 | - - + + | ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () |
︙ | |||
316 317 318 319 320 321 322 | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 | - - - + + + + + + + + | ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. ;; ;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED") ;; Now convert anything in allow-auto-rerun to NOT_STARTED ;; |
︙ | |||
1073 1074 1075 1076 1077 1078 1079 | 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 | - + | (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) (if (and mcj (string->number mcj)) (string->number mcj) 1))) ;; length of the register queue ahead (reglen (if (number? reglen-in) reglen-in 1)) (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle (last-time-some-running (current-seconds)) |
︙ | |||
1168 1169 1170 1171 1172 1173 1174 | 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 | - - - + + + | testmode: testmode newtal: newtal itemmaps: itemmaps ;; prereqs-not-met: prereqs-not-met ))) (runs:dat-regfull-set! runsdat regfull) ;; every couple minutes verify the server is there for this run |
︙ | |||
1645 1646 1647 1648 1649 1650 1651 | 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 | - + | ;; 'set-state-status ;; ;; NB// should pass in keys? ;; (define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(mode 'remove-all)(options '())) (common:clear-caches) ;; clear all caches (let* ((db #f) |
︙ | |||
1703 1704 1705 1706 1707 1708 1709 | 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 | - + | ;; seek and kill in flight -runtests with % as testpatt here ;; (if (equal? testpatt "%") (tasks:kill-runner target run-name testpatt) ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) |
︙ |
Modified tasks.scm from [57e383db06] to [e18dae9779].
︙ | |||
50 51 52 53 54 55 56 57 58 59 60 61 62 63 | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | + - + | (debug:print 0 *default-log-port* waiting-msg)) (if (> count 0) (begin (thread-sleep! 1) (loop (file-exists? fullpath) (- count 1))) (begin (debug:print 0 *default-log-port* "ERROR: removing the journal file " fullpath ", this is not good. Look for disk full, write access and other issues.") (if remove (system (conc "rm -rf " fullpath))) #f))) #t)))))) (define (tasks:get-task-db-path) (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") (configf:lookup *configdat* "setup" "dbdir") |
︙ | |||
91 92 93 94 95 96 97 | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | - + | (debug:print 0 *default-log-port* " exn=" (condition->list exn)) (thread-sleep! 1) (tasks:open-db numretries (- numretries 1))) (begin (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* " exn=" (condition->list exn)))) |
︙ |
Modified tests/Makefile from [ca46bf23f9] to [3cbc059672].
︙ | |||
17 18 19 20 21 22 23 | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | + - + + - + | FS = $(shell df -T .|tail -1|awk '{print $$2}') VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5) # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" all : build unit test4 |
︙ |
Modified tests/fullrun/megatest.config from [353b25ebc0] to [ad7007c3e5].
︙ | |||
97 98 99 100 101 102 103 | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | - - + + | # override the html viewer launch command # # htmlviewercmd firefox -new-window htmlviewercmd arora # -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run # (nb// this is in addition to NOT_STARTED which is automatically re-run) |
︙ |
Added tests/unittests/all-rmt.scm version [091111a6e5].