Changes In Branch v1.80-processes Through [b5f1f35f26] Excluding Merge-Ins
This is equivalent to a diff from 72065b6c5e to b5f1f35f26
2023-11-10
| ||
19:49 | Last seemingly good commit on all platforms. check-in: 1d9da3b7a0 user: matt tags: v1.80-revolution | |
2023-10-09
| ||
19:51 | Merged v1.80 in check-in: 38506ffe03 user: matt tags: v1.80 | |
19:38 | fix port setting Leaf check-in: b5f1f35f26 user: matt tags: v1.80-processes | |
10:59 | Added force-init to db open proc. check-in: b1a043e49f user: mrwellan tags: v1.80-processes | |
2023-10-06
| ||
16:56 | Fixed dbmod:attach-sync so that it works for the non-id rows. Adjusted some log messages. Removed old lock files check-in: 1e29e5e90e user: mmgraham tags: v1.80 | |
2023-09-29
| ||
08:17 | Merged fork check-in: 35feb6b8db user: mrwellan tags: v1.80-processes | |
2023-09-25
| ||
19:04 | Added sync file age checking to -db2db check-in: 72065b6c5e user: mmgraham tags: v1.80 | |
19:02 | Corrected 20 second age check for sync lock file. Added exception handler for a sqlite3:with-transaction. check-in: 8f8169ac4d user: mmgraham tags: v1.80 | |
Modified api.scm from [c477d1f287] to [5fa313076b].
︙ | |||
401 402 403 404 405 406 407 408 409 410 411 412 413 414 | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 | + + + + + + | ((tasks-get-last) (apply tasks:get-last dbstruct params)) ;; NO SYNC DB ((no-sync-set) (apply db:no-sync-set *no-sync-db* params)) ((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params)) ((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params)) ((no-sync-get-lock) (apply db:no-sync-get-lock *no-sync-db* params)) ;; NO SYNC DB PROCESSES ((register-process) (apply dbfile:register-process *no-sync-db* params)) ((set-process-done) (apply dbfile:set-process-done *no-sync-db* params)) ((set-process-status) (apply dbfile:set-process-status *no-sync-db* params)) ((get-process-options) (apply dbfile:get-process-options *no-sync-db* params)) ;; ARCHIVES ;; ((archive-get-allocations) ((archive-register-disk) (apply db:archive-register-disk dbstruct params)) ((archive-register-block-name)(apply db:archive-register-block-name dbstruct params)) ;; ((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey)) |
︙ |
Modified dbfile.scm from [1a2e6b4c5e] to [4b315f3788].
︙ | |||
14 15 16 17 18 19 20 | 14 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 | - + - + + | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== |
︙ | |||
119 120 121 122 123 124 125 126 127 128 129 130 131 132 | 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 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | ;; used in simple-get-runs (thanks Brandon!) (define-record simple-run target id runname state status owner event_time) (define-record-printer (simple-run x out) (fprintf out "#,(simple-run ~S ~S ~S ~S)" (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) )))) ;; args is hash table of string to value ;; (define (get-purpose args) (let* ((get-arg (lambda (key) (hash-table-ref/default args key #f))) (get-switch (lambda keys (fold (lambda (key res) (if (hash-table-ref/default args key #f) (or key res) res)) #f keys))) (action (get-switch "-server" "-execute" "-run" "-rerun"))) (cond (action (substring action 1 (string-length action))) (else "nopurpose")))) ;; megatest process tracking (defstruct procinf (start (current-seconds)) (end -1) (host (get-host-name)) ;; why is this not being recognised? (pid (current-process-id)) (port -1) (cwd (current-directory)) (load #f) (purpose #f) ;; get-purpose needed to be run in megatest.scm (dbname #f) (mtbin (car (argv))) (mtversion #f) (status "running") ) (define *procinf* (make-procinf)) (define *dbstruct-dbs* #f) (define *db-open-mutex* (make-mutex)) (define *db-access-mutex* (make-mutex)) ;; used in common.scm (define *no-sync-db* #f) (define *db-sync-in-progress* #f) (define *db-with-db-mutex* (make-mutex)) (define *max-api-process-requests* 0) |
︙ | |||
360 361 362 363 364 365 366 | 401 402 403 404 405 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 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 | - + + - + - + - + + | (define (dbfile:print-err . params) (with-output-to-port (current-error-port) (lambda () (apply print params)))) |
︙ | |||
463 464 465 466 467 468 469 | 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 617 618 619 620 621 622 | - + + + + + + + + + + + + + + + - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT, val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));" "CREATE TABLE IF NOT EXISTS no_sync_locks (key TEXT, val TEXT, |
︙ |
Modified launch.scm from [9d838959e9] to [470997d4b0].
︙ | |||
30 31 32 33 34 35 36 | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | - - - + + + | (declare (uses db)) (declare (uses rmtmod)) (declare (uses ezsteps)) ;; (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses mtargs)) |
︙ |
Modified megatest.scm from [429d7d2934] to [f7c0fef20e].
︙ | |||
539 540 541 542 543 544 545 546 547 548 549 550 551 552 | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 | + + + + + | (exit 1)))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) ;; set the purpose field in procinf (procinf-purpose-set! *procinf* (get-purpose args:arg-hash)) (procinf-mtversion-set! *procinf* megatest-version) ;; The watchdog is to keep an eye on things like db sync etc. ;; ;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage ;;(define *watchdog* (make-thread ;; (lambda () ;; (handle-exceptions |
︙ |
Modified rmt.scm from [6ddef022d0] to [64f3d622e8].
︙ | |||
724 725 726 727 728 729 730 731 732 733 734 735 736 737 | 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 | + + + + + + + + + + + + + + | (define (rmt:no-sync-del! var) (rmt:send-receive 'no-sync-del! #f `(,var))) (define (rmt:no-sync-get-lock keyname) (rmt:send-receive 'no-sync-get-lock #f `(,keyname))) ;; process registration (define (rmt:register-process host port pid starttime status purpose dbname mtversion) (rmt:send-receive 'register-process #f (list host port pid starttime status purpose dbname mtversion))) (define (rmt:set-process-done host pid reason) (rmt:send-receive 'set-process-done #f (list host pid reason))) (define (rmt:set-process-status host pid newstatus) (rmt:send-receive 'set-process-status #f (list host pid newstatus))) (define (rmt:get-process-options purpose dbname) (rmt:get-process-options 'get-process-options #f (list purpose dbname))) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== (define (rmt:archive-get-allocations testname itempath dneeded) (rmt:send-receive 'archive-get-allocations #f (list testname itempath dneeded))) |
︙ |
Modified tcp-transportmod.scm from [c1e45ba013] to [a1fcad65c5].
︙ | |||
480 481 482 483 484 485 486 | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 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 | + + + + + + + + + + + + + + + + + + + - - - + + + + + + + + + + | (tt:start-tcp-server ttdat)) ;; start the tcp-server which applies handler to incoming data "tcp-server-thread")) (run-thread (make-thread (lambda () (tt:keep-running ttdat dbfname dbstruct))))) (thread-start! tcp-thread) (thread-start! run-thread) (let* ((areapath (tt-areapath ttdat)) (nosyncdbpath (conc areapath"/.mtdb"))) ;; this didn't seem to work, is port not available yet? (let loop ((count 0)) (if (tt-port ttdat) (begin (procinf-port-set! *procinf* (tt-port ttdat)) (procinf-dbname-set! *procinf* dbfname) (dbfile:with-no-sync-db nosyncdbpath (lambda (nsdb) (dbfile:insert-or-update-process nsdb *procinf*)))) (if (< count 5) (begin (thread-sleep! 0.5) (loop (+ count 1))) (debug:print 0 *default-log-port* "ERROR: (tt-port ttdat) no port set!")))) |
︙ |