Changes In Branch v1.63 Through [f38d05a68d] Excluding Merge-Ins
This is equivalent to a diff from bff9d56983 to f38d05a68d
2018-04-18
| ||
00:21 | No idea what this was. Commiting just in case it is interesting ... Leaf check-in: 33160354bc user: matt tags: dunno | |
2017-01-04
| ||
16:49 | Use item-specific testconfig caches when possible (i.e. where there is enough information available). check-in: f98ca94491 user: mrwellan tags: v1.63 | |
12:10 | updated manyservers.sh to be runnable with other instances of itself on same host check-in: f38d05a68d user: bjbarcla tags: v1.63 | |
2017-01-03
| ||
15:02 | Fixed couple calls to start servers which were receiving the old run-id parameter instead of the needed toppath check-in: d66cd9561f user: mrwellan tags: v1.63 | |
2016-12-05
| ||
13:11 | Bumped version to v1.6301 check-in: fbf0a07a1d user: mrwellan tags: v1.63, v1.6301 | |
12:58 | Protected calls to expensive ping with calls to cheap server:read-dotserver. This appears to 100% the run-away pings problem Closed-Leaf check-in: bff9d56983 user: mrwellan tags: v1.62-no-rpc | |
11:05 | Correct expiration of server connections check-in: b168adb943 user: mrwellan tags: v1.62-no-rpc | |
Modified Makefile from [1b85fc3382] to [629c3de1dd].
︙ | |||
129 130 131 132 133 134 135 136 137 138 139 140 141 142 | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 | + + + + | $(PREFIX)/bin/mt_xterm : utils/mt_xterm $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/nbfake : utils/nbfake $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/remrun : utils/remrun $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/viewscreen : utils/viewscreen $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/nbfind : utils/nbfind $(INSTALL) $< $@ |
︙ | |||
157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 | + + + + + - + + | deploytarg/viewscreen : utils/viewscreen $(INSTALL) $< $@ chmod a+x $@ deploytarg/nbfind : utils/nbfind $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/mtest-reaper: helpers/mtest-reaper.scm helpers/ducttape-lib.scm helpers/inteldate.scm helpers/mimetypes.scm make -C helpers $@ PREFIX=$(PREFIX) INSTALL=$(INSTALL) ARCHSTR=$(ARCHSTR) mtest-reaper: $(PREFIX)/bin/mtest-reaper # install dashboard as dboard so wrapper script can be called dashboard $(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ |
︙ | |||
209 210 211 212 213 214 215 | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 | - + | # for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \ # chicken-install -prefix deploytarg -deploy $$i;done # deploytarg/libsqlite3.so : # CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3 |
︙ | |||
276 277 278 279 280 281 282 | 286 287 288 289 290 291 292 293 | + | fi if csi -ne '(use postgresql)';then \ echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o daemon.o dashboard-tests.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o |
Modified NOTES from [fdf26c3763] to [24a602c385].
|
Modified api.scm from [fe7a2f21be] to [1debddd502].
︙ | |||
37 38 39 40 41 42 43 44 45 46 47 48 49 50 | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | + | get-count-tests-running-for-run-id get-run-info get-run-status get-run-stats get-targets get-target ;; register-run get-tests-tags get-tests-for-run get-test-id get-tests-for-runs-mindata get-run-name-from-id get-runs get-num-runs get-all-run-ids |
︙ | |||
59 60 61 62 63 64 65 66 67 68 69 70 71 72 | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | + + | testmeta-get-record have-incompletes? synchash-get )) (define api:write-queries '( get-keys-write ;; dummy "write" query to force server start ;; SERVERS start-server kill-server ;; TESTS test-set-state-status-by-id delete-test-records |
︙ | |||
109 110 111 112 113 114 115 116 117 118 119 120 121 122 | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | + | ;; ;; - returns #( flag result ) ;; (define (api:execute-requests dbstruct dat) (handle-exceptions exn (let ((call-chain (get-call-chain))) (debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer") (print-call-chain (current-error-port)) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") (vector ;; return a vector + the returned data structure #t |
︙ | |||
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 | + + | ((sync-inmem->db) (let ((run-id (car params))) (db:sync-touched dbstruct run-id force-sync: #t))) ((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) ;; TESTMETA ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) ((get-tests-tags) (db:get-tests-tags dbstruct)) ;; TASKS ((tasks-add) (apply tasks:add dbstruct params)) ((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params)) ((tasks-get-last) (apply tasks:get-last dbstruct 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)) ;;====================================================================== ;; READ ONLY QUERIES ;;====================================================================== ;; KEYS ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) ((get-keys) (db:get-keys dbstruct)) ((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server ((get-key-vals) (apply db:get-key-vals dbstruct params)) ((get-target) (apply db:get-target dbstruct params)) ((get-targets) (db:get-targets dbstruct)) ;; ARCHIVES ((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params)) |
︙ | |||
237 238 239 240 241 242 243 244 245 246 247 248 249 250 | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 | + | ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) ;; TEST DATA ((read-test-data) (apply db:read-test-data dbstruct params)) ;; MISC ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) (run-id (cadr params)) (realparams (cddr params))) (db:with-db dbstruct run-id #t ;; these are all for modifying the db (lambda (db) |
︙ |
Modified client.scm from [50265f350f] to [cbdbeb9ff4].
︙ | |||
195 196 197 198 199 200 201 | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | - + - + | run-id (tasks:hostinfo-get-interface server-dat) (tasks:hostinfo-get-port server-dat) " client:setup (server-dat = #t)") (if (> remaining-tries 8) (thread-sleep! (+ 1 (random 5))) ;; spread out the starts a little (thread-sleep! (+ 15 (random 20)))) ;; it isn't going well. give it plenty of time |
︙ |
Modified common.scm from [a3fcacf886] to [4b29489636].
︙ | |||
88 89 90 91 92 93 94 | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | - - + | ;; db stats (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > (define *db-stats-mutex* (make-mutex)) ;; db access (define *db-last-access* (current-seconds)) ;; last db access, used in server (define *db-write-access* #t) ;; db sync |
︙ | |||
129 130 131 132 133 134 135 | 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 174 175 176 | - + + + + + + + + + + + + + + + + + + - - + + - + | (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here (define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here (define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id (define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db |
︙ | |||
520 521 522 523 524 525 526 | 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 | - - - - - + + + + + + + - + - + + + + + + + - - - + + + + + + - + + - + | (message-digest-string (md5-primitive) *toppath*)) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:run-sync?) |
︙ | |||
588 589 590 591 592 593 594 595 596 597 598 599 | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 | + + - + - + + + - + + + + + + - + + - - - - + + + + + - + + + + + + | (set! last-time start-time) (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (let delay-loop ((count 0)) ;;(BB> "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) (if (and (not *time-to-exit*) (< count 4)) ;; was 11, changing to 4. (begin (thread-sleep! 1) (delay-loop (+ count 1)))) |
︙ | |||
768 769 770 771 772 773 774 | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 | - - + + + + - - - - - - - - + + + + + + + + + + | (define (common:args-get-state) (or (args:get-arg "-state")(args:get-arg ":state"))) (define (common:args-get-status) (or (args:get-arg "-status")(args:get-arg ":status"))) (define (common:args-get-testpatt rconf) |
︙ | |||
1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 | 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | (map (lambda (res) (if (eof-object? res) 9e99 res)) (with-input-from-pipe (conc "ssh " remote-host " cat /proc/loadavg") (lambda ()(list (read)(read)(read))))) (with-input-from-file "/proc/loadavg" (lambda ()(list (read)(read)(read)))))) ;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads ;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc. ;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load ;; (define (common:get-normalized-cpu-load remote-host) (let ((data (if remote-host (with-input-from-pipe (conc "ssh " remote-host " cat /proc/loadavg;cat /proc/cpuinfo;echo end") read-lines) (append (with-input-from-file "/proc/loadavg" read-lines) (with-input-from-file "/proc/cpuinfo" read-lines) (list "end")))) (load-rx (regexp "^([\\d\\.]+)\\s+([\\d\\.]+)\\s+([\\d\\.]+)\\s+.*$")) (proc-rx (regexp "^processor\\s+:\\s+(\\d+)\\s*$")) (core-rx (regexp "^core id\\s+:\\s+(\\d+)\\s*$")) (phys-rx (regexp "^physical id\\s+:\\s+(\\d+)\\s*$")) (max-num (lambda (p n)(max (string->number p) n)))) ;; (print "data=" data) (if (null? data) ;; something went wrong #f (let loop ((hed (car data)) (tal (cdr data)) (loads #f) (proc-num 0) ;; processor includes threads (phys-num 0) ;; physical chip on motherboard (core-num 0)) ;; core ;; (print hed ", " loads ", " proc-num ", " phys-num ", " core-num) (if (null? tal) ;; have all our data, calculate normalized load and return result (let* ((act-proc (+ proc-num 1)) (act-phys (+ phys-num 1)) (act-core (+ core-num 1)) (adj-proc-load (/ (car loads) act-proc)) (adj-core-load (/ (car loads) act-core))) (append (list (cons 'adj-proc-load adj-proc-load) (cons 'adj-core-load adj-core-load)) (list (cons '1m-load (car loads)) (cons '5m-load (cadr loads)) (cons '15m-load (caddr loads))) (list (cons 'proc act-proc) (cons 'core act-core) (cons 'phys act-phys)))) (regex-case hed (load-rx ( x l1 l5 l15 ) (loop (car tal)(cdr tal)(map string->number (list l1 l5 l15)) proc-num phys-num core-num)) (proc-rx ( x p ) (loop (car tal)(cdr tal) loads (max-num p proc-num) phys-num core-num)) (phys-rx ( x p ) (loop (car tal)(cdr tal) loads proc-num (max-num p phys-num) core-num)) (core-rx ( x c ) (loop (car tal)(cdr tal) loads proc-num phys-num (max-num c core-num))) (else (begin ;; (print "NO MATCH: " hed) (loop (car tal)(cdr tal) loads proc-num phys-num core-num))))))))) (define (common:unix-ping hostname) (let ((res (system (conc "ping -c 1 " hostname " > /dev/null")))) (eq? res 0))) ;; ideally put all this info into the db, no need to preserve it across moving homehost ;; ;; return list of ;; ( reachable? cpuload update-time ) (define (common:get-host-info hostname) (let* ((loadinfo (rmt:get-latest-host-load hostname)) (load (car loadinfo)) (load-sample-time (cdr loadinfo)) (load-sample-age (- (current-seconds) load-sample-time)) (loadinfo-timeout-seconds 20) (host-last-update-timeout-seconds 10) (host-rec (hash-table-ref/default *host-loads* hostname #f)) ) (cond ((< load-sample-age loadinfo-timeout-seconds) (list #t load-sample-time load)) ((and host-rec (< (current-seconds) (+ (host-last-update host-rec) host-last-update-timeout-seconds))) (list #t (host-last-update host-rec) (host-last-cpuload host-rec ))) ((common:unix-ping hostname) (list #t (current-seconds) (alist-ref 'adj-core-load (common:get-normalized-cpu-load hostname)))) (else (list #f 0 -1))))) (define (common:update-host-loads-table hosts-raw) (let* ((hosts (filter (lambda (x) (string-match (regexp "^\\S+$") x)) hosts-raw))) (for-each (lambda (hostname) (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f))) (if h h (let ((h (make-host))) (hash-table-set! *host-loads* hostname h) h)))) (host-info (common:get-host-info hostname)) (is-reachable (car host-info)) (last-reached-time (cadr host-info)) (load (caddr host-info))) (host-reachable-set! rec is-reachable) (host-last-update-set! rec last-reached-time) (host-last-cpuload-set! rec load))) hosts))) (define (common:get-least-loaded-host hosts-raw) (let* ((hosts (filter (lambda (x) (string-match (regexp "^\\S+$") x)) hosts-raw)) (best-host #f) (best-load 99999) (curr-time (current-seconds))) (common:update-host-loads-table hosts) (for-each (lambda (hostname) (let* ((rec (let ((h (hash-table-ref/default *host-loads* hostname #f))) (if h h (let ((h (make-host))) (hash-table-set! *host-loads* hostname h) h)))) (reachable (host-reachable rec)) (load (host-last-cpuload rec))) (cond ((not reachable) #f) ((< (+ load (/ (random 250) 1000)) ;; add a random factor to keep from getting in a rut (+ best-load (/ (random 250) 1000)) ) (set! best-load load) (set! best-host hostname))))) hosts) best-host)) (define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f)) (let* ((loadavg (common:get-cpu-load remote-host)) (first (car loadavg)) (next (cadr loadavg)) (adjload (* maxload numcpus)) (loadjmp (- first next))) |
︙ | |||
1573 1574 1575 1576 1577 1578 1579 | 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 | - - - + + + + - - + + + + - - + - - + + + + + + + - + | (query fetch-column (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;")))) ;;====================================================================== ;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S ;;====================================================================== ;; |
︙ |
Modified common_records.scm from [0e6990e6a2] to [e3400966c5].
︙ | |||
119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | 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 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | (lambda () (if *logging* (db:log-event (apply conc params)) (apply print params) ))))) ;; Brandon's debug printer shortcut (indulge me :) (define *BB-process-starttime* (current-milliseconds)) (define (BB> . in-args) (let* ((stack (get-call-chain)) (location #f)) (for-each (lambda (frame) (let* ((this-loc (vector-ref frame 0)) (this-func (cadr (string-split this-loc " ")))) (if (equal? this-func "BB>") (set! location this-loc)))) stack) |
︙ |
Modified configf.scm from [d9393dba52] to [ddff2b4e5d].
︙ | |||
55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | 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 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | + - + - - - - - + + + + + + + + + + + - - + + - + - + - + | (caar cmdres))))) ;;====================================================================== ;; Make the regexp's needed globally available ;;====================================================================== (define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) (define configf:script-rx (regexp "^\\[scriptinc\\s+(.*)\\]\\s*$")) ;; include output from a script (define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) (define configf:blank-l-rx (regexp "^\\s*$")) (define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) (define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) (define configf:comment-rx (regexp "^\\s*#.*")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) (define configf:settings (regexp "^\\[configf:settings\\s+(\\S+)\\s+(\\S+)]\\s*$")) ;; read a line and process any #{ ... } constructs |
︙ | |||
180 181 182 183 184 185 186 | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | + - + - + + + + - + | ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather ;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path) ;; (define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)(settings (make-hash-table))(keep-filenames #f)(post-section-procs '())) (debug:print-info 5 *default-log-port* "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) (debug:print 9 *default-log-port* "START: " path) (if (and (not (port? path)) |
︙ | |||
227 228 229 230 231 232 233 234 235 236 237 238 239 240 | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 | + + + + + + + + + + + + + + + + | (read-config full-conf res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) ;; (pop-directory) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (begin (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") (debug:print 2 *default-log-port* " " full-conf) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))) (configf:script-rx ( x include-script );; handle-exceptions ;; exn ;; (begin ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (if (and (file-exists? include-script)(file-execute-access? include-script)) (let* ((new-inp-port (open-input-pipe include-script))) (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) ;; (print "We got here, calling read-config next. Port is: " new-inp-port) (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) (close-input-port new-inp-port) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (begin (debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))) ) ;; ) (configf:section-rx ( x section-name ) (begin ;; call post-section-procs (for-each (lambda (dat) (let ((patt (car dat)) (proc (cdr dat))) (if (string-match patt curr-section-name) |
︙ |
Modified dashboard.scm from [5d219ac9eb] to [3a1cbbc7df].
︙ | |||
288 289 290 291 292 293 294 295 296 297 298 299 300 301 | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | + + + + + + + + + + + | (runs-summary-source-runname-label #f) (runs-summary-dest-runname-label #f) ;; runs summary view tests-tree ;; used in newdashboard ) ;; register tabdat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:tabdat into a composition of lists that pp will handle (hash-table-set! *BBpp_custom_expanders_list* TABDAT: (cons dboard:tabdat? (lambda (tabdat-item) (filter (lambda (alist-entry) (member (car alist-entry) '(allruns-by-id allruns))) ;; FIELDS OF INTEREST (dboard:tabdat->alist tabdat-item))))) (define (dboard:tabdat-target-string vec) (let ((targ (dboard:tabdat-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) (define (dboard:tabdat-test-patts-use vec) (let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for? |
︙ | |||
358 359 360 361 362 363 364 365 366 367 368 369 370 371 | 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 | + + + + + + + + + + + + + + | ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat key-vals ((last-update 0) : fixnum) ;; last query to db got records from before last-update ((data-changed #f) : boolean) ((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less that 100 items (db-path #f) ) ;; register dboard:rundat with BBpp ;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle (hash-table-set! *BBpp_custom_expanders_list* RUNDAT: (cons dboard:rundat? (lambda (tabdat-item) (filter (lambda (alist-entry) (member (car alist-entry) '(run run-data-offset ))) ;; FIELDS OF INTEREST (dboard:rundat->alist tabdat-item))))) (define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f));; -100 is before time began (make-dboard:rundat run: run tests: (or tests (make-hash-table)) key-vals: key-vals )) |
︙ | |||
621 622 623 624 625 626 627 628 629 630 631 632 633 634 | 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 | + + | (start-time (current-seconds)) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run header "id") run)) runs-tree) ;; (vector-ref runs-dat 1)) ht)) (tb (dboard:tabdat-runs-tree tabdat))) ;;(BB> "In update-rundat") ;;(inspect allruns runs-hash) (dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2)) (dboard:tabdat-header-set! tabdat header) ;; ;; trim runs to only those that are changing often here ;; (if (null? runs) (begin |
︙ | |||
738 739 740 741 742 743 744 | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 | - + + + + + + + | (let* ((newmaxtests (max num-tests maxtests)) ;; (last-update (- (current-seconds) 10)) (run-struct (or run-struct (dboard:rundat-make-init run: run tests: tests-ht key-vals: key-vals))) |
︙ | |||
3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 | 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 | + + + | (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num)) (dbkeys (dboard:tabdat-dbkeys tabdat))) ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num) ;;(tabdat-values tabdat) ;;RA added ;; (pp (dboard:tabdat->alist tabdat)) ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat) (dashboard:do-update-rundat tabdat) ;;(BB> "dashboard:runs-tab-updater") ;;(inspect tabdat) (let ((uidat (dboard:commondat-uidat commondat))) ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat) (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat))) )) "dashboard:runs-tab-updater")) ;;====================================================================== |
︙ |
Modified db.scm from [b74c06eb1c] to [31eac1d5ff].
︙ | |||
191 192 193 194 195 196 197 | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 | - + - + | ;; ;; (define db:get-dbdir common:get-db-tmp-area) ;; (or (configf:lookup *configdat* "setup" "dbdir") ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) |
︙ | |||
333 334 335 336 337 338 339 340 341 342 343 344 345 346 | 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 | + | (debug:print-info 4 *default-log-port* "Syncing for run-id: " run-id) (mutex-lock! *db-multi-sync-mutex*) (let ((update_info (cons (if force-sync 0 *db-last-sync*) "last_update"))) (mutex-unlock! *db-multi-sync-mutex*) (db:sync-tables (db:sync-all-tables-list dbstruct) update_info tmpdb refndb mtdb)) (mutex-lock! *db-multi-sync-mutex*) (set! *db-last-sync* start-t) (set! *db-last-access* start-t) (mutex-unlock! *db-multi-sync-mutex*))) ;; close all opened run-id dbs (define (db:close-all dbstruct) (if (dbr:dbstruct? dbstruct) (begin ;; (db:sync-touched dbstruct 0 force-sync: #t) ;; NO. Do not do this here. Instead we rely on a server to be started when there are writes, even if the server itself is not going to be used as a server. |
︙ | |||
737 738 739 740 741 742 743 | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 | - + | (define (db:get-access-mode) (if (args:get-arg "-use-db-cache") 'cached 'rmt)) ;; Add db direct ;; (define (db:dispatch-query access-mode rmt-cmd db-cmd . params) (if (eq? access-mode 'cached) |
︙ | |||
1495 1496 1497 1498 1499 1500 1501 | 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 | + + + + + + + - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + | ;; (> (- (current-seconds)(file-modification-time tdatpath)) 600)))) ;; no change in 10 minutes to testdat.db - she's dead Jim ;; incompleted)) (min-incompleted-ids (map car incompleted)) ;; do 'em all (all-ids (append min-incompleted-ids (map car oldlaunched)))) (if (> (length all-ids) 0) (begin (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") (for-each (lambda (test-id) (db:test-set-status-state dbstruct run-id test-id "COMPLETE" "DEAD" "Test failed to complete")) all-ids)))))) ;; ALL REPLACED BY THE BLOCK ABOVE ;; |
︙ | |||
2036 2037 2038 2039 2040 2041 2042 | 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 | - + + | (lambda (state status count) (let ((netstate (if (equal? state "COMPLETED") status state))) (if (string? netstate) (begin (hash-table-set! totals netstate (+ (hash-table-ref/default totals netstate 0) count)) (hash-table-set! curr netstate (+ (hash-table-ref/default curr netstate 0) count)))))) db |
︙ | |||
2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 | 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 | + + + | (string-intersperse testnames "','") "') AND NOT (uname = 'n/a' AND item_path='');")) ;; should this include the (uname = 'n/a' ...) ??? )) 0))))) ;; DEBUG FIXME - need to merge this v.155 query correctly ;; AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?) ;; AND NOT (uname = 'n/a' AND item_path = '');" ;; tags: '("tag%" "tag2" "%ag6") ;; ;; done with run when: ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING (define (db:estimated-tests-remaining dbstruct run-id) (db:with-db dbstruct run-id |
︙ | |||
3052 3053 3054 3055 3056 3057 3058 3059 3060 | 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 | + + - + - + + | (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) (sqlite3:finalize! runsqry) row-ids)) ;; finds latest matching all patts for given run-id ;; (define (db:test-get-paths-matching-keynames-target-new dbstruct run-id keynames target res testpatt statepatt statuspatt runname) (let* ((testqry (tests:match->sqlqry testpatt)) |
︙ | |||
3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 | 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 | + | ;; '(test-set-rundir "UPDATE tests SET rundir=? AND testname=? AND item_path=?;") ;; DONE '(test-set-rundir-shortdir "UPDATE tests SET rundir=?,shortdir=? WHERE testname=? AND item_path=? AND run_id=?;") ;; BROKEN!!! NEEDS run-id '(delete-tests-in-state ;; "DELETE FROM tests WHERE state=?;") ;; DONE "UPDATE tests SET state='DELETED' WHERE state=?") '(tests:test-set-toplog "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';") '(update-cpuload-diskfree "UPDATE tests SET cpuload=?,diskfree=? WHERE id=?;") ;; DONE '(update-uname-host "UPDATE tests SET uname=?,host=? WHERE id=?;") ;; DONE '(update-test-rundat "INSERT INTO test_rundat (test_id,update_time,cpuload,diskfree,diskusage,run_duration) VALUES (?,?,?,?,?,?);") '(update-test-state "UPDATE tests SET state=? WHERE state=? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") '(update-test-status "UPDATE tests SET status=? WHERE status like ? AND run_id=? AND testname=? AND NOT (item_path='' AND testname IN (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));") ;; stuff for roll-up-pass-fail-counts '(update-pass-fail-counts "UPDATE tests SET fail_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('FAIL','CHECK','INCOMPLETE','ABORT')), pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) WHERE testname=? AND item_path='' AND run_id=?;") ;; DONE ;; BROKEN!!! NEEDS run-id |
︙ | |||
3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 | 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 | + + + + + + + + + + + + + + + + + + | (sqlite3:for-each-row (lambda (state status count) (set! res (cons (vector state status count) res))) db "SELECT state,status,count(state) FROM tests WHERE run_id=? AND testname=? AND item_path='' GROUP BY state,status;" run-id testname) res)) (define (db:get-latest-host-load dbstruct raw-hostname) (let* ((hostname (string-substitute "\\..*$" "" raw-hostname)) (res (cons -1 0)) (mydb (db:dbdat-get-db (db:get-db dbstruct 0))) ) (db:with-db dbstruct 0 #f (lambda (db) (sqlite3:for-each-row (lambda (cpuload update-time) (set! res (cons cpuload update-time))) db "SELECT tr.cpuload, tr.update_time FROM test_rundat tr, tests t WHERE t.host=? AND tr.cpuload != -1 AND tr.test_id=t.id ORDER BY tr.update_time DESC LIMIT 1;" hostname))) res )) (define (db:set-top-level-from-items dbstruct run-id testname) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (summ (db:get-state-status-summary db run-id testname)) (find (lambda (state status) (if (null? summ) |
︙ | |||
3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 | 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 | + + + + + + + + + + + + + + + + + + + | "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" test-name) res)))) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; returns a hash table of tags to tests ;; (define (db:get-tests-tags dbstruct) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat)) (res (make-hash-table))) (sqlite3:for-each-row (lambda (testname tags-in) (let ((tags (string-split tags-in ","))) (for-each (lambda (tag) (hash-table-set! res tag (delete-duplicates (cons testname (hash-table-ref/default res tag '()))))) tags))) db "SELECT testname,tags FROM test_meta") res)) ;; read the record given a testname (define (db:testmeta-get-record dbstruct testname) (let ((res #f)) (db:with-db dbstruct #f |
︙ |
Modified docs/manual/megatest_manual.html from [2d6199dc08] to [2f3ab9d0a7].
︙ | |||
1323 1324 1325 1326 1327 1328 1329 | 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 | + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + | </div> </div> </div> <div class="sect1"> <h2 id="_reference">Reference</h2> <div class="sectionbody"> <div class="sect2"> <h3 id="_config_file_helpers">Config File Helpers</h3> <div class="paragraph"><p>Various helpers for more advanced config files.</p></div> <table class="tableblock frame-topbot grid-all" style=" width:80%; "> <caption class="title">Table 2. Helpers</caption> <col style="width:14%;"> <col style="width:28%;"> <col style="width:28%;"> <col style="width:28%;"> <thead> <tr> <th class="tableblock halign-center valign-top" >Helper </th> <th class="tableblock halign-left valign-top" > Purpose </th> <th class="tableblock halign-left valign-top" > Valid values </th> <th class="tableblock halign-left valign-top" > Comments</th> </tr> </thead> <tbody> <tr> <td class="tableblock halign-center valign-top" ><p class="tableblock">#{scheme (scheme code…)}</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Execute arbitrary scheme code</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Any valid scheme</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Value returned from the call is converted to a string and processed as part of the config file</p></td> </tr> <tr> <td class="tableblock halign-center valign-top" ><p class="tableblock">#{system command}</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Execute program, inserts exit code</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Any valid Unix command</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Discards the output from the program</p></td> </tr> <tr> <td class="tableblock halign-center valign-top" ><p class="tableblock">#{shell command} or #{sh …}</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Execute program, inserts result from stdout</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Any valid Unix command</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Value returned from the call is converted to a string and processed as part of the config file</p></td> </tr> <tr> <td class="tableblock halign-center valign-top" ><p class="tableblock">#{realpath path} or #{rp …}</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Replace with normalized path</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Must be a valid path</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced"></p></td> </tr> <tr> <td class="tableblock halign-center valign-top" ><p class="tableblock">#{getenv VAR} or #{gv VAR}</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Replace with content of env variable</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Must be a valid var</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced"></p></td> </tr> <tr> <td class="tableblock halign-center valign-top" ><p class="tableblock">#{get s v} or #{g s v}</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Replace with variable v from section s</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Variable must be defined before use</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced"></p></td> </tr> <tr> <td class="tableblock halign-center valign-top" ><p class="tableblock">#{rget v}</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Replace with variable v from target or default of runconfigs file</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced"></p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced"></p></td> </tr> <tr> <td class="tableblock halign-center valign-top" ><p class="tableblock"></p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Replace with the path to the megatest testsuite area</p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced"></p></td> <td class="tableblock halign-left valign-top" ><p class="tableblock monospaced"></p></td> </tr> </tbody> </table> </div> <div class="sect2"> |
︙ | |||
1446 1447 1448 1449 1450 1451 1452 | 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 | - + | </div> <div class="sect2"> <h3 id="_database_settings">Database settings</h3> <table class="tableblock frame-topbot grid-all" style=" width:70%; "> |
︙ | |||
1915 1916 1917 1918 1919 1920 1921 | 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 | - + | <h2 id="_programming_api">Programming API</h2> <div class="sectionbody"> <div class="paragraph"><p>These routines can be called from the megatest repl.</p></div> <table class="tableblock frame-topbot grid-all" style=" width:70%; "> |
︙ | |||
1967 1968 1969 1970 1971 1972 1973 | 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 | - + | </div> </div> </div> <div id="footnotes"><hr></div> <div id="footer"> <div id="footer-text"> Version 1.0<br> |
Modified docs/manual/reference.txt from [206fb51b8f] to [a08ca10124].
1 2 3 4 | 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 | + + + + + + + + + + + + + + + + + + + - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + | Reference --------- Config File Helpers ~~~~~~~~~~~~~~~~~~~ Various helpers for more advanced config files. .Helpers [width="80%",cols="^,2m,2m,2m",frame="topbot",options="header"] |====================== |Helper | Purpose | Valid values | Comments | #{scheme (scheme code...)} | Execute arbitrary scheme code | Any valid scheme | Value returned from the call is converted to a string and processed as part of the config file | #{system command} | Execute program, inserts exit code | Any valid Unix command | Discards the output from the program | #{shell command} or #{sh ...} | Execute program, inserts result from stdout | Any valid Unix command | Value returned from the call is converted to a string and processed as part of the config file | #{realpath path} or #{rp ...} | Replace with normalized path | Must be a valid path | | #{getenv VAR} or #{gv VAR} | Replace with content of env variable | Must be a valid var | | #{get s v} or #{g s v} | Replace with variable v from section s | Variable must be defined before use | | #{rget v} | Replace with variable v from target or default of runconfigs file | | | #{mtrah} | Replace with the path to the megatest testsuite area | | |====================== |
︙ |
Modified http-transport.scm from [4d8eecbf3a] to [85b3cef6fd].
︙ | |||
215 216 217 218 219 220 221 | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | - + | ;; (define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 3)) (let* ((fullurl (if (vector? serverdat) (http-transport:server-dat-get-api-req serverdat) (begin (debug:print 0 *default-log-port* "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) |
︙ | |||
381 382 383 384 385 386 387 | 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 417 418 | - + + + + - + + - + | (last-access 0) (server-timeout (server:get-timeout)) (server-going #f)) (let loop ((count 0) (server-state 'available) (bad-sync-count 0) (start-time (current-milliseconds))) |
︙ | |||
484 485 486 487 488 489 490 | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 | + - + | ;; (if (and (<= rem-time 4) ;; (> rem-time 0)) ;; (thread-sleep! rem-time) ;; (thread-sleep! 4))) ;; fallback for if the math is changed ... (define (http-transport:server-shutdown server-id port) (let ((tdbdat (tasks:open-db))) ;;(BB> "http-transport:server-shutdown called") |
︙ | |||
511 512 513 514 515 516 517 518 519 520 521 522 523 524 | 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 | + - - + - - - + - + | (/ *total-non-write-delay* *number-non-write-queries*)) " ms") (debug:print-info 0 *default-log-port* "Server shutdown complete. Exiting") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete") ;; if the .server file contained :myport then we can remove it (server:remove-dotserver-file *toppath* port) ;;(BB> "http-transport:server-shutdown -> exit") (exit))) ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch run-id) |
︙ |
Deleted inteldate.scm version [a6b831c59f].
| - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
|
Modified launch.scm from [4e784cfd15] to [e1f9f3deb0].
︙ | |||
120 121 122 123 124 125 126 127 128 129 130 131 132 133 | 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 | + + + + + + + + + + + + | (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) ;; now launch the actual process (call-with-environment-variables (list (cons "PATH" (conc (get-environment-variable "PATH") ":."))) (lambda () ;; (process-run "/bin/bash" "-c" "exec ls -l /tmp/foobar > /tmp/delme-more.log 2>&1") (let* ((cmd (conc stepcmd " > " stepname ".log 2>&1")) ;; >outfile 2>&1 (pid (process-run "/bin/bash" (list "-c" cmd)))) (with-output-to-file "Makefile.ezsteps" (lambda () (print stepname ".log :") (print "\t" cmd) (if (file-exists? (conc stepname ".logpro")) (print "\tlogpro " stepname ".logpro " stepname ".html < " stepname ".log")) (print) (print stepname " : " stepname ".log") (print)) #:append) (rmt:test-set-top-process-pid run-id test-id pid) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! m) (launch:einf-pid-set! exit-info pid) ;; (vector-set! exit-info 0 pid) (launch:einf-exit-status-set! exit-info exit-status) ;; (vector-set! exit-info 1 exit-status) (launch:einf-exit-code-set! exit-info exit-code) ;; (vector-set! exit-info 2 exit-code) |
︙ | |||
314 315 316 317 318 319 320 | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 | - + - + - + | (current-seconds) start-seconds))))) (kill-tries 0)) ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) (let loop ((minutes (calc-minutes)) |
︙ | |||
844 845 846 847 848 849 850 | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 | - + + + + - + | ))) (if (and *toppath* (directory-exists? *toppath*)) (begin (setenv "MT_RUN_AREA_HOME" *toppath*) (setenv "MT_TESTSUITE_NAME" (common:get-testsuite-name))) (begin |
︙ | |||
1051 1052 1053 1054 1055 1056 1057 | 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 | + + - - - - - - - + + + + + + + - - - - - - + + + + + + - - - - - + + + + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + | ;; 2. create run dir on disk, path name is meaningful ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex (let* ((item-path (item-list->path itemdat))) |
︙ |
Modified megatest-version.scm from [a6ad525294] to [0bf6986bb1].
1 2 3 4 5 | 1 2 3 4 5 6 7 | - + | ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) |
Modified megatest.scm from [46d15d3c2a] to [ba3fdf979e].
︙ | |||
91 92 93 94 95 96 97 98 99 100 101 102 103 104 | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | + + | Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.) -target key1/key2/... : run for key1, key2, etc. -reqtarg key1/key2/... : run for key1, key2, etc. but key1/key2 must be in runconfig -testpatt patt1/patt2,patt3/... : % is wildcard -runname : required, name for this particular test run -state : Applies to runs, tests or steps depending on context -status : Applies to runs, tests or steps depending on context -mode key : load testpatt from <key> in runconfigs instead of default TESTPATT -tagexpr tag1,tag2%,.. : select tests with tags matching expression Test helpers (for use inside tests) -step stepname -test-status : set the state and status of a test (use :state and :status) -setlog logfname : set the path/filename to the final log relative to the test directory. may be used with -test-status -set-toplog logfname : set the overall log for a suite of sub-tests |
︙ | |||
116 117 118 119 120 121 122 | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 | - + | -load-test-data : read test specific data for storage in the test_data table from standard in. Each line is comma delimited with four fields category,variable,value,comment Queries -list-runs patt : list runs matching pattern \"patt\", % is the wildcard -show-keys : show the keys used in this megatest setup |
︙ | |||
207 208 209 210 211 212 213 | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 | - + + + | ":runname" "-runname" ":state" "-state" ":status" "-status" "-list-runs" |
︙ | |||
343 344 345 346 347 348 349 | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 | + - + + | (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")))) (if targ (setenv "MT_TARGET" targ))) ;; The watchdog is to keep an eye on things like db sync etc. ;; (define *watchdog* (make-thread common:watchdog "Watchdog thread")) (if (not (args:get-arg "-server")) |
︙ | |||
788 789 790 791 792 793 794 | 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 | + - - - - - - - - - - - - - + + + + + + + + + + + + + | (exit)))) ;;====================================================================== ;; Weird special calls that need to run *after* the server has started? ;;====================================================================== (if (args:get-arg "-list-targets") (if (launch:setup) |
︙ | |||
1016 1017 1018 1019 1020 1021 1022 | 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 | - - + + + - - - - - - - - - - - - - + + + + + + + + + + + + + | ;; (if (args:get-arg "-testpatt") ;; (args:get-arg "-testpatt") ;; "%")) (keys (rmt:get-keys)) ;; (db:get-keys dbstruct)) ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) ;; (runsdat (rmt:get-runs-by-patt keys (or runpatt "%") (common:args-get-target) ;; (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) ;; #f #f '("id" "runname" "state" "status" "owner" "event_time" "comment") 0)) |
︙ | |||
1525 1526 1527 1528 1529 1530 1531 | 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 | + - + | (debug:print 0 *default-log-port* "Failed to setup, giving up on -test-paths or -test-files, exiting") (exit 1))) (let* ((keys (rmt:get-keys)) ;; db:test-get-paths must not be run remote (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (set! *didsomething* #t) (for-each (lambda (path) (if (file-exists? path) |
︙ | |||
1823 1824 1825 1826 1827 1828 1829 | 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 | + - + | (if (args:get-arg "-cleanup-db") (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) (let ((dbstruct (db:setup *toppath*))) |
︙ | |||
1845 1846 1847 1848 1849 1850 1851 | 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 | - - - + | (if (args:get-arg "-update-meta") (begin (if (not (launch:setup)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") (exit 1))) |
︙ | |||
1980 1981 1982 1983 1984 1985 1986 | 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 | - - + + + + + + + + - | (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html")) (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== |
Added minimal/manyservers.sh version [1fde698cb9].