Overview
Comment: | Saftey fixes and minor cleanup ==/3.73/1.3/PASS/1203/orion/== |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.65-cleanup |
Files: | files | file ages | folders |
SHA1: |
79674abc641f7014ceef05b533851364 |
User & Date: | mrwellan on 2020-08-24 18:06:27 |
Original Comment: | Saftey fixes and minor cleanup |
Other Links: | branch diff | manifest | tags |
Context
2020-08-25
| ||
10:12 | added support for custom load-jump-limit and added setup, keep-deleted-records (in seconds, keep deleted records this long) ==/7.9/0.9/WARN/1201/mars/== check-in: d1548b7a57 user: mrwellan tags: v1.65-cleanup | |
2020-08-24
| ||
18:06 | Saftey fixes and minor cleanup ==/3.73/1.3/PASS/1203/orion/== check-in: 79674abc64 user: mrwellan tags: v1.65-cleanup | |
06:54 | filled out more exception handlers. ==/3.73/1.3/PASS/1203/orion/== check-in: 1cf9221da5 user: mrwellan tags: v1.65-cleanup | |
Changes
Modified common.scm from [b77238c527] to [bc77148d79].
︙ | |||
906 907 908 909 910 911 912 | 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 | - - - + + + + + | (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-testsuite-name) (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description. (configf:lookup *configdat* "setup" "testsuite" ) (getenv "MT_TESTSUITE_NAME") |
︙ | |||
946 947 948 949 950 951 952 | 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 | + - - - - - - - + + + + + + + + + + + + | *db-cache-path* (if *toppath* ;; common:get-create-writeable-dir (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path* ", exn=" exn) (exit 1)) (let* ((tsname (common:get-testsuite-name)) |
︙ | |||
1189 1190 1191 1192 1193 1194 1195 | 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 | - + + | (tal (cdr dirs))) (let ((res (or (and (directory? hed) (file-write-access? hed) hed) (handle-exceptions exn (begin |
︙ | |||
1696 1697 1698 1699 1700 1701 1702 | 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 | + - + + | ;; (define (common:lazy-modification-time fpath) (handle-exceptions exn (begin (debug:print 0 *default-log-port* "Failed to get modifcation time for " fpath ", treating it as zero. exn=" exn) 0) (if (file-exists? fpath) |
︙ |
Modified common_records.scm from [f00d4d5706] to [80f9e14f2d].
︙ | |||
122 123 124 125 126 127 128 129 130 131 132 133 | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | + + - - + + | (not (null? (lset-intersection! eq? *verbosity* n)))) ((and (number? *verbosity*) (list? n)) (member *verbosity* n)))) (define (debug:setup) (let ((debugstr (or (args:get-arg "-debug") (args:get-arg "-debug-noprop") (getenv "MT_DEBUG_MODE")))) (set! *verbosity* (debug:calc-verbosity debugstr)) (debug:check-verbosity *verbosity* debugstr) ;; if we were handed a bad verbosity rule then we will override it with 1 and continue (if (not *verbosity*)(set! *verbosity* 1)) (if (and (not (args:get-arg "-debug-noprop")) |
︙ |
Modified db.scm from [1897cba456] to [e3d7e1adb0].
︙ | |||
455 456 457 458 459 460 461 | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 | - + | #f (handle-exceptions exn (begin (print "Attempt to safely close sqlite3 db failed. Trying again. exn=" exn) (thread-sleep! 3) (sqlite3:interrupt! db) |
︙ | |||
478 479 480 481 482 483 484 | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 | - + - - + + | ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. (let ((tdbs (map db:dbdat-get-db (stack->list (dbr:dbstruct-dbstack dbstruct)))) (mdb (db:dbdat-get-db (dbr:dbstruct-mtdb dbstruct))) (rdb (db:dbdat-get-db (dbr:dbstruct-refndb dbstruct))) (stmt-cache (dbr:dbstruct-stmt-cache dbstruct))) (map (lambda (db) |
︙ | |||
2178 2179 2180 2181 2182 2183 2184 | 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 | - - + + | (string->number res) #f))) (if newres newres res)) res))) |
︙ |
Modified http-transport.scm from [cf6ca516a2] to [6328aa908d].
︙ | |||
130 131 132 133 134 135 136 | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | + + + - + | (send-response body: (http-transport:html-test-log $) headers: '((content-type text/HTML)))) ((equal? (uri-path (request-uri (current-request))) '(/ "dashboard")) (send-response body: (http-transport:html-dboard $) headers: '((content-type text/HTML)))) (else (continue)))))))) (handle-exceptions exn (debug:print 0 *default-log-port* "Failed to create file " start-file ", exn=" exn) |
︙ | |||
293 294 295 296 297 298 299 300 301 302 303 304 305 306 | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 | + | 0)) ;; added this speculatively ;; Shouldn't this be a call to the managed call-all-connections stuff above? (close-all-connections!) (mutex-unlock! *http-mutex*) )) (time-out (lambda () (thread-sleep! 45) (debug:print 0 *default-log-port* "WARNING: send-receive took more than 45 seconds!!") #f)) (th1 (make-thread send-recieve "with-input-from-request")) (th2 (make-thread time-out "time out"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) (thread-terminate! th2) |
︙ | |||
429 430 431 432 433 434 435 | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 | + + + - + | (iface (car server-info)) (port (cadr server-info)) (last-access 0) (server-timeout (server:expiration-timeout)) (server-going #f) (server-log-file (args:get-arg "-log"))) ;; always set when we are a server (handle-exceptions exn (debug:print 0 *default-log-port* "Failed to create " started-file ", exn=" exn) |
︙ |
Modified launch.scm from [50fbfebf83] to [4a656b9137].
︙ | |||
1546 1547 1548 1549 1550 1551 1552 | 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 | - - - - - - - - - - - + + + + + + + + + + + | ) itemdat))) (testprevvals (alist->env-vars (hash-table-ref/default tconfig "pre-launch-env-overrides" '()))) ;; Launchwait defaults to true, must override it to turn off wait (launchwait (if (equal? (configf:lookup *configdat* "setup" "launchwait") "no") #f #t)) (launch-results-prev (apply (if launchwait ;; BB: TODO: refactor this to examine return code of launcher, if nonzero, set state to launch failed. |
︙ |
Modified megatest.scm from [c469764f4f] to [06490b6ac8].
︙ | |||
208 209 210 211 212 213 214 215 216 217 218 219 220 221 | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | + | -list-servers : list the servers -kill-servers : kill all servers -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm -mark-incompletes : find and mark incomplete tests -ping run-id|host:port : ping server, exit with 0 if found -debug N|N,M,O... : enable debug 0-N or N and M and O ... -debug-noprop N|M,M,O...: enable debug but do not propagate to subprocesses via MT_DEBUG -config fname : override the megatest.config file with fname -append-config fname : append fname to the megatest.config file Utilities -env2file fname : write the environment to fname.csh and fname.sh -envcap a : save current variables labeled as context 'a' in file envdat.db -envdelta a-b : output enviroment delta from context a to context b to -o fname |
︙ | |||
343 344 345 346 347 348 349 350 351 352 353 354 355 356 | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 | + | "-actions" "-precmd" "-include" "-exclude-rx" "-exclude-rx-from" "-debug" ;; for *verbosity* > 2 "-debug-noprop" "-create-test" "-override-timeout" "-test-files" ;; -test-paths is for listing all "-load" ;; load and exectute a scheme file "-section" "-var" "-dumpmode" |
︙ |
Modified rmt.scm from [f699e4c73f] to [39d97c528a].
︙ | |||
311 312 313 314 315 316 317 | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 | - - - - - - - - - - - - - - - - - - - | (if success ;; success only tells us that the transport was ;; successful, have to examine the data to see if ;; there was a detected issue at the other end (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd) (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params) ))) |
︙ | |||
422 423 424 425 426 427 428 | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 | - - - - - - - - - - - | (print "transport failed. exn=" exn) #f) (http-transport:client-api-send-receive run-id connection-info cmd params)))) (if (and res (vector-ref res 0)) (vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!! #f))) |
︙ | |||
476 477 478 479 480 481 482 | 446 447 448 449 450 451 452 453 454 455 456 457 458 459 | - - - | (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) ;; given a hostname, return a pair of cpu load and update time representing latest intelligence from tests running on that host (define (rmt:get-latest-host-load hostname) (rmt:send-receive 'get-latest-host-load 0 (list hostname))) |
︙ | |||
647 648 649 650 651 652 653 | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 | - - - - - | ;; (apply append (map (lambda (run-id) ;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) ;; run-id-list)))) (define (rmt:delete-test-records run-id test-id) (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) |
︙ | |||
694 695 696 697 698 699 700 | 656 657 658 659 660 661 662 663 664 665 666 667 668 669 | - - - | (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) (apply append (map (lambda (run-id) (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) |
︙ |
Modified runs.scm from [b9d660d885] to [95c765665a].
︙ | |||
1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 | 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 | + + + | )) ;; every time though the loop increment the test/itempatt val. ;; when the min is > max-allowed and none running then force exit ;; (define *max-tries-hash* (make-hash-table)) (define (runs:pretty-long-list lst) (if (> (length lst) 8)(append (take lst 3)(list "...")) lst)) ;;====================================================================== ;; runs:run-tests-queue is called by runs:run-tests ;;====================================================================== ;; ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > (define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) ;; At this point the list of parent tests is expanded |
︙ | |||
1616 1617 1618 1619 1620 1621 1622 | 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 | - + | reruns)))) ;; (loop (car tal)(cdr tal) reg reruns)))) (runs:incremental-print-results run-id) (debug:print 4 *default-log-port* "TOP OF LOOP => " "test-name: " test-name "\n hed: " hed |
︙ |
Modified server.scm from [bafb54f0c9] to [8058946e40].
︙ | |||
624 625 626 627 628 629 630 631 632 633 634 635 636 637 | 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 | + | (define (server:writable-watchdog-deltasync dbstruct) (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (common:run-sync?)) (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) (debug-mode (debug:debug-mode 1)) (last-time (current-seconds)) (no-sync-db (db:open-no-sync-db)) (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) (sync-duration 0) ;; run time of the sync in milliseconds ;;(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))) ) (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls (debug:print-info 2 *default-log-port* "Periodic sync thread started.") (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num) (if (and legacy-sync (not *time-to-exit*)) |
︙ | |||
745 746 747 748 749 750 751 | 746 747 748 749 750 751 752 753 754 755 756 | - + | (if (and (not *time-to-exit*) (< count 6)) ;; was 11, changing to 4. (begin (thread-sleep! 1) (delay-loop (+ count 1)))) (if (not *time-to-exit*) (loop)))) ;; time to exit, close the no-sync db here |