Overview
Comment: | Added db copying to /tmp every 5 seconds and opening xterm from dashboard in a read-only area |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.70 |
Files: | files | file ages | folders |
SHA1: |
37f73fe14d8874c9052c43c3f2b37aa5 |
User & Date: | mmgraham on 2022-08-19 17:11:53 |
Other Links: | branch diff | manifest | tags |
Context
2022-08-19
| ||
20:37 | better handling of read-only files and directories in cautious-open-database check-in: 7d8861598e user: mmgraham tags: v1.70 | |
17:11 | Added db copying to /tmp every 5 seconds and opening xterm from dashboard in a read-only area check-in: 37f73fe14d user: mmgraham tags: v1.70 | |
2022-08-17
| ||
19:02 | changed dashboard to use -target for target/run. Changed db:cautious-open to handle read-only check-in: a7b0d6ce43 user: mmgraham tags: v1.70, breaks-dashboard-for-wal-db | |
Changes
Modified common.scm from [a75c0e329c] to [8329a06561].
︙ | ︙ | |||
903 904 905 906 907 908 909 910 911 912 913 914 915 916 | thepath (if (equal? thepath "/") (begin (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.") #f) (loop (pathname-directory thepath))))) )) ;;====================================================================== ;; redefine for future cleanup (converge on area-name, the more generic ;; (define common:get-area-name common:get-testsuite-name) (define (common:get-db-tmp-area . junk) | > > > > > > > > > > > > | 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 | thepath (if (equal? thepath "/") (begin (debug:print-error 0 *default-log-port* "Unable to find megatest home directory.") #f) (loop (pathname-directory thepath))))) )) (define (common:db-tmp-area-path) (conc "/tmp/" (current-user-name) "/megatest_localdb/" (common:get-testsuite-name) "/" (string-translate *toppath* "/" ".") ) ) ;;====================================================================== ;; redefine for future cleanup (converge on area-name, the more generic ;; (define common:get-area-name common:get-testsuite-name) (define (common:get-db-tmp-area . junk) |
︙ | ︙ |
Modified dashboard.scm from [41537b7251] to [a62e9ad174].
︙ | ︙ | |||
202 203 204 205 206 207 208 209 210 211 212 213 214 215 | (dboard:commondat-tabdats commondat) tabnum tabdat)) ;; gets and calls updater list based on curr-tab-num ;; (define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) (for-each ;; perform the function calls for the complete updaters list | > | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 | (dboard:commondat-tabdats commondat) tabnum tabdat)) ;; gets and calls updater list based on curr-tab-num ;; (define (dboard:common-run-curr-updaters commondat #!key (tab-num #f)) (copy-db-to-tmp) (if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat (let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat))) (updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '()))) (debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum) (for-each ;; perform the function calls for the complete updaters list |
︙ | ︙ | |||
3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 | (print "Starting main loop") (thread-start! th2) (thread-join! th2) ) ) ) ) ;; ########################### top level code ######################## ;; check for MT_* environment variables and exit if found (if (not (args:get-arg "-test")) (begin (for-each (lambda (var) ;; (display " ")(display var) | > > > > > > > > > > > > > > > > | 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 | (print "Starting main loop") (thread-start! th2) (thread-join! th2) ) ) ) ) (define last-copy-time 0) ;; Do this only if in read-only mode. (define (copy-db-to-tmp) (let* ((db-file "./.megatest/main.db")) (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5))) (begin (system (conc "rsync -a .megatest " (common:get-db-tmp-area))) (set! last-copy-time (current-seconds)) ) ) ) ) ;; ########################### top level code ######################## ;; check for MT_* environment variables and exit if found (if (not (args:get-arg "-test")) (begin (for-each (lambda (var) ;; (display " ")(display var) |
︙ | ︙ |
Modified dbfile.scm from [d826bed1b3] to [ae8c9cbdb4].
︙ | ︙ | |||
501 502 503 504 505 506 507 | (let* ((db-exists (file-exists? fname)) (db (sqlite3:open-database fname))) (if (and init-proc (not db-exists)) (init-proc db)) db))) (if (file-exists? fname ) (sqlite3:open-database fname) | < | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 | (let* ((db-exists (file-exists? fname)) (db (sqlite3:open-database fname))) (if (and init-proc (not db-exists)) (init-proc db)) db))) (if (file-exists? fname ) (sqlite3:open-database 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.") |
︙ | ︙ |
Modified dcommon.scm from [dbcf309f44] to [9acb2d697e].
︙ | ︙ | |||
526 527 528 529 530 531 532 | ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (print "Command =" command) (common:without-vars command "MT_.*")) (message-window (conc "Directory " rundir " not found")))))) (xterm) | < > > > > | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 | ";mt_xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (print "Command =" command) (common:without-vars command "MT_.*")) (message-window (conc "Directory " rundir " not found")))))) (xterm) ) ) ) ) ;;====================================================================== ;; D A T A T A B L E S ;;====================================================================== ;; Table of keys (define (dcommon:keys-matrix rawconfig) |
︙ | ︙ |
Modified launch.scm from [0d3f22327e] to [c3fcd3bfc9].
︙ | ︙ | |||
1448 1449 1450 1451 1452 1453 1454 | ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)))))) (item-path (item-list->path itemdat)) (contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour"))) (let loop ((delta (- (current-seconds) *last-launch*)) (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0))) (if (> launch-delay delta) (begin | | | | 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 | ;; (loop (rmt:no-sync-get-lock lock-key) expire-time)))))) (item-path (item-list->path itemdat)) (contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour"))) (let loop ((delta (- (current-seconds) *last-launch*)) (launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 0))) (if (> launch-delay delta) (begin ;; (if (common:low-noise-print 1200 "test launch delay") ;; every two hours or so remind the user about launch delay. ;; (debug:print-info 0 *default-log-port* "NOTE: test launches are delayed by " launch-delay " seconds. See megatest.config launch-delay setting to adjust.")) ;; launch of " test-name " for " (- launch-delay delta) " seconds")) (thread-sleep! (- launch-delay delta)) (loop (- (current-seconds) *last-launch*) launch-delay)))) (change-directory *toppath*) (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars) (append (list (list "MT_RUN_AREA_HOME" *toppath*) |
︙ | ︙ |
Modified utils/mt_xterm from [868b69899e] to [5e40a3e5f1].
︙ | ︙ | |||
14 15 16 17 18 19 20 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # 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/>. MT_TMPDISPLAY=$DISPLAY | > > > > > > > > > | | | > > | 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 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # 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/>. MT_TMPDISPLAY=$DISPLAY MT_TMPUSER=$USER MT_HOME=$HOME tmpfile=`mktemp` grep -v "export USER=" megatest.sh | grep -v "export HOME=" > $tmpfile source $tmpfile rm $tmpfile # if [ -e megatest.sh ];then #source megatest.sh #fi export DISPLAY=$MT_TMPDISPLAY export USER=$USER export HOME=$MT_HOME if [ x"$MT_XTERM_CMD" == "x" ];then exec xterm "$@" else exec $MT_XTERM_CMD fi |