Overview
Comment: | Added stop-the-train, crowbar switch |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.70 |
Files: | files | file ages | folders |
SHA1: |
bf4367276064e2920c46982263af598e |
User & Date: | matt on 2022-11-08 22:15:13 |
Other Links: | branch diff | manifest | tags |
Context
2022-11-10
| ||
13:37 | Fixed server/client signature. I think. check-in: bf877ecde8 user: matt tags: v1.70 | |
2022-11-08
| ||
22:15 | Added stop-the-train, crowbar switch check-in: bf43672760 user: matt tags: v1.70 | |
14:24 | Added improved new to old converter check-in: 5458437545 user: mrwellan tags: v1.70 | |
Changes
Modified common.scm from [8e93110015] to [7a004393e6].
︙ | ︙ | |||
40 41 42 43 44 45 46 47 48 49 50 51 52 53 | ;; (define old-exit exit) ;; ;; (define (exit . code) ;; (if (null? code) ;; (old-exit) ;; (old-exit code))) ;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* . ;; arguments - thunk, message (define (common:fail-safe thunk warning-message-on-exception) (handle-exceptions exn (begin | > > > > > > > > > > | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | ;; (define old-exit exit) ;; ;; (define (exit . code) ;; (if (null? code) ;; (old-exit) ;; (old-exit code))) (define (stop-the-train) (thread-start! (make-thread (lambda () (let loop () (if (and *toppath* (file-exists? (conc *toppath*"/stop-the-train"))) (begin (debug:print 0 *default-log-port* "ERROR: found file "*toppath*"/stop-the-train, exiting immediately") (exit 1))) (thread-sleep! 5) (loop)))))) ;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* . ;; arguments - thunk, message (define (common:fail-safe thunk warning-message-on-exception) (handle-exceptions exn (begin |
︙ | ︙ |
Modified commonmod.scm from [79bf78cc96] to [2570fcf4eb].
︙ | ︙ | |||
206 207 208 209 210 211 212 | ;; (define (get-cfg-areas cfgdat) (let ((adat (get-section cfgdat "areas"))) (map (lambda (entry) `(,(car entry) . ,(val->alist (cadr entry)))) adat))) | | > > > > | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | ;; (define (get-cfg-areas cfgdat) (let ((adat (get-section cfgdat "areas"))) (map (lambda (entry) `(,(car entry) . ,(val->alist (cadr entry)))) adat))) ;;====================================================================== ;; misc stuff ;;====================================================================== ;; (define (debug:print . params) #f) ;; (define (debug:print-info . params) #f) ;; ;; (define (set-functions dbgp dbgpinfo) ;; (set! debug:print dbgp) ;; (set! debug:print-info dbgpinfo)) |
︙ | ︙ |
Modified dashboard.scm from [124f6f1518] to [6283f67b19].
︙ | ︙ | |||
3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 | (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (define (main) ;; (print "Starting dashboard main") | > | | 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 | (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== (stop-the-train) (define (main) ;; (print "Starting dashboard main") (let* ((mtdb-path (conc *toppath* "/.megatest/main.db")) (target (args:get-arg "-target")) (commondat (dboard:commondat-make))) (if target (begin (args:remove-arg-from-ht "-target") (dboard:commondat-target-set! commondat target) |
︙ | ︙ |
Modified dbfile.scm from [2d10dcee17] to [5fcb8e6b81].
︙ | ︙ | |||
329 330 331 332 333 334 335 | (define (dbfile:print-err . params) (with-output-to-port (current-error-port) (lambda () (apply print params)))) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | > > > > > > | | 329 330 331 332 333 334 335 336 337 338 339 340 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 367 368 369 370 371 372 373 374 375 376 377 378 379 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 409 410 411 412 413 414 415 416 | (define (dbfile:print-err . params) (with-output-to-port (current-error-port) (lambda () (apply print params)))) (define (dbfile:cautious-open-database fname init-proc sync-mode journal-mode #!optional (tries-left 500)) (let* ((busy-file (conc fname"-journal")) (delay-time (* (- 51 tries-left) 1.1)) (write-access (file-write-access? fname)) (dir-access (file-write-access? (pathname-directory fname))) (retry (lambda () (thread-sleep! delay-time) (if (> tries-left 0) (dbfile:cautious-open-database fname init-proc sync-mode: sync-mode journal-mode: journal-mode (- tries-left 1)))))) (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up.")) (if (and (file-write-access? fname) (file-exists? busy-file)) (begin (if (common:low-noise-print 120 busy-file) (dbfile:print-err "INFO: dbfile:cautious-open-database: journal file " busy-file" exists, trying again in few seconds.")) (thread-sleep! 1) (if (eq? tries-left 2) (begin (dbfile:print-err "INFO: forcing journal rollup "busy-file) (dbfile:brute-force-salvage-db fname))) (dbfile:cautious-open-database fname init-proc sync-mode: sync-mode journal-mode: journal-mode (- tries-left 1))) (let* ((result (condition-case (if dir-access (dbfile:with-simple-file-lock (conc fname ".lock") (lambda () (let* ((db-exists (file-exists? fname)) (db (sqlite3:open-database fname))) ;; creates an empty db if it did not already exist. (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000)) (if sync-mode (sqlite3:execute db (conc "PRAGMA synchronous = "sync-mode";"))) (if journal-mode (sqlite3:execute db (conc "PRAGMA journal_mode = "journal-mode";"))) (if (and init-proc (not db-exists)) (init-proc db)) db))) (begin (if (file-exists? fname ) (let ((db (sqlite3:open-database fname))) ;; pragmas synchronous not needed because this db is used read-only ;; (sqlite3:execute db (conc "PRAGMA synchronous = "mode";") db ) (print "file doesn't exist: " fname)))) (exn (io-error) (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.") (retry)) (exn (corrupt) (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.") (retry)) (exn (busy) (dbfile:print-err exn "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.") (retry)) (exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.") (retry)) (exn () (dbfile:print-err exn "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)) (retry))))) result)))) (define (dbfile:brute-force-salvage-db fname) (let* ((backupfname (conc fname"-"(current-process-id)".bak")) (cmd (conc "cp "fname" "backupfname";mv "fname" "(conc fname ".delme;") "cp "backupfname" "fname))) (dbfile:print-err "WARNING: attempting recovery of file "fname" by running commands:\n" " "cmd) (system cmd))) (define (dbfile:open-no-sync-db dbpath) (if *no-sync-db* *no-sync-db* (begin (if (not (file-exists? dbpath)) |
︙ | ︙ |
Modified launch.scm from [8b5c3e3658] to [60d380c61b].
︙ | ︙ | |||
914 915 916 917 918 919 920 921 922 923 924 925 926 927 | ;; side effects: ;; sets; *configdat* (megatest.config info) ;; *runconfigdat* (runconfigs.config info) ;; *configstatus* (status of the read data) ;; (define (launch:setup #!key (force-reread #f) (areapath #f)) (mutex-lock! *launch-setup-mutex*) (if (and *toppath* (eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all (begin (debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") (mutex-unlock! *launch-setup-mutex*) *toppath*) (let ((res (launch:setup-body force-reread: force-reread areapath: areapath))) | > > > > > > | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 | ;; side effects: ;; sets; *configdat* (megatest.config info) ;; *runconfigdat* (runconfigs.config info) ;; *configstatus* (status of the read data) ;; (define (launch:setup #!key (force-reread #f) (areapath #f)) (mutex-lock! *launch-setup-mutex*) ;; this stops the train quickly for new processes (if (and *toppath* (file-exists? (conc *toppath*"/stop-the-train"))) (begin (debug:print 0 *default-log-port* "ERROR: found file "*toppath*"/stop-the-train, exiting immediately") (exit 1))) (if (and *toppath* (eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all (begin (debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") (mutex-unlock! *launch-setup-mutex*) *toppath*) (let ((res (launch:setup-body force-reread: force-reread areapath: areapath))) |
︙ | ︙ |
Modified megatest.scm from [92b16ace59] to [7c70251ef1].
︙ | ︙ | |||
555 556 557 558 559 560 561 562 563 564 565 566 567 568 | (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val))) ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) ;; (if start-watchdog ;; (thread-start! *watchdog*)) #t ) ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions (define (open-logfile logpath-in) (condition-case (let* ((log-dir (or (pathname-directory logpath-in) ".")) (fname (pathname-strip-directory logpath-in)) (logpath (if (> (string-length fname) 250) | > > | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 | (start-watchdog (and (null? no-watchdog-args-vals) start-watchdog-specail-arg-val))) ;(print "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals " start-watchdog-specail-arg-val:" start-watchdog-specail-arg-val " start-watchdog:" start-watchdog) ;; (if start-watchdog ;; (thread-start! *watchdog*)) #t ) ;; stop the train watchdog (stop-the-train) ;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions (define (open-logfile logpath-in) (condition-case (let* ((log-dir (or (pathname-directory logpath-in) ".")) (fname (pathname-strip-directory logpath-in)) (logpath (if (> (string-length fname) 250) |
︙ | ︙ |