Comment: | More ported to inmem |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
662f6304a0fefe071eb567c1705d6ac9 |
User & Date: | matt on 2013-11-12 21:12:06 |
Other Links: | manifest | tags |
2013-11-12
| ||
21:49 | More adjustments to inmem check-in: 7c12fbc39a user: matt tags: trunk | |
21:12 | More ported to inmem check-in: 662f6304a0 user: matt tags: trunk | |
14:13 | Tweaks check-in: 993f84005f user: mrwellan tags: trunk | |
Modified api.scm from [a1062addd1] to [41b5b06e44].
︙ | ︙ | |||
32 33 34 35 36 37 38 | ((delete-test-records) (apply db:delete-test-records db params)) ((delete-old-deleted-test-records) (db:delete-old-deleted-test-records db)) ((test-set-status-state) (apply db:test-set-status-state db params)) ((get-previous-test-run-record) (apply db:get-previous-test-run-record db params)) ((get-matching-previous-test-run-records)(map vector->list (apply db:get-matching-previous-test-run-records db params))) ((db:test-get-logfile-info) (apply db:test-get-logfile-info db params)) ((test-get-records-for-index-file (apply db:test-get-records-for-index-file db params))) | | > > > > | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | ((delete-test-records) (apply db:delete-test-records db params)) ((delete-old-deleted-test-records) (db:delete-old-deleted-test-records db)) ((test-set-status-state) (apply db:test-set-status-state db params)) ((get-previous-test-run-record) (apply db:get-previous-test-run-record db params)) ((get-matching-previous-test-run-records)(map vector->list (apply db:get-matching-previous-test-run-records db params))) ((db:test-get-logfile-info) (apply db:test-get-logfile-info db params)) ((test-get-records-for-index-file (apply db:test-get-records-for-index-file db params))) ((get-testinfo-state-status) (let ((res (apply db:get-testinfo-state-status db params))) (if (vector? res) (vector->list res) res))) ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new db params)) ((get-prereqs-not-met) (let ((res (apply db:get-prereqs-not-met db params))) (map (lambda (x) (if (vector? x) (vector->list x) x)) res))) ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts db params)) ;; RUNS ((get-run-info) (let ((res (apply db:get-run-info db params))) (list (vector-ref res 0) (vector->list (vector-ref res 1))))) ((register-run) (apply db:register-run db params)) |
︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 | ((update-run-event_time) (apply db:update-run-event_time db params)) ;; MISC ((login) (apply db:login db params)) ((general-call) (let ((stmtname (car params)) (realparams (cdr params))) (db:general-call db stmtname realparams))) ((kill-server) (db:sync-to *inmemdb* *db*) (let ((hostname (car *runremote*)) (port (cadr *runremote*)) (pid (if (null? params) #f (car params))) (th1 (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread"))) (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!") | > | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | ((update-run-event_time) (apply db:update-run-event_time db params)) ;; MISC ((login) (apply db:login db params)) ((general-call) (let ((stmtname (car params)) (realparams (cdr params))) (db:general-call db stmtname realparams))) ((sync-inmem->db) (db:sync-back)) ((kill-server) (db:sync-to *inmemdb* *db*) (let ((hostname (car *runremote*)) (port (cadr *runremote*)) (pid (if (null? params) #f (car params))) (th1 (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread"))) (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!") |
︙ | ︙ |
Modified dashboard-tests.scm from [972ae80d2f] to [d29ac1e9dd].
︙ | ︙ | |||
312 313 314 315 316 317 318 | ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) (let ((record (hash-table-ref/default res | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 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 | ;; organise the steps for better readability (let ((res (make-hash-table))) (for-each (lambda (step) (debug:print 6 "step=" step) (let ((record (hash-table-ref/default res (tdb:step-get-stepname step) ;; stepname start end status Duration Logfile (vector (tdb:step-get-stepname step) "" "" "" "" "")))) (debug:print 6 "record(before) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) (case (string->symbol (tdb:step-get-state step)) ((start)(vector-set! record 1 (tdb:step-get-event_time step)) (vector-set! record 3 (if (equal? (vector-ref record 3) "") (tdb:step-get-status step))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step)))) ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) (endt (any->number (vector-ref record 2)))) (debug:print 4 "record[1]=" (vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step)))) (else (vector-set! record 2 (tdb:step-get-state step)) (vector-set! record 3 (tdb:step-get-status step)) (vector-set! record 4 (tdb:step-get-event_time step)))) (hash-table-set! res (tdb:step-get-stepname step) record) (debug:print 6 "record(after) = " record "\nid: " (tdb:step-get-id step) "\nstepname: " (tdb:step-get-stepname step) "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)))) ;; (else (vector-set! record 1 (tdb:step-get-event_time step))) (sort steps (lambda (a b) (cond ((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t) ((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b)) (< (tdb:step-get-id a) (tdb:step-get-id b))) (else #f))))) res)) (define (dashboard-tests:get-compressed-steps test-id #!key (work-area #f)) (if (or (not work-area) (file-exists? (conc work-area "/testdat.db"))) (let* ((steps-data (tdb:get-steps-for-test test-id work-area)) |
︙ | ︙ |
Modified dashboard.scm from [b4efde3b5b] to [b8686db61f].
︙ | ︙ | |||
1426 1427 1428 1429 1430 1431 1432 | (define (dashboard:recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) (> modtime last-db-update-time) (> (current-seconds)(+ last-db-update-time 1))))) | | | 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 | (define (dashboard:recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) (> modtime last-db-update-time) (> (current-seconds)(+ last-db-update-time 1))))) (define *monitor-db-path* (conc *toppath* "/db/monitor.db")) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. (let ((db (tasks:open-db))) (sqlite3:finalize! db)) (define (dashboard:run-update x) |
︙ | ︙ |
Modified db.scm from [5380b387e8] to [32892c2413].
︙ | ︙ | |||
70 71 72 73 74 75 76 | (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") (exit)))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) | < > | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: Attempted to open db when not in megatest area. Exiting.") (exit)))) (let* ((dbpath (conc *toppath* "/megatest.db")) ;; fname) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) ;; (never-give-up-open-db dbpath)) (write-access (file-write-access? dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) ;; 136000 = 2.2 minutes (if (and dbexists (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (debug:print-info 11 "open-db, dbpath=" dbpath " argv=" (argv)) |
︙ | ︙ | |||
94 95 96 97 98 99 100 | (let* ((path (configf:lookup *configdat* "setup" "tmpdb")) (fname (if path (conc path "/temp-megatest.db") #f)) (exists (and path (file-exists? fname))) (db (if path (begin (create-directory path #t) (sqlite3:open-database fname)) | | > > > | > | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | (let* ((path (configf:lookup *configdat* "setup" "tmpdb")) (fname (if path (conc path "/temp-megatest.db") #f)) (exists (and path (file-exists? fname))) (db (if path (begin (create-directory path #t) (sqlite3:open-database fname)) (sqlite3:open-database ":memory:"))) (handler (make-busy-timeout 3600))) (if (or (not path) (not exists)) (db:initialize db)) (sqlite3:set-busy-handler! db handler) db)) (define (db:sync-to fromdb todb) ;; strategy ;; 1. Get all run-ids ;; 2. For each run-id ;; a. Sync that run in a transaction |
︙ | ︙ | |||
1167 1168 1169 1170 1171 1172 1173 | (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) db qry ) res)) | | < < < < | < < < < < < | | 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 | (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) db qry ) res)) (define (db:delete-test-records db test-id) (tdb:delete-test-step-records db test-id) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id)) (define (db:delete-tests-for-run db run-id) (sqlite3:execute db "DELETE FROM tests WHERE run_id=?;" run-id)) (define (db:delete-old-deleted-test-records db) (let ((targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime))) |
︙ | ︙ | |||
1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 | ;; (define (cdb:remote-run proc db . params) ;; (if (or *db-write-access* ;; (not (member proc *db:all-write-procs*))) ;; (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params) ;; (begin ;; (debug:print 0 "ERROR: Attempt to access read-only database") ;; #f))) (define (db:test-get-logfile-info db run-id test-name) (let ((res #f)) (sqlite3:for-each-row (lambda (path final_logf) (set! logf final_logf) (set! res (list path final_logf)) | > > > > > > > > > > > | 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 | ;; (define (cdb:remote-run proc db . params) ;; (if (or *db-write-access* ;; (not (member proc *db:all-write-procs*))) ;; (apply cdb:client-call *runremote* 'immediate #f *default-numtries* open-run-close proc #f params) ;; (begin ;; (debug:print 0 "ERROR: Attempt to access read-only database") ;; #f))) (define (rmt:roll-up-pass-fail-counts run-id test-name item-path status) (if (and (not (equal? item-path "")) (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP"))) (begin (db:general-call 'update-pass-fail-counts db (list run-id test-name run-id test-name)) (if (equal? status "RUNNING") (db:general-call 'top-test-set-running db (list run-id test-name)) (db:general-call 'top-test-set-per-pf-counts db (list run-id test-name run-id test-name))) #f) #f)) (define (db:test-get-logfile-info db run-id test-name) (let ((res #f)) (sqlite3:for-each-row (lambda (path final_logf) (set! logf final_logf) (set! res (list path final_logf)) |
︙ | ︙ | |||
1885 1886 1887 1888 1889 1890 1891 | (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) ;; for each run starting with the most recent look to see if there is a matching test ;; if found then return that matching test record (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) | | | 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 | (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) ;; for each run starting with the most recent look to see if there is a matching test ;; if found then return that matching test record (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) #f (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results) (if (and (null? results) (not (null? tal))) (loop (car tal)(cdr tal)) (if (null? results) #f (car results)))))))))) |
︙ | ︙ | |||
1926 1927 1928 1929 1930 1931 1932 | ;; collect all matching tests for the runs then ;; extract the most recent test and return that. (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) | | | 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 | ;; collect all matching tests for the runs then ;; extract the most recent test and return that. (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids) (if (null? prev-run-ids) '() ;; no previous runs? return null (let loop ((hed (car prev-run-ids)) (tal (cdr prev-run-ids))) (let ((results (db:get-tests-for-run db hed (conc test-name "/" item-path) '() '() #f #f #f #f #f #f))) (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path " results: " (intersperse results "\n")) ;; Keep only the youngest of any test/item combination (for-each (lambda (testdat) (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat))) (stored-test (hash-table-ref/default tests-hash full-testname #f))) |
︙ | ︙ |
Modified ezsteps.scm from [5bdb7484d4] to [a48b4294d3].
︙ | ︙ | |||
96 97 98 99 100 101 102 | (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: test-run-dir)) (if logpro-used | | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) ;; testing if procedures called in a remote call cause problems (ans: no or so I suspect) (db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna work-area: test-run-dir)) (if logpro-used (rmt:test-set-log! test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) (overall-status (cond ((eq? rollup-status 2) 'warn) |
︙ | ︙ |
Modified http-transport.scm from [1dff27fc16] to [a6b93a7de2].
whitespace changes only
Modified launch.scm from [3c59fa35f3] to [f885a90fba].
︙ | ︙ | |||
144 145 146 147 148 149 150 | (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info | | | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 | (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info (tests:set-full-meta-info test-id run-id 0 work-area) ;; (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f) (tests:test-force-state-status! test-id "REMOTEHOSTSTART" "n/a") (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") |
︙ | ︙ |
Modified megatest.scm from [85bb5af86b] to [aeda34eef4].
︙ | ︙ | |||
901 902 903 904 905 906 907 | ;; (set! *transport-type* (string->symbol transport)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) ;; DO NOT remote run, makes calls to the testdat.db test db. | | | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 | ;; (set! *transport-type* (string->symbol transport)) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) ;; DO NOT remote run, makes calls to the testdat.db test db. (tdb:teststep-set-status! test-id step state status msg logfile work-area: work-area) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -step") (exit 6)))))) (if (args:get-arg "-step") (begin (megatest:step |
︙ | ︙ | |||
960 961 962 963 964 965 966 | (change-directory work-area) ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close | | | | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 | (change-directory work-area) ;; can setup as client for server mode now ;; (client:setup) (if (args:get-arg "-load-test-data") ;; has sub commands that are rdb: ;; DO NOT put this one into either cdb:remote-run or open-run-close (tdb:load-test-data test-id work-area: work-area)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) (rmt:test-set-log! test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote (tests:test-set-toplog! db run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") ;; DO NOT run remote (tests:summarize-items db run-id test-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") |
︙ | ︙ | |||
992 993 994 995 996 997 998 | ((zsh bash sh ash) "2>&1 >") (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test ;; DO NOT run remote | | | | | 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 | ((zsh bash sh ash) "2>&1 >") (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test ;; DO NOT run remote (tdb:teststep-set-status! test-id stepname "start" "n/a" (args:get-arg "-m") logfile work-area: work-area) ;; run the test step (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir) (change-directory startingdir) (set! exitstat (system fullcmd)) ;; cmd params)) (set! *globalexitstatus* exitstat) ;; (change-directory testpath) ;; run logpro if applicable ;; (process-run "ls" (list "/foo" "2>&1" "blah.log")) (if logprofile (let* ((htmllogfile (conc stepname ".html")) (oldexitstat exitstat) (cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " "))) (debug:print-info 2 "running \"" cmd "\"") (change-directory startingdir) (set! exitstat (system cmd)) (set! *globalexitstatus* exitstat) ;; no necessary (change-directory testpath) (rmt:test-set-log! test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) ;; DO NOT run remote (tdb:teststep-set-status! test-id stepname "end" exitstat msg logfile work-area: work-area)) ))) (if (or (args:get-arg "-test-status") (args:get-arg "-set-values")) (let ((newstatus (cond ((number? status) (if (equal? status 0) "PASS" "FAIL")) ((and (string? status) (string->number status))(if (equal? (string->number status) 0) "PASS" "FAIL")) |
︙ | ︙ |
Modified rmt.scm from [277a7a3b51] to [00b9d433cf].
︙ | ︙ | |||
72 73 74 75 76 77 78 79 80 81 82 83 84 85 | (define (rmt:kill-server) (rmt:send-receive 'kill-server '())) ;; hand off a call to one of the db:queries statements (define (rmt:general-call stmtname . params) (rmt:send-receive 'general-call (append (list stmtname) params))) ;;====================================================================== ;; K E Y S ;;====================================================================== (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs (list run-id))) | > > > | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | (define (rmt:kill-server) (rmt:send-receive 'kill-server '())) ;; hand off a call to one of the db:queries statements (define (rmt:general-call stmtname . params) (rmt:send-receive 'general-call (append (list stmtname) params))) (define (rmt:sync-inmem->db) (rmt:send-receive 'sync-inmem->db '())) ;;====================================================================== ;; K E Y S ;;====================================================================== (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs (list run-id))) |
︙ | ︙ | |||
132 133 134 135 136 137 138 | (define (rmt:get-previous-test-run-record run-id test-name item-path) (rmt:send-receive 'get-previous-test-run-record (list run-id test-name item-path))) (define (rmt:get-matching-previous-test-run-records run-id test-name item-path) (map list->vector (rmt:send-receive 'get-matching-previous-test-run-records (list run-id test-name item-path)))) | | | > > > | 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 | (define (rmt:get-previous-test-run-record run-id test-name item-path) (rmt:send-receive 'get-previous-test-run-record (list run-id test-name item-path))) (define (rmt:get-matching-previous-test-run-records run-id test-name item-path) (map list->vector (rmt:send-receive 'get-matching-previous-test-run-records (list run-id test-name item-path)))) (define (rmt:test-get-logfile-info run-id test-name) (rmt:send-receive 'test-get-logfile-info (list run-id test-name))) (define (rmt:test-get-records-for-index-file run-id test-name) (rmt:send-receive 'test-get-records-for-index-file (list run-id test-name))) (define (rmt:get-testinfo-state-status test-id) (let ((res (rmt:send-receive 'get-testinfo-state-status (list test-id)))) (if (list? res) (list->vector res) res))) (define (rmt:test-set-log! test-id logf) (if (string? logf)(rmt:general-call 'test-set-log logf test-id))) (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (rmt:send-receive 'test-get-paths-matching-keynames-target-new (list keynames target res testpatt statepatt statuspatt runname))) |
︙ | ︙ |
Modified tasks.scm from [9517782d04] to [c9fadd13bc].
︙ | ︙ | |||
424 425 426 427 428 429 430 | (sqlite3:execute mdb (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");"))) ;; (define (tasks:start-monitor db mdb) (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more (debug:print-info 1 "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) | | | 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 | (sqlite3:execute mdb (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");"))) ;; (define (tasks:start-monitor db mdb) (if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more (debug:print-info 1 "Not starting monitor, already have more than two running") (let* ((megatestdb (conc *toppath* "/megatest.db")) (monitordbf (conc *toppath* "/db/monitor.db")) (last-db-update 0)) ;; (file-modification-time megatestdb))) (task:register-monitor mdb) (let loop ((count 0) (next-touch 0)) ;; next-touch is the time where we need to update last_update ;; if the db has been modified we'd best look at the task queue (let ((modtime (file-modification-time megatestdbpath ))) (if (> modtime last-db-update) |
︙ | ︙ |
Modified tests/Makefile from [e01d7d9755] to [ad942b6696].
1 2 3 4 5 6 7 8 9 10 11 12 | # # run some tests BINPATH=$(shell readlink -m $(PWD)/../bin) MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) RUNNAME := $(shell date +w%V.%u.%H.%M) IPADDR := "-" # Set SERVER to "-server -" SERVER = DEBUG = 1 LOGGING = | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # # run some tests BINPATH=$(shell readlink -m $(PWD)/../bin) MEGATEST=$(BINPATH)/megatest DASHBOARD=$(BINPATH)/dashboard PATH := $(BINPATH):$(PATH) RUNNAME := $(shell date +w%V.%u.%H.%M) IPADDR := "-" # Set SERVER to "-server -" SERVER = DEBUG = 1 LOGGING = |
︙ | ︙ | |||
104 105 106 107 108 109 110 | # Some simple checks for bootstrapping and run loop logic test9 : minsetup test9a test9b test9c test9d test9e test9a : @echo Run super-simple mintest e, no waitons. | | | | | | | | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 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 | # Some simple checks for bootstrapping and run loop logic test9 : minsetup test9a test9b test9c test9d test9e test9a : @echo Run super-simple mintest e, no waitons. cd mintest;$(MEGATEST) -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9b : @echo Run simple mintest d with one waiton c cd mintest;$(MEGATEST) -runtests d -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9c : @echo Run mintest a with full waiton chain a -> b -> c -> d -> e cd mintest;$(MEGATEST) -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9d : @echo Run an itemized test with no items cd mintest;$(MEGATEST) -runtests g -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9e : @echo Run mintest a1 with full waiton chain with d1fail: a1 -> b1 -> c1 -> d1fail -> e1 cd mintest;$(MEGATEST) -runtests a1 -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test10 : @echo Run a bunch of different targets simultaneously (cd fullrun;$(MEGATEST) -server - ;sleep 2)& for targ in mint/btrfs/mintdir sunos/sshfs/loc; do \ (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$targ :runname $(RUNNAME) &); done for sys in ubuntu suse redhat debian;do \ for fs in afs nfs zfs; do \ for dpath in none tmp; do \ (cd fullrun;$(MEGATEST) -runtests priority_10_waiton_1 -target $$sys/$$fs/$$dpath :runname $(RUNNAME) &);\ done;done;done test11 : cd fullrun;time (for a in 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 1 2 3 4 5 6 7 8 9 10 ;do (megatest -test-paths -target %/%/% > /dev/null ) & done; wait; ) minsetup : cd ..;make && make install mkdir -p mintest/runs mintest/links cd mintest;$(MEGATEST) -stop-server 0 cd mintest;$(MEGATEST) -server - -debug $(DEBUG) > server.log 2> server.log & sleep 3 cd mintest;$(DASHBOARD) -rows 18 & cleanprep : ../*.scm Makefile */*.config mkdir -p fullrun/tmp/mt_runs fullrun/tmp/mt_links cd ..;make;make install rm -f */logging.db touch cleanprep |
︙ | ︙ | |||
168 169 170 171 172 173 174 | cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath % clean : rm cleanprep kill : killall -v mtest main.sh dboard || true | | | | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 | cd fullrun;$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath % clean : rm cleanprep kill : killall -v mtest main.sh dboard || true rm -rf */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* || true killall -v mtest dboard || true hardkill : kill sleep 2;killall -v mtest main.sh dboard -9 listservers : cd fullrun;$(MEGATEST) -list-servers runforever : while(ls); do runname=`date +%F-%R:%S`;(cd fullrun;$(MEGATEST) -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname);done |
Modified tests/mintest/megatest.config from [24752ab48d] to [158955d103].
1 2 3 4 5 6 7 8 9 10 11 12 13 | [fields] X TEXT [setup] max_concurrent_jobs 50 linktree #{getenv PWD}/linktree [server] port 8090 [jobtools] useshell yes launcher nbfind | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | [fields] X TEXT [setup] max_concurrent_jobs 50 linktree #{getenv PWD}/linktree transport http [server] port 8090 [jobtools] useshell yes launcher nbfind |
︙ | ︙ |
Modified tests/rununittest.sh from [4e5a87c2e6] to [45ac8d74ef].
1 2 3 4 5 6 7 | #!/bin/bash # Usage: rununittest.sh testname debuglevel # # Clean setup # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | #!/bin/bash # Usage: rununittest.sh testname debuglevel # # Clean setup # rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db rm -rf simplelinks/ simpleruns/ mkdir -p simplelinks simpleruns (cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) # Run the test $1 is the unit test to run cd simplerun;echo '(load "../tests.scm")' | ../../bin/megatest -repl -debug $2 $1 |
Added tests/unittests/inmemdb.scm version [89b5b8b964].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 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 | ;;====================================================================== ;; S E R V E R ;;====================================================================== ;; Run like this: ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (set! *transport-type* 'http) (system "cp ../fullrun/megatest.db megatest.db") (test "open inmem db" 1 (begin (open-in-mem-db) 1)) (test "setup for run" #t (begin (setup-for-run) (string? (getenv "MT_RUN_AREA_HOME")))) (system "megatest -server - -debug 0 &") (thread-sleep! 3) ;; need to wait for server to start. Yes, a better way is needed. (define *keys* (keys:config-get-fields *configdat*)) (define *keyvals* (keys:target->keyval *keys* "a/b/c")) (test #f #t (string? (car *runremote*))) (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) (define inmem (open-in-mem-db)) (define (inmem-test t b) (test "inmem sync to" t (db:sync-to *db* inmem)) (test "inmem sync back" b (db:sync-to inmem *db*))) (inmem-test 0 0) (inmem-test 1 1) ;;====================================================================== ;; D B ;;====================================================================== (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) |
Modified tests/unittests/server.scm from [2057de46b9] to [4b5ecf2866].
1 2 3 4 5 6 7 8 9 10 | ;;====================================================================== ;; S E R V E R ;;====================================================================== ;; Run like this: ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (set! *transport-type* 'http) | < < | > | > > > > > > < < < < < < < | < < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 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 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | ;;====================================================================== ;; S E R V E R ;;====================================================================== ;; Run like this: ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (set! *transport-type* 'http) (test "setup for run" #t (begin (setup-for-run) (string? (getenv "MT_RUN_AREA_HOME")))) (test "server-register, get-best-server" #t (let ((res #f)) (open-run-close tasks:server-register tasks:open-db 1 "bob" 1234 100 'live 'http) (set! res (open-run-close tasks:get-best-server tasks:open-db)) (number? (vector-ref res 3)))) (test "de-register server" #f (let ((res #f)) (open-run-close tasks:server-deregister tasks:open-db "bob" port: 1234) (vector? (open-run-close tasks:get-best-server tasks:open-db)))) (define server-pid #f) ;; Not sure how the following should work, replacing it with system of megatest -server ;; (test "launch server" #t (let ((pid (process-fork (lambda () ;; ;; (daemon:ize) ;; (server:launch 'http))))) ;; (set! server-pid pid) ;; (number? pid))) (system "../../bin/megatest -server - -debug 22 > server.log 2> server.log &") (let loop ((n 10)) (thread-sleep! 1) ;; need to wait for server to start. (let ((res (open-run-close tasks:get-best-server tasks:open-db))) (print "tasks:get-best-server returned " res) (if (and (not res) (> n 0)) (loop (- n 1))))) (test "get-best-server" #t (begin (client:launch) (let ((dat (open-run-close tasks:get-best-server tasks:open-db))) (vector? dat)))) (define *keys* (keys:config-get-fields *configdat*)) (define *keyvals* (keys:target->keyval *keys* "a/b/c")) (test #f #t (string? (car *runremote*))) (test #f '(#t "successful login") (rmt:login)) ;; *runremote* *toppath* *my-client-signature*))) (test #f #f (rmt:get-test-info-by-id 99)) ;; get non-existant test ;; RUNS (test #f 1 (rmt:register-run *keyvals* "firstrun" "new" "n/a" (current-user-name))) (test "get run info" "firstrun" (let ((rinfo (rmt:get-run-info 1))) (vector-ref (vector-ref rinfo 1) 3))) (test "get runname from id" "firstrun" (rmt:get-run-name-from-id 1)) ;; TESTS (test "get tests (no data)" '() (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f)) (test "register test" #t (rmt:general-call 'register-test 1 "test1" "")) (test "get tests (some data)" 1 (length (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f))) (test "get test id" 1 (rmt:get-test-id 1 "test1" "")) (test "sync back" #t (> (rmt:sync-inmem->db) 0)) (test "get test id from main" 1 (db:get-test-id *db* 1 "test1" "")) (test "get keys" #t (list? (rmt:get-keys))) (test "set comment" #t (begin (rmt:general-call 'set-test-comment "this is a comment" 1) #t)) (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1))) (db:test-get-comment trec))) ;; MORE RUNS (test "get runs" #t (let* ((runs (rmt:get-runs "%" #f #f '())) (header (vector-ref runs 0)) (data (vector-ref runs 1))) (and (list? header) (list? data) (vector? (car data))))) (test "get local testinfo" "test1" (vector-ref (db:get-testinfo-state-status *db* 1) 2)) (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1) 2)) ;;====================================================================== ;; D B ;;====================================================================== (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) |