Differences From Artifact [5559976353]:
- File common.scm — part of check-in [42bfe6fba7] at 2022-11-21 07:14:33 on branch v1.70-nohomehost — Basic auto server start working (user: matt, size: 141302) [annotate] [blame] [check-ins using] [more...]
To Artifact [2af8632d78]:
- File
common.scm
— part of check-in
[e2a27caa33]
at
2023-01-18 18:21:48
on branch v1.80
— Normalize toppath for /tmp db area to address weird csh /home/matt/data/megatest vs. pwd.
Get DEADs after a while. There is a crash related to connection handling. (user: matt, size: 142216) [annotate] [blame] [check-ins using]
︙ | |||
406 407 408 409 410 411 412 413 | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 | + + + + - - + + + + + + + | (define (common:version-db-delta) (- megatest-version (common:get-last-run-version-number))) (define (common:version-changed?) (not (equal? (common:get-last-run-version) (common:version-signature)))) ;; From 1.70 to 1.80, db's are compatible. (define (common:api-changed?) (let* ( |
︙ | |||
518 519 520 521 522 523 524 | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 | - + | ;; logs directory you wish to log-rotate. ;; (define (common:rotate-logs) (let* ((all-files (make-hash-table)) (stats (make-hash-table)) (inc-stat (lambda (key) (hash-table-set! stats key (+ (hash-table-ref/default stats key 0) 1)))) |
︙ | |||
597 598 599 600 601 602 603 | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 | + - + - + | (debug:print-info 0 *default-log-port* "Deleted " (length files) " files from logs, keeping " max-allowed " files.")))))) ;;====================================================================== ;; Force a megatest cleanup-db if version is changed and skip-version-check not specified ;; Do NOT check if not on homehost! ;; (define (common:exit-on-version-changed) (if (and *toppath* ;; do nothing if *toppath* not yet provided |
︙ | |||
624 625 626 627 628 629 630 | 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 | - + - + | (print-call-chain (current-error-port)) (exit 1)) (common:cleanup-db dbstruct))) ((not (common:file-exists? mtconf)) (debug:print 0 *default-log-port* " megatest.config does not exist in this area. Cannot proceed with megatest version migration.") (exit 1)) ((not (common:file-exists? dbfile)) |
︙ | |||
708 709 710 711 712 713 714 | 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 | + + - - - - - - - - - + + + + + + + + + | (if dat dat "")))) (define (common:alist-ref/default key alist default) (or (alist-ref key alist) default)) ;; moved into commonmod ;; |
︙ | |||
944 945 946 947 948 949 950 | 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 | + - + - + - + | *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* ((toppath (common:real-path *toppath*)) |
︙ | |||
978 979 980 981 982 983 984 | 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 | + - - + + | (message-digest-string (md5-primitive) str)) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:run-sync?) (and *toppath* ;; gate if called before *toppath* is set |
︙ | |||
1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 | 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 | + + + + + + + + + + + + + + + + + + + + | (begin (debug:print-error 0 *default-log-port* "command \"/bin/readlink -f " path "\" failed. exn=" exn) path) ;; just give up (with-input-from-pipe (conc "/bin/readlink -f " path) (lambda () (read-line))))) ;; for reasons I don't understand multiple calls to real-path in parallel threads ;; must be protected by mutexes ;; (define (common:real-path inpath) ;; (process:cmd-run-with-stderr->list "readlink" "-f" inpath)) ;; cmd . params) ;; (let-values ;; (((inp oup pid) (process "readlink" (list "-f" inpath)))) ;; (with-input-from-port inp ;; (let loop ((inl (read-line)) ;; (res #f)) ;; (print "inl=" inl) ;; (if (eof-object? inl) ;; (begin ;; (close-input-port inp) ;; (close-output-port oup) ;; ;; (process-wait pid) ;; res) ;; (loop (read-line) inl)))))) (with-input-from-pipe (conc "readlink -f " inpath) read-line)) ;;====================================================================== ;; returns *effective load* (not normalized) ;; (define (common:get-intercept onemin fivemin) (if (< onemin fivemin) ;; load is decreasing, just use the onemin load onemin |
︙ | |||
1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 | 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 | + + + + + + + | (begin ;; found a host, return it (debug:print 0 *default-log-port* "INFO: Found host: " new-best " load: " load " last-used: " delta " seconds ago, with job-rate: " job-rate) (host-last-used-set! rec curr-time) new-best) (if (null? tal) #f (loop (car tal)(cdr tal) best-host))))))))) (define (common:wait-for-homehost-load maxnormload msg) (let loop ((start-time (current-seconds))) ;; we saw some instances of this being called before *toppath* was set. This might be an early setup race. This delay should help but it is impossible to test... (if (not *toppath*) (begin (debug:print 0 *default-log-port* "ERROR: common:wait-for-homehost-load called before *toppath* set.") (thread-sleep! 30) (if (< (- (current-seconds) start-time) 300) (loop start-time))))) (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local. #f (server:choose-server *toppath* 'homehost))) (hh (if hh-dat (car hh-dat) #f))) (common:wait-for-normalized-load maxnormload msg hh))) (define (common:get-num-cpus remote-host) |
︙ | |||
2216 2217 2218 2219 2220 2221 2222 | 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 | - - - - - - - - - - - - - - - - - - - - | (define (get-uname . params) (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) |
︙ |