Changes In Branch v1.60 Through [c8184e551e] Excluding Merge-Ins
This is equivalent to a diff from e89be5432c to c8184e551e
2014-11-30
| ||
12:19 | Merged ABORT changes check-in: 12a41bff5e user: matt tags: v1.60 | |
09:53 | Merged fix for get-tests-for-run(s) check-in: c8184e551e user: matt tags: v1.60 | |
2014-11-25
| ||
21:10 | Add big delay and take a break when system is clearly overloaded. check-in: ec50f4ac00 user: matt tags: v1.60 | |
2014-09-09
| ||
10:42 | Removing zmq from chicken build script check-in: 91fd288f45 user: matt tags: v1.55 | |
2014-08-13
| ||
16:13 | Merged in v1.55 changes check-in: f870afe4d0 user: mrwellan tags: v1.60 | |
13:57 | Unset TARGET* vars before starting the real work in nbfake check-in: e89be5432c user: mrwellan tags: v1.55 | |
2014-08-05
| ||
00:09 | Added bit more to datashare check-in: 8e9852ca99 user: matt tags: v1.55 | |
Modified Makefile from [660e49132a] to [64fd867d54].
1 2 3 4 5 6 7 8 | # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)' PREFIX=$(PWD) CSCOPTS= INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm filedb.scm \ client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \ tree.scm ezsteps.scm lock-queue.scm sdb.scm \ rmt.scm api.scm tdb.scm portlogger.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3 |
︙ | ︙ | |||
41 42 43 44 45 46 47 | mtest: $(OFILES) megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard | | | > > | | > > | | | 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 89 90 91 92 93 94 95 | mtest: $(OFILES) megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm csc $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(OFILES) $(GOFILES) newdashboard.scm -o ndboard # # $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm # csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl # Special dependencies for the includes tests.o db.o launch.o runs.o dashboard-tests.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o megatest.o : db_records.scm tests.o runs.o dashboard.o dashboard-tests.o dashboard-main.o : run_records.scm db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm tests.o tasks.o dashboard-tasks.o : task_records.scm runs.o : test_records.scm megatest.o : megatest-fossil-hash.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm zmq-transport.scm : common_records.scm # Temporary while transitioning to new routine # runs.o : run-tests-queue-classic.scm run-tests-queue-new.scm megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm csc $(CSCOPTS) -c $< $(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest @echo Installing to PREFIX=$(PREFIX) $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest chmod a+x $(PREFIX)/bin/megatest $(PREFIX)/bin/.$(ARCHSTR)/ndboard : ndboard $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard $(HELPERS) : utils/mt_* $(INSTALL) $< $@ chmod a+x $@ $(PREFIX)/bin/mt_xterm : utils/mt_xterm $(INSTALL) $< $@ |
︙ | ︙ | |||
117 118 119 120 121 122 123 | # install dashboard as dboard so wrapper script can be called dashboard $(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) utils/mk_wrapper $(PREFIX) dboard $(PREFIX)/bin/dashboard chmod a+x $(PREFIX)/bin/dashboard $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard | | > | > | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | # install dashboard as dboard so wrapper script can be called dashboard $(PREFIX)/bin/.$(ARCHSTR)/dboard : dboard $(FILES) 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/refdb $(PREFIX)/bin/mt_xterm \ $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) test: tests/tests.scm cd tests;csi -I .. -b -n tests.scm |
︙ | ︙ | |||
161 162 163 164 165 166 167 | csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg mv deploytarg/deploytarg deploytarg/mtest deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg mv deploytarg/deploytarg deploytarg/dboard | | > | | | > | > > > | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg mv deploytarg/deploytarg deploytarg/mtest deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg mv deploytarg/deploytarg deploytarg/dboard # DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \ # megatest-version.o tdb.o ods.o mt.o keys.o datashare-testing/sd : datashare.scm $(OFILES) csc datashare.scm $(OFILES) -o datashare-testing/sd sd : datashare-testing/sd mkdir -p /tmp/$(USER)/datashare/disk1 /tmp/$(USER)/basepath xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) |
Modified NOTES from [f5959ca38f] to [8d1d854887].
1 2 3 4 5 6 7 | [87cbe68f31] [be405e8e2e] # FROM andyjpg on #chicken (let ((original-exit (exit-handler))) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ====================================================================== Try writing to in-memory db and every 2-5 seconds syncing to megatest.db ====================================================================== First, how much time will it take to write back the changes: 1. Get the run table (define (get-all db)(let ((res '()))(for-each-row (lambda (a . b)(set! res (cons (apply vector a b) res))) db "SELECT * FROM tests;") res)) (define tdata (let ((start (current-milliseconds))(res (get-all *db*)))(print (- (current-milliseconds) start))res)) Result ranges from 34ms to 89ms but mostly around 40ms for 623 records on moosefs Projecting to 15000 records: Slow 2 seconds to read all Median 1 second to read all This seems like it would work with an update period of 2-5 seconds TODO ---- 1. open-db opens in-memory db and megatest.db, put handles in *memdb* and *db*, *memdb* is < run-id dbh > 2. Server is part of runtests a. server start cycle - adapt to per run-id i. states; starting, started, stopping, stopped b. turn off write coalesing 3. Calls to -runtests, -remove-runs etc. a. Might talk to running server if run specific b. Can talk to megatest.db but not a generally good idea c. Can start a runserver 4. Dashboard is fine except for writes? ====================================================================== Routines to convert for runs.scm cdb:remote-run db:register-run cdb:delete-tests-in-state *runremote* cdb:get-test-info-by-id *runremote* cdb:remote-run db:delete-old-deleted-test-records cdb:remote-run db:delete-run cdb:remote-run db:delete-test-records cdb:remote-run db:delete-tests-for-run cdb:remote-run db:find-and-mark-incomplete cdb:remote-run db:get-count-tests-running cdb:remote-run db:get-count-tests-running-in-jobgroup cdb:remote-run db:get-keys cdb:remote-run db:get-run-info cdb:remote-run db:get-run-key-val cdb:remote-run db:get-run-name-from-id cdb:remote-run db:get-steps-for-test cdb:remote-run db:get-test-id-cached cdb:remote-run db:get-tests-for-runs-mindata cdb:remote-run db:lock/unlock-run cdb:remote-run db:set-sync cdb:remote-run db:set-tests-state-status cdb:remote-run db:set-var cdb:remote-run db:testmeta-add-record cdb:remote-run db:testmeta-get-record cdb:remote-run db:testmeta-update-field cdb:remote-run db:update-run-event_time cdb:remote-run instead cdb:remote-run server:start cdb:remote-run test:get-matching-previous-test-run-records cdb:tests-register-test *runremote* (define (runs:shrink-can-run-more-tests-count) ;; the db is a dummy var so we can use cdb:remote-run ====================================================================== [87cbe68f31] [be405e8e2e] # FROM andyjpg on #chicken (let ((original-exit (exit-handler))) |
︙ | ︙ |
Modified TODO from [61ddd55e7d] to [249cc9a526].
1 |
| > > | | > | > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | TODO ==== Migration to inmem db plus per run db ------------------------------------- . Re-work the dbstruct data structure? .. Move main.db to global? .. [ run-id.db inmemdb last-mod last-read last-sync inuse ] . Re-work all queries to use run-id to dereference server . Open main.db directly in calls to -runtests etc. No need to talk remote? |
Added api.scm version [b8269d4337].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 | ;;====================================================================== ;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (declare (unit api)) (declare (uses rmt)) (declare (uses db)) ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs get-keys test-toplevel-num-items get-test-info-by-id test-get-rundir-from-test-id get-count-tests-running get-count-tests-running-in-jobgroup get-previous-test-run-record get-matching-previous-test-run-records test-get-logfile-info test-get-records-for-index-file get-testinfo-state-status test-get-top-process-pid test-get-paths-matching-keynames-target-new get-prereqs-not-met get-count-tests-running-for-run-id get-run-info get-run-status register-run get-tests-for-run get-test-id get-tests-for-runs-mindata get-run-name-from-id get-runs get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data login testmeta-get-record)) ;; These are called by the server on recipt of /api calls ;; - keep it simple, only return the actual result of the call, i.e. no meta info here ;; (define (api:execute-requests dbstruct cmd params) (case (string->symbol cmd) ;; SERVERS ((start-server) (apply server:kind-run params)) ((kill-server) (set! *server-run* #f)) ;; KEYS ((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params)) ((get-keys) (db:get-keys dbstruct)) ;; TESTS ((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params)) ((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params)) ((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params)) ((test-set-state-status-by-id) (apply db:test-set-state-status-by-id dbstruct params)) ((get-count-tests-running) (apply db:get-count-tests-running dbstruct params)) ((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params)) ((delete-test-records) (apply db:delete-test-records dbstruct params)) ;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params)) ((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params)) ((test-set-status-state) (apply db:test-set-status-state dbstruct params)) ((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params)) ((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params)) ((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params)) ((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params)) ((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params)) ((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params)) ((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params)) ((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params)) ((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params)) ((roll-up-pass-fail-counts) (apply db:roll-up-pass-fail-counts dbstruct params)) ((update-fail-pass-counts) (apply db:general-call dbstruct 'update-pass-fail-counts params)) ((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params)) ;; RUNS ((get-run-info) (apply db:get-run-info dbstruct params)) ((get-run-status) (apply db:get-run-status dbstruct params)) ((set-run-status) (apply db:set-run-status dbstruct params)) ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((get-tests-for-run) (apply db:get-tests-for-run dbstruct params)) ((get-test-id) (apply db:get-test-id dbstruct params)) ((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params)) ((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params)) ((delete-run) (apply db:delete-run dbstruct params)) ((get-runs) (apply db:get-runs dbstruct params)) ((get-all-run-ids) (db:get-all-run-ids dbstruct)) ((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params)) ((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params)) ((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params)) ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) ((find-and-mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ;; TEST DATA ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) ((csv->test-data) (apply db:csv->test-data dbstruct params)) ((get-steps-data) (apply db:get-steps-data dbstruct params)) ;; MISC ((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) (db:general-call db stmtname realparams))))) ((sync-inmem->db) (db:sync-touched dbstruct run-id force-sync: #t)) ((sdb-qry) (apply sdb:qry params)) ;; TESTMETA ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) ((testmeta-add-record) (apply db:testmeta-add-record dbstruct params)) ((testmeta-update-field) (apply db:testmeta-update-field dbstruct params)) (else (list "ERROR" 0)))) ;; http-server send-response ;; api:process-request ;; db:* ;; ;; NB// Runs on the server as part of the server loop ;; (define (api:process-request dbstruct $) ;; the $ is the request vars proc (let* ((cmd ($ 'cmd)) (paramsj ($ 'params)) (params (db:string->obj paramsj)) ;; (rmt:json-str->dat paramsj)) (res (api:execute-requests dbstruct cmd params))) ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds ;; (rmt:dat->json-str ;; (if (or (string? res) ;; (list? res) ;; (number? res) ;; (boolean? res)) ;; res ;; (list "ERROR, not string, list, number or boolean" 1 cmd params res))))) (db:obj->string res))) |
Modified client.scm from [2d4047b824] to [6d1c8717b3].
︙ | ︙ | |||
33 34 35 36 37 38 39 | ;; client:get-signature (define (client:get-signature) (if *my-client-signature* *my-client-signature* (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) | < < < < > > > | > > | < | | | < | > | > > > > > | > | < > | > > | | > | > > > > > > | | | < | > > > > > > > > > > > > > | | > > > > > | > | > > > | > > | < > > > > > > > > | | | | | | | 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 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 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 | ;; client:get-signature (define (client:get-signature) (if *my-client-signature* *my-client-signature* (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) *my-client-signature*))) ;; Not currently used! But, I think it *should* be used!!! (define (client:logout serverdat) (let ((ok (and (socket? serverdat) (cdb:logout serverdat *toppath* (client:get-signature))))) ok)) ;; Do all the connection work, look up the transport type and set up the ;; connection if required. ;; ;; There are two scenarios. ;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline ;; 2. We are a run tests, list runs or other interactive process and we must figure out ;; *transport-type* and *runremote* from the monitor.db ;; ;; client:setup ;; ;; lookup_server, need to remove *runremote* stuff ;; (define (client:setup run-id #!key (remaining-tries 100) (failed-connects 0)) (debug:print-info 2 "client:setup remaining-tries=" remaining-tries) (let* ((tdbdat (tasks:open-db))) (if (<= remaining-tries 0) (begin (debug:print 0 "ERROR: failed to start or connect to server for run-id " run-id) (exit 1)) (let ((host-info (hash-table-ref/default *runremote* run-id #f))) (if host-info (let* ((iface (http-transport:server-dat-get-iface host-info)) (port (http-transport:server-dat-get-port host-info)) (start-res (http-transport:client-connect iface port)) (ping-res (rmt:login-no-auto-client-setup start-res run-id))) (if ping-res ;; sucessful login? (begin (debug:print-info 2 "client:setup, ping is good using host-info=" host-info ", remaining-tries=" remaining-tries) ;; Why add the close-connections here? ;; (http-transport:close-connections run-id) (hash-table-set! *runremote* run-id start-res) start-res) ;; return the server info ;; have host info but no ping. shutdown the current connection and try again (begin ;; login failed (debug:print-info 1 "client:setup, ping is bad for start-res=" start-res " and *runremote*=" host-info) (http-transport:close-connections run-id) (hash-table-delete! *runremote* run-id) (if (< remaining-tries 8) (thread-sleep! 5) (thread-sleep! 1)) (client:setup run-id remaining-tries: (- remaining-tries 1))))) ;; YUK: rename server-dat here (let* ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) (debug:print-info 4 "client:setup server-dat=" server-dat ", remaining-tries=" remaining-tries) (if server-dat (let* ((iface (tasks:hostinfo-get-interface server-dat)) (port (tasks:hostinfo-get-port server-dat)) (start-res (http-transport:client-connect iface port)) (ping-res (rmt:login-no-auto-client-setup start-res run-id))) (if (and start-res ping-res) (begin (hash-table-set! *runremote* run-id start-res) (debug:print-info 2 "connected to " (http-transport:server-dat-make-url start-res)) start-res) (begin ;; login failed but have a server record, clean out the record and try again (debug:print-info 0 "client:setup, login failed, will attempt to start server ... start-res=" start-res ", run-id=" run-id ", server-dat=" server-dat) (http-transport:close-connections run-id) (hash-table-delete! *runremote* run-id) (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id (tasks:hostinfo-get-interface server-dat) (tasks:hostinfo-get-port server-dat) " client:setup (server-dat = #t)") (thread-sleep! 2) (server:try-running run-id) (thread-sleep! 10) ;; give server a little time to start up (client:setup run-id remaining-tries: (- remaining-tries 1))))) (begin ;; no server registered (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) (thread-sleep! 2) (if (< num-available 2) (begin (server:try-running run-id))) (thread-sleep! 10) ;; give server a little time to start up (client:setup run-id remaining-tries: (- remaining-tries 1))))))))))) ;; keep this as a function to ease future (define (client:start run-id server-info) (http-transport:client-connect (tasks:hostinfo-get-interface server-info) (tasks:hostinfo-get-port server-info))) ;; client:signal-handler (define (client:signal-handler signum) (signal-mask! signum) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () "") ;; do nothing for now (was flush out last call if applicable) "eat response")) (th2 (make-thread (lambda () (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 1) ;; give the flush one second to do it's stuff (debug:print 0 " Done.") (exit 4)) "exit on ^C timer"))) (thread-start! th2) (thread-start! th1) (thread-join! th2)))) ;; client:launch ;; Need to set the signal handler somewhere other than here as this ;; routine will go away. ;; (define (client:launch run-id) (set-signal-handler! signal/int client:signal-handler) (if (client:setup run-id) (debug:print-info 2 "connected as client") (begin (debug:print 0 "ERROR: Failed to connect as client") (exit)))) |
Modified common.scm from [b4d7faf92c] to [aa6e9ff977].
1 2 3 4 5 6 7 8 9 10 11 | ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== | | > > > > > > > | > > > > > > > > > > > > > > > > > > | < | < | | | 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 89 90 | ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3) (require-extension sqlite3 regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit common)) (include "common_records.scm") ;; (require-library margs) ;; (include "margs.scm") (define getenv get-environment-variable) (define (safe-setenv key val) (if (and (string? val)(string? key)) (handle-exceptions exn (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val) (setenv key val)) (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val))) (define home (getenv "HOME")) (define user (getenv "USER")) ;; GLOBAL GLETCHES (define *db-keys* #f) (define *configinfo* #f) (define *configdat* #f) (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *waiting-queue* (make-hash-table)) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar (define *write-frequency* (make-hash-table)) ;; run-id => (vector (current-seconds) 0)) (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing ;; DATABASE (define *dbstruct-db* #f) (define *db-stats* (make-hash-table)) ;; hash of vectors < count duration-total > (define *db-stats-mutex* (make-mutex)) (define *db-sync-mutex* (make-mutex)) (define *db-multi-sync-mutex* (make-mutex)) (define *db-local-sync* (make-hash-table)) ;; used to record last touch of db (define *megatest-db* #f) (define *last-db-access* (current-seconds)) ;; update when db is accessed via server (define *db-write-access* #t) (define *inmemdb* #f) (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'http) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* (make-hash-table)) ;; if set up for server communication this will hold <host port> (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *client-non-blocking-mode* #f) (define *server-id* #f) (define *server-info* #f) (define *time-to-exit* #f) (define *received-response* #f) (define *default-numtries* 10) (define *server-run* #t) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (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 |
︙ | ︙ | |||
89 90 91 92 93 94 95 96 97 98 99 100 | (set! *test-paths* (make-hash-table)) (set! *test-ids* (make-hash-table)) (set! *test-info* (make-hash-table)) (set! *run-info-cache* (make-hash-table)) (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define *common:std-states* | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 | (set! *test-paths* (make-hash-table)) (set! *test-ids* (make-hash-table)) (set! *test-info* (make-hash-table)) (set! *run-info-cache* (make-hash-table)) (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) ;; Generic string database (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ;; Generic path database (define *fdb* #f) ;;====================================================================== ;; L O C K E R S A N D B L O C K E R S ;;====================================================================== ;; block further accesses to databases. Call this before shutting db down (define (common:db-block-further-queries) (mutex-lock! *db-access-mutex*) (set! *db-access-allowed* #f) (mutex-unlock! *db-access-mutex*)) (define (common:db-access-allowed?) (let ((val (begin (mutex-lock! *db-access-mutex*) *db-access-allowed* (mutex-unlock! *db-access-mutex*)))) val)) ;;====================================================================== ;; U S E F U L S T U F F ;;====================================================================== (define (common:low-noise-print waitval . keys) (let* ((key (string-intersperse (map conc keys) "-" )) (lasttime (hash-table-ref/default *common:denoise* key 0)) (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! *common:denoise* key currtime) #t) #f))) (define (common:get-megatest-exe) (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")) (define (common:read-encoded-string instr) (handle-exceptions exn (handle-exceptions exn (begin (debug:print 0 "ERROR: received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== (define *common:std-states* '((0 "COMPLETED") (1 "NOT_STARTED") (2 "RUNNING") (3 "REMOTEHOSTSTART") (4 "LAUNCHED") (5 "KILLED") (6 "KILLREQ") (7 "STUCK"))) (define *common:std-statuses* '((0 "PASS") (1 "WARN") (2 "FAIL") (3 "CHECK") (4 "n/a") (5 "WAIVED") (6 "SKIP") (7 "DELETED") (8 "STUCK/DEAD"))) ;; These are stopping conditions that prevent a test from being run (define *common:cant-run-states-sym* '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) ;;====================================================================== ;; D E B U G G I N G S T U F F ;;====================================================================== (define *verbosity* 1) (define *logging* #f) (define (get-with-default val default) (let ((val (args:get-arg val))) (if val val default))) (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) (define (common:get-testsuite-name) (or (configf:lookup *configdat* "setup" "testsuite" ) (pathname-file *toppath*))) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (std-exit-procedure) (debug:print-info 2 "starting exit process, finalizing databases.") (rmt:print-db-stats) (let ((run-ids (hash-table-keys *db-local-sync*))) (if (and (not (null? run-ids)) (configf:lookup *configdat* "setup" "megatest-db")) (db:multi-db-sync run-ids 'new2old))) (if *dbstruct-db* (db:close-all *dbstruct-db*)) (if (and *megatest-db* (sqlite3:database? *megatest-db*)) (begin (sqlite3:interrupt! *megatest-db*) (sqlite3:finalize! *megatest-db* #t) (set! *megatest-db* #f))) (if *task-db* (let ((db (cdr *task-db*))) (if (sqlite3:database? db) (begin (sqlite3:interrupt! db) (sqlite3:finalize! db #t) (vector-set! *task-db* 0 #f)))))) (define (std-signal-handler signum) (signal-mask! signum) (debug:print 0 "ERROR: Received signal " signum " exiting promptly") ;; (std-exit-procedure) ;; shouldn't need this since we are exiting and it will be called anyway (exit)) (set-signal-handler! signal/int std-signal-handler) (set-signal-handler! signal/term std-signal-handler) ;;====================================================================== ;; Misc utils ;;====================================================================== ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 (define (common:hms-string->seconds tstr) (let ((parts (string-split tstr)) |
︙ | ︙ | |||
183 184 185 186 187 188 189 | (if (string-match (regexp modpatt) item) (set! res #t)))) (string-split patts ",")) res) #t)) ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) | | > | | > | | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 | (if (string-match (regexp modpatt) item) (set! res #t)))) (string-split patts ",")) res) #t)) ;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) (define (common:get-runconfig-targets #!key (configf #f)) (sort (map car (hash-table->alist (or configf (read-config "runconfigs.config" #f #t)))) string<?)) ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) "disks" '("none" ""))) ;;====================================================================== ;; T A R G E T S ;;====================================================================== (define (common:args-get-target #!key (split #f)) |
︙ | ︙ | |||
381 382 383 384 385 386 387 | (define (get-uname . params) (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) | | | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 | (define (get-uname . params) (let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params))))) (uname #f)) (if (null? (car uname-res)) "unknown" (caar uname-res)))) (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF"))) (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]"))) (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) |
︙ | ︙ | |||
459 460 461 462 463 464 465 466 467 468 469 470 471 472 | (define (seconds->year-work-week/day sec) (time->string (seconds->local-time sec) "%yww%V.%w")) (define (seconds->year-work-week/day-time sec) (time->string (seconds->local-time sec) "%yww%V.%w %H:%M")) ;;====================================================================== ;; Colors ;;====================================================================== (define (common:name->iup-color name) (case (string->symbol (string-downcase name)) | > > > > > > > > > > > | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 | (define (seconds->year-work-week/day sec) (time->string (seconds->local-time sec) "%yww%V.%w")) (define (seconds->year-work-week/day-time sec) (time->string (seconds->local-time sec) "%yww%V.%w %H:%M")) (define (seconds->quarter sec) (case (string->number (time->string (seconds->local-time sec) "%m")) ((1 2 3) 1) ((4 5 6) 2) ((7 8 9) 3) ((10 11 12) 4) (else #f))) ;;====================================================================== ;; Colors ;;====================================================================== (define (common:name->iup-color name) (case (string->symbol (string-downcase name)) |
︙ | ︙ |
Modified common_records.scm from [61ac915575] to [08c9f6257d].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== ;; (use trace) (define (debug:calc-verbosity vstr) (cond ((number? vstr) vstr) ((not (string? vstr)) 1) ;; ((string-match "^\\s*$" vstr) 1) (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) | > > > > > > > > > > > > > > > > > > > | | | 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 | ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== ;; (use trace) ;; Some of these routines use: ;; ;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html ;; ;; Syntax for defining macros in a simple style similar to function definiton, ;; when there is a single pattern for the argument list and there are no keywords. ;; ;; (define-simple-syntax (name arg ...) body ...) ;; (define-syntax define-simple-syntax (syntax-rules () ((_ (name arg ...) body ...) (define-syntax name (syntax-rules () ((name arg ...) (begin body ...))))))) (define-syntax common:handle-exceptions (syntax-rules () ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...)))) (define (debug:calc-verbosity vstr) (cond ((number? vstr) vstr) ((not (string? vstr)) 1) ;; ((string-match "^\\s*$" vstr) 1) (vstr (let ((debugvals (filter number? (map string->number (string-split vstr ","))))) (cond ((> (length debugvals) 1) debugvals) ((> (length debugvals) 0)(car debugvals)) (else 1)))) ((args:get-arg "-v") 2) ((args:get-arg "-q") 0) (else 1))) ;; check verbosity, #t is ok (define (debug:check-verbosity verbosity vstr) (if (not (or (number? verbosity) (list? verbosity))) |
︙ | ︙ | |||
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 | (define (debug:print n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () (if *logging* (db:log-event (apply conc params)) (apply print params) ))))) (define (debug:print-info n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () (let ((res (format#format #f "INFO: (~2d) ~a" n (apply conc params)))) (if *logging* (db:log-event res) (apply print "INFO: (" n ") " params) ;; res) )))))) ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) | > > | 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 | (define (debug:print n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () (if *logging* (db:log-event (apply conc params)) ;; (apply print "pid:" (current-process-id) " " params) (apply print params) ))))) (define (debug:print-info n . params) (if (debug:debug-mode n) (with-output-to-port (current-error-port) (lambda () (let ((res (format#format #f "INFO: (~2d) ~a" n (apply conc params)))) (if *logging* (db:log-event res) ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) (apply print "INFO: (" n ") " params) ;; res) )))))) ;; if a value is printable (i.e. string or number) return the value ;; else return an empty string (define-inline (printable val) (if (or (number? val)(string? val)) val "")) |
Modified configf.scm from [35104b9121] to [3684e66c72].
︙ | ︙ | |||
59 60 61 62 63 64 65 | (define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) (define configf:comment-rx (regexp "^\\s*#.*")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) ;; read a line and process any #{ ... } constructs (define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)")) | | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | (define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) (define configf:comment-rx (regexp "^\\s*#.*")) (define configf:cont-ln-rx (regexp "^(\\s+)(\\S+.*)$")) ;; read a line and process any #{ ... } constructs (define configf:var-expand-regex (regexp "^(.*)#\\{(scheme|system|shell|getenv|get|runconfigs-get|rget)\\s+([^\\}\\{]*)\\}(.*)")) (define (configf:process-line l ht allow-system) (let loop ((res l)) (if (string? res) (let ((matchdat (string-search configf:var-expand-regex res))) (if matchdat (let* ((prestr (list-ref matchdat 1)) (cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv (cmd (list-ref matchdat 3)) |
︙ | ︙ | |||
83 84 85 86 87 88 89 | (sect (car parts)) (var (cadr parts))) (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) | > > | | | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | (sect (car parts)) (var (cadr parts))) (conc "(lambda (ht)(config-lookup ht \"" sect "\" \"" var "\"))"))) ((runconfigs-get) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))")) (else "(lambda (ht)(print \"ERROR\") \"ERROR\")")))) ;; (print "fullcmd=" fullcmd) (if (or allow-system (not (member cmdtype '("system" "shell")))) (with-input-from-string fullcmd (lambda () (set! result ((eval (read)) ht)))) (set! result (conc "#{(" cmdtype ") " cmd "}"))) (loop (conc prestr result poststr))) res)) res))) ;; Run a shell command and return the output as a string (define (shell cmd) (let* ((output (cmd-run->list cmd)) (res (car output)) |
︙ | ︙ | |||
115 116 117 118 119 120 121 | (define (runconfigs-get config var) (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) (if targ (or (configf:lookup config targ var) (configf:lookup config "default" var)) (configf:lookup config "default" var)))) | > > | | | > | > | > > | 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 | (define (runconfigs-get config var) (let ((targ (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) (if targ (or (configf:lookup config targ var) (configf:lookup config "default" var)) (configf:lookup config "default" var)))) ;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ... ;; (define (configf:read-line p ht allow-processing) (let loop ((inl (read-line p))) (let ((cont-line (and (string? inl) (not (string-null? inl)) (equal? "\\" (string-take-right inl 1))))) (if cont-line ;; last character is \ (let ((nextl (read-line p))) (if (not (eof-object? nextl)) (loop (string-append (if cont-line (string-take inl (- (string-length inl) 1)) inl) nextl)))) (case allow-processing ;; if (and allow-processing ;; (not (eq? allow-processing 'return-string))) ((#t #f) (configf:process-line inl ht allow-processing)) ((return-string) inl) (else (configf:process-line inl ht allow-processing))))))) ;; read a config file, returns hash table of alists ;; read a config file, returns hash table of alists ;; adds to ht if given (must be #f otherwise) ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly |
︙ | ︙ | |||
203 204 205 206 207 208 209 | " output: " cmdres) (exit 1))) (if (null? res) "" (string-intersperse res " ")))))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist | | < < < | | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 | " output: " cmdres) (exit 1))) (if (null? res) "" (string-intersperse res " ")))))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key (case allow-system ((return-procs) val-proc) ((return-string) cmd) (else (val-proc))))) (loop (configf:read-line inp res allow-system) curr-section-name #f #f)) (loop (configf:read-line inp res allow-system) curr-section-name #f #f))) (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist (hash-table-ref/default res curr-section-name '())) (envar (and environ-patt (string-search (regexp environ-patt) curr-section-name))) (realval (if envar (config:eval-string-in-environment val) val))) (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name) (if envar (safe-setenv key realval)) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key realval)) (loop (configf:read-line inp res allow-system) curr-section-name key #f))) (configf:key-no-val ( x key val) (let* ((alist (hash-table-ref/default res curr-section-name '()))) (hash-table-set! res curr-section-name (config:assoc-safe-add alist key #t)) (loop (configf:read-line inp res allow-system) curr-section-name key #f))) |
︙ | ︙ |
Modified dashboard-tests.scm from [a4ddccb773] to [224dddeb50].
︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) (declare (uses ezsteps)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") ;;====================================================================== ;; C O M M O N ;;====================================================================== (define (dtests:get-pre-command #!key (default-override #f)) (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) (or cfg-ovrd default-override "xterm -geometry 180x20 -e \""))) (define (dtests:get-post-command #!key (default-override #f)) (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) | > > > > > | 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 | (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (unit dashboard-tests)) (declare (uses common)) (declare (uses db)) (declare (uses gutils)) (declare (uses rmt)) (declare (uses ezsteps)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") ;;====================================================================== ;; C O M M O N ;;====================================================================== (define *dashboard-comment-share-slot* #f) (define (dtests:get-pre-command #!key (default-override #f)) (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command"))) (or cfg-ovrd default-override "xterm -geometry 180x20 -e \""))) (define (dtests:get-post-command #!key (default-override #f)) (let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command"))) |
︙ | ︙ | |||
123 124 125 126 127 128 129 | (append (map (lambda (val) (iup:label val ; #:expand "HORIZONTAL" )) (list "Author: " "Owner: " "Reviewed: " "Tags: " | | < | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | (append (map (lambda (val) (iup:label val ; #:expand "HORIZONTAL" )) (list "Author: " "Owner: " "Reviewed: " "Tags: " "Description: ")) (list (iup:label "" #:expand "VERTICAL")))) (apply iup:vbox ; #:expand "YES" (list (store-meta "author" (iup:label (db:testmeta-get-author testmeta) #:expand "HORIZONTAL") (lambda (testmeta)(db:testmeta-get-author testmeta))) (store-meta "owner" |
︙ | ︙ | |||
150 151 152 153 154 155 156 | (test-meta-panel-get-description testmeta))) ))))) ;;====================================================================== ;; Run info panel ;;====================================================================== | | | | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | (test-meta-panel-get-description testmeta))) ))))) ;;====================================================================== ;; Run info panel ;;====================================================================== (define (run-info-panel db keydat testdat runname) (let* ((run-id (db:test-get-run_id testdat)) (rundat (db:get-run-info db run-id)) (header (db:get-header rundat)) (event_time (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "event_time"))) (iup:frame #:title "Megatest Run Info" ; #:expand "YES" (iup:hbox ; #:expand "YES" (apply iup:vbox ; #:expand "YES" (append (map (lambda (keyval) |
︙ | ︙ | |||
192 193 194 195 196 197 198 | (iup:label val ; #:expand "HORIZONTAL" )) (list "Hostname: " "Uname -a: " "Disk free: " "CPU Load: " "Run duration: " | | > > | > > | | | > > > > | > | | | | | | | 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 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 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 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 313 314 315 316 317 318 319 | (iup:label val ; #:expand "HORIZONTAL" )) (list "Hostname: " "Uname -a: " "Disk free: " "CPU Load: " "Run duration: " "Logfile: " "Top process id: ")) (iup:label "" #:expand "VERTICAL"))) (apply iup:vbox ; #:expand "YES" (list ;; NOTE: Yes, the host can change! (store-label "HostName" (iup:label ;; (sdb:qry 'getstr (db:test-get-host testdat) ;; ) #:expand "HORIZONTAL") (lambda (testdat)(db:test-get-host testdat))) (store-label "Uname" (iup:label " " #:expand "HORIZONTAL") (lambda (testdat) ;; (sdb:qry 'getstr (db:test-get-uname testdat))) ;; ) (store-label "DiskFree" (iup:label (conc (db:test-get-diskfree testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-diskfree testdat)))) (store-label "CPULoad" (iup:label (conc (db:test-get-cpuload testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-cpuload testdat)))) (store-label "RunDuration" (iup:label (conc (seconds->hr-min-sec (db:test-get-run_duration testdat))) #:expand "HORIZONTAL") (lambda (testdat)(conc (seconds->hr-min-sec (db:test-get-run_duration testdat))))) (store-label "LogFile" (iup:label (conc (db:test-get-final_logf testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-final_logf testdat)))) (store-label "ProcessId" (iup:label (conc (db:test-get-process_id testdat)) #:expand "HORIZONTAL") (lambda (testdat)(conc (db:test-get-process_id testdat)))) ))))) ;; use a global for setting the buttons colors ;; state status teststeps (define *state-status* (vector #f #f #f)) (define (update-state-status-buttons testdat) (let* ((state (db:test-get-state testdat)) (status (db:test-get-status testdat)) (color (car (gutils:get-color-for-state-status state status)))) ((vector-ref *state-status* 0) state color) ((vector-ref *state-status* 1) status color))) (define *dashboard-test-db* #t) (define *dashboard-comment-share-slot* #f) ;;====================================================================== ;; Set fields ;;====================================================================== (define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f)) (let ((newcomment #f) (newstatus #f) (newstate #f) (wtxtbox #f)) (iup:frame #:title "Set fields" (iup:vbox (iup:hbox (iup:label "Comment:") (let ((txtbox (iup:textbox #:action (lambda (val a b) (rmt:test-set-state-status-by-id run-id test-id #f #f b) ;; IDEA: Just set a variable with the proc to call? (rmt:test-set-state-status-by-id run-id test-id #f #f b) (set! newcomment b)) #:value (db:test-get-comment testdat) #:expand "HORIZONTAL"))) (set! wtxtbox txtbox) txtbox)) (apply iup:hbox (iup:label "STATE:" #:size "30x") (let* ((btns (map (lambda (state) (let ((btn (iup:button state #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) (rmt:test-set-state-status-by-id run-id test-id state #f #f) (db:test-set-state! testdat state))))) btn)) (map cadr *common:std-states*)))) ;; (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "KILLED" "KILLREQ")))) (vector-set! *state-status* 0 (lambda (state color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name state) color "192 192 192"))) (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) (iup:attribute-set! btn "BGCOLOR" newcolor)))) btns))) btns)) (apply iup:hbox (iup:label "STATUS:" #:size "30x") (let* ((btns (map (lambda (status) (let ((btn (iup:button status #:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10" #:action (lambda (x) (let ((t (iup:attribute x "TITLE"))) (if (equal? t "WAIVED") (iup:show (dashboard-tests:waiver run-id testdat (if wtxtbox (iup:attribute wtxtbox "VALUE") #f) (lambda (c) (set! newcomment c) (if wtxtbox (begin (iup:attribute-set! wtxtbox "VALUE" c) (if (not *dashboard-comment-share-slot*) (set! *dashboard-comment-share-slot* wtxtbox))) )))) (begin (rmt:test-set-state-status-by-id run-id test-id #f status #f) (db:test-set-status! testdat status)))))))) btn)) (map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP")))) (vector-set! *state-status* 1 (lambda (status color) (for-each (lambda (btn) (let* ((name (iup:attribute btn "TITLE")) (newcolor (if (equal? name status) color "192 192 192"))) (if (not (colors-similar? newcolor (iup:attribute btn "BGCOLOR"))) |
︙ | ︙ | |||
338 339 340 341 342 343 344 | (conc "ezstep run from step " stepname))))) ;; (iup:button "Refresh test data" ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 | (conc "ezstep run from step " stepname))))) ;; (iup:button "Refresh test data" ;; #:expand "HORIZONTAL" ;; #:action (lambda (obj) ;; (print "Refresh test data " stepname)) ))) (define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) (comnt (iup:textbox #:action (lambda (val a b) (if wpatt (if (string-match wregx b) (iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt)) |
︙ | ︙ | |||
370 371 372 373 374 375 376 | #:expand "HORIZONTAL" #:action (lambda (obj) (let ((comment (iup:attribute comnt "VALUE")) (test-id (db:test-get-id testdat))) (if (or (not wpatt) (string-match wregx comment)) (begin | | > | | | | | | | | > | | | 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 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 | #:expand "HORIZONTAL" #:action (lambda (obj) (let ((comment (iup:attribute comnt "VALUE")) (test-id (db:test-get-id testdat))) (if (or (not wpatt) (string-match wregx comment)) (begin (rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment) (db:test-set-status! testdat "WAIVED") (cmtcmd comment) (iup:destroy! dlog)))))) (iup:button "Cancel" #:expand "HORIZONTAL" #:action (lambda (obj) (iup:destroy! dlog))))))) dlog)) ;;====================================================================== ;; ;;====================================================================== (define (examine-test run-id test-id) ;; run-id run-key origtest) (let* ((db-path (db:dbfile-path run-id)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db")) (dbstruct (make-dbr:dbstruct path: (configf:lookup *configdat* "setup" "linktree") local: #t)) (testdat (db:get-test-info-by-id dbstruct run-id test-id)) (db-mod-time 0) ;; (file-modification-time db-path)) (last-update 0) ;; (current-seconds)) (request-update #t)) (if (not testdat) (begin (debug:print 2 "ERROR: No test data found for test " test-id ", exiting") (exit 1)) (let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f)) (keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f)) (rundat (if testdat (db:get-run-info dbstruct run-id) #f)) (runname (if testdat (db:get-value-by-header (db:get-rows rundat) (db:get-header rundat) "runname") #f)) (tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id)) ;; These next two are intentional bad values to ensure errors if they should not ;; get filled in properly. (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found (teststeps (if testdat (dcommon:get-compressed-steps dbstruct run-id test-id) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) (testmeta (if testdat (let ((tm (db:testmeta-get-record dbstruct testname))) (if tm tm (make-db:testmeta))) (make-db:testmeta))) (keystring (string-intersperse (map (lambda (keyval) ;; (conc ":" (car keyval) " " (cadr keyval))) (cadr keyval)) |
︙ | ︙ | |||
450 451 452 453 454 455 456 | (refreshdat (lambda () (let* ((curr-mod-time (max (file-modification-time db-path) (if (file-exists? testdat-path) (file-modification-time testdat-path) (begin (set! testdat-path (conc rundir "/testdat.db")) 0)))) | | | < | < < < < < < < < < < < < | < < < < | > | | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 | (refreshdat (lambda () (let* ((curr-mod-time (max (file-modification-time db-path) (if (file-exists? testdat-path) (file-modification-time testdat-path) (begin (set! testdat-path (conc rundir "/testdat.db")) 0)))) (need-update (or (and (>= curr-mod-time db-mod-time) (> (current-milliseconds)(+ last-update 250))) ;; every half seconds if db touched (> (current-milliseconds)(+ last-update 10000)) ;; force update even 10 seconds request-update)) (newtestdat (if need-update ;; NOTE: BUG HIDER, try to eliminate this exception handler (handle-exceptions exn (debug:print-info 0 "test db access issue in examine test for run-id " run-id ", test-id " test-id ": " ((condition-property-accessor 'exn 'message) exn)) (db:get-test-info-by-id dbstruct run-id test-id ))))) ;; (debug:print-info 0 "need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) (set! teststeps (dcommon:get-compressed-steps dbstruct run-id test-id)) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 "INFO: teststeps=" (intersperse teststeps "\n ")) ;; I don't see why this was implemented this way. Please comment it ... ;; (if (eq? curr-mod-time db-mod-time) ;; do only once if same ;; (set! db-mod-time (+ curr-mod-time 1)) ;; (set! db-mod-time curr-mod-time)) |
︙ | ︙ | |||
600 601 602 603 604 605 606 | ;; (test-set-status! db run-id test-name state status itemdat) (set! self ; (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title testfullname (iup:vbox ; #:expand "YES" ;; The run and test info (iup:hbox ; #:expand "YES" | | | | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 | ;; (test-set-status! db run-id test-name state status itemdat) (set! self ; (iup:dialog #:close_cb (lambda (a)(exit)) ; #:expand "YES" #:title testfullname (iup:vbox ; #:expand "YES" ;; The run and test info (iup:hbox ; #:expand "YES" (run-info-panel dbstruct keydat testdat runname) (test-info-panel testdat store-label widgets) (test-meta-panel testmeta store-meta)) (host-info-panel testdat store-label) ;; The controls (iup:frame #:title "Actions" (iup:vbox (iup:hbox (iup:button "View Log" #:action viewlog #:size "80x") (iup:button "Start Xterm" #:action xterm #:size "80x") (iup:button "Run Test" #:action run-test #:size "80x") (iup:button "Clean Test" #:action remove-test #:size "80x") (iup:button "CleanRunExecute!" #:action clean-run-execute #:size "80x") (iup:button "Kill All Jobs" #:action kill-jobs #:size "80x") (iup:button "Close" #:action (lambda (x)(exit)) #:size "80x")) (apply iup:hbox (list command-text-box command-launch-button)))) (set-fields-panel dbstruct run-id test-id testdat) (let ((tabs (iup:tabs ;; Replace here with matrix (let ((steps-matrix (iup:matrix #:font "Courier New, -8" #:expand "YES" #:scrollbar "YES" |
︙ | ︙ | |||
658 659 660 661 662 663 664 | (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 | (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) (dcommon:populate-steps teststeps steps-matrix)))) (hash-table-set! widgets "StepsMatrix" proc) (proc testdat)) steps-matrix) ;; populate the Test Data panel (iup:frame #:title "Test Data" (let ((test-data |
︙ | ︙ | |||
726 727 728 729 730 731 732 | (db:test-data-get-value x) (db:test-data-get-expected x) (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) | | | 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 | (db:test-data-get-value x) (db:test-data-get-expected x) (db:test-data-get-tol x) (db:test-data-get-status x) (db:test-data-get-units x) (db:test-data-get-type x) (db:test-data-get-comment x))) (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id #f tdb:read-test-data test-id "%"))) "\n"))) (if (not (equal? currval newval)) (iup:attribute-set! test-data "VALUE" newval ))))) ;; "TITLE" newval))))) test-data)) ;;(dashboard:run-controls) ))) (iup:attribute-set! tabs "TABTITLE0" "Steps") |
︙ | ︙ |
Modified dashboard.scm from [0b0b326b4f] to [6d6a8350b9].
︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 | ;; (declare (uses dashboard-main)) (declare (uses megatest-version)) (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " | > | | | | | > | 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 | ;; (declare (uses dashboard-main)) (declare (uses megatest-version)) (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "megatest-fossil-hash.scm") (define help (conc "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2014 Usage: dashboard [options] -h : this help -server host:port : connect to host:port instead of db access -test run-id,test-id : control test identified by testid -guimonitor : control panel for runs Misc -rows N : set number of rows ")) ;; process args (define remargs (args:get-args (argv) (list "-rows" "-run" "-test" "-debug" "-host" "-transport" ) (list "-h" "-use-server" "-guimonitor" "-main" "-v" "-q" |
︙ | ︙ | |||
81 82 83 84 85 86 87 | (exit))) (if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) | | | | | < < < < < | < < < | | | < < | 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 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | (exit))) (if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) (define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? *db-file-path*))) (define toplevel #f) (define dlg #f) (define max-test-num 0) (define *keys* (db:get-keys *dbstruct-local*)) (define *dbkeys* (append *keys* (list "runname"))) (define *header* #f) (define *allruns* '()) (define *allruns-by-id* (make-hash-table)) ;; (define *runchangerate* (make-hash-table)) (define *buttondat* (make-hash-table)) ;; <run-id color text test run-key> (define *alltestnamelst* '()) (define *searchpatts* (make-hash-table)) (define *num-runs* 8) (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) ;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%")) ;; Update management ;; (define *last-update* (current-seconds)) (define *last-db-update-time* 0) (define *please-update-buttons* #t) (define *delayed-update* 0) (define *update-is-running* #f) (define *update-mutex* (make-mutex)) (define *all-item-test-names* '()) (define *num-tests* 15) (define *start-run-offset* 0) (define *start-test-offset* 0) (define *examine-test-dat* (make-hash-table)) (define *exit-started* #f) (define *status-ignore-hash* (make-hash-table)) (define *state-ignore-hash* (make-hash-table)) (define *tests-sort-options* (vector (vector "Sort +a" 'testname "ASC") (vector "Sort -a" 'testname "DESC") (vector "Sort +t" 'event_time "ASC") (vector "Sort -t" 'event_time "DESC") (vector "Sort +s" 'statestatus "ASC") (vector "Sort -s" 'statestatus "DESC") (vector "Sort +a" 'testname "ASC"))) |
︙ | ︙ | |||
215 216 217 218 219 220 221 | (c2 (map string->number (string-split color2))) (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt keypatts) (let* ((referenced-run-ids '()) | | | > | | | | | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | (c2 (map string->number (string-split color2))) (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt keypatts) (let* ((referenced-run-ids '()) (allruns (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) *start-run-offset* keypatts)) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) (states (hash-table-keys *state-ignore-hash*)) (statuses (hash-table-keys *status-ignore-hash*)) (sort-info (get-curr-sort)) (sort-by (vector-ref sort-info 1)) (sort-order (vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) 'testname 'itempath))) ;; ;; trim runs to only those that are changing often here ;; (for-each (lambda (run) (let* ((run-id (db:get-value-by-header run header "id")) (tests (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses #f #f *hide-not-hide* sort-by sort-order 'shortlist)) ;; NOTE: bubble-up also sets the global *all-item-test-names* ;; (tests (bubble-up tmptests priority: bubble-type)) (key-vals (db:get-key-vals *dbstruct-local* run-id))) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (set! referenced-run-ids (cons run-id referenced-run-ids)) (if (> (length tests) maxtests) (set! maxtests (length tests))) (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set |
︙ | ︙ | |||
478 479 480 481 482 483 484 | (car matching)))) (testname (db:test-get-testname test)) (itempath (db:test-get-item-path test)) (testfullname (test:test-get-fullname test)) (teststatus (db:test-get-status test)) (teststate (db:test-get-state test)) ;;(teststart (db:test-get-event_time test)) | | | 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 | (car matching)))) (testname (db:test-get-testname test)) (itempath (db:test-get-item-path test)) (testfullname (test:test-get-fullname test)) (teststatus (db:test-get-status test)) (teststate (db:test-get-state test)) ;;(teststart (db:test-get-event_time test)) ;;(runtime (db:test-get-run_duration test)) (buttontxt (cond ((equal? teststate "COMPLETED") teststatus) ((and (equal? teststate "NOT_STARTED") (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) teststatus) (else teststate))) |
︙ | ︙ | |||
577 578 579 580 581 582 583 | (if (not (null? values)) (let ((newval (car values))) (iup:attribute-set! lb "VALUE" newval) newval)))))) (define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) | | | 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 | (if (not (null? values)) (let ((newval (car values))) (iup:attribute-set! lb "VALUE" newval) newval)))))) (define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) (db-target-dat (db:get-targets *dbstruct-local*)) (header (vector-ref db-target-dat 0)) (db-targets (vector-ref db-target-dat 1)) (all-targets (append db-targets (map (lambda (x) (list->vector (take (append (string-split x "/") (make-list (length header) "na")) |
︙ | ︙ | |||
809 810 811 812 813 814 815 | #:dropdown "YES" #:action (lambda (obj val index lbstate) (iup:attribute-set! tb "VALUE" val) (dboard:data-set-run-name! *data* val) (dashboard:update-run-command)))) (refresh-runs-list (lambda () (let* ((target (dboard:data-get-target-string *data*)) | | | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 | #:dropdown "YES" #:action (lambda (obj val index lbstate) (iup:attribute-set! tb "VALUE" val) (dboard:data-set-run-name! *data* val) (dashboard:update-run-command)))) (refresh-runs-list (lambda () (let* ((target (dboard:data-get-target-string *data*)) (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f)) (runs-header (vector-ref runs-for-targ 0)) (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) runs-dat)))) (iup:attribute-set! lb "REMOVEITEM" "ALL") |
︙ | ︙ | |||
858 859 860 861 862 863 864 | combos))) (iup:hbox ;; Text box for STATES (iup:frame #:title "States" (dashboard:text-list-toggle-box ;; Move these definitions to common and find the other useages and replace! | | | | 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 | combos))) (iup:hbox ;; Text box for STATES (iup:frame #:title "States" (dashboard:text-list-toggle-box ;; Move these definitions to common and find the other useages and replace! (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") (lambda (all) (dboard:data-set-states! *data* all) (dashboard:update-run-command)))) ;; Text box for STATES (iup:frame #:title "Statuses" (dashboard:text-list-toggle-box (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") (lambda (all) (dboard:data-set-statuses! *data* all) (dashboard:update-run-command)))))))) (iup:frame #:title "Tests and Tasks" (let* ((updater #f) |
︙ | ︙ | |||
980 981 982 983 984 985 986 | ;; ))) ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area | | | | > | > > > | | | | | | 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 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 1027 1028 1029 1030 1031 1032 | ;; ))) ;;====================================================================== ;; S U M M A R Y ;;====================================================================== ;; ;; General info about the run(s) and megatest area (define (dashboard:summary db) (let ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f))) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string))) (iup:vbox (iup:split #:value 500 (iup:frame #:title "General Info" (iup:vbox (iup:hbox (iup:label "Area Path") (iup:textbox #:value *toppath* #:expand "HORIZONTAL")) (iup:hbox (dcommon:keys-matrix rawconfig) (dcommon:general-info) ))) (iup:frame #:title "Server" (dcommon:servers-table))) (iup:frame #:title "Megatest config settings" (iup:hbox (dcommon:section-matrix rawconfig "setup" "Varname" "Value") (iup:vbox (dcommon:section-matrix rawconfig "server" "Varname" "Value") ;; (iup:frame ;; #:title "Disks Areas" (dcommon:section-matrix rawconfig "disks" "Disk area" "Path")))) (iup:frame #:title "Run statistics" (dcommon:run-stats db))))) ;;====================================================================== ;; R U N ;;====================================================================== ;; ;; display and manage a single run at a time (define (tree-path->run-id path) (if (not (null? path)) (hash-table-ref/default (dboard:data-get-path-run-ids *data*) path #f) #f)) (define dashboard:update-run-summary-tab #f) ;; (define (tests window-id) (define (dashboard:one-run db) (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) |
︙ | ︙ | |||
1046 1047 1048 1049 1050 1051 1052 | (run-matrix (iup:matrix #:expand "YES" #:click-cb (lambda (obj lin col status) (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) | | | | > | > | | 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 | (run-matrix (iup:matrix #:expand "YES" #:click-cb (lambda (obj lin col status) (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&"))) (system cmd))))) (updater (lambda () (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:data-get-curr-run-id *data*)) (tests-dat (let ((tdat (db:get-tests-for-run db run-id (hash-table-ref/default *searchpatts* "test-name" "%/%") (hash-table-keys *state-ignore-hash*) ;; '() (hash-table-keys *status-ignore-hash*) ;; '() #f #f *hide-not-hide* #f #f "id,testname,item_path,state,status"))) ;; get 'em all (sort tdat (lambda (a b) (let* ((aval (vector-ref a 2)) (bval (vector-ref b 2)) (anum (string->number aval)) (bnum (string->number bval))) (if (and anum bnum) (< anum bnum) |
︙ | ︙ | |||
1178 1179 1180 1181 1182 1183 1184 | tb run-matrix))) ;;====================================================================== ;; R U N S ;;====================================================================== | | | 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 | tb run-matrix))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (make-dashboard-buttons db nruns ntests keynames) (let* ((nkeys (length keynames)) (runsvec (make-vector nruns)) (header (make-vector nruns)) (lftcol (make-vector ntests)) (keycol (make-vector ntests)) (controls '()) (lftlst '()) |
︙ | ︙ | |||
1234 1235 1236 1237 1238 1239 1240 | (let ((hideit (iup:button "HideTests" #:action (lambda (obj) (set! *hide-not-hide* (not *hide-not-hide*)) (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) (mark-for-update))))) (set! *hide-not-hide-button* hideit) hideit)) (iup:hbox | | > > | 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 | (let ((hideit (iup:button "HideTests" #:action (lambda (obj) (set! *hide-not-hide* (not *hide-not-hide*)) (iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide")) (mark-for-update))))) (set! *hide-not-hide-button* hideit) hideit)) (iup:hbox (iup:button "Quit" #:action (lambda (obj) ;; (if *dbstruct-local* (db:close-all *dbstruct-local*)) (exit))) (iup:button "Refresh" #:action (lambda (obj) (mark-for-update))) (iup:button "Collapse" #:action (lambda (obj) (let ((myname (iup:attribute obj "TITLE"))) (if (equal? myname "Collapse") (begin (for-each (lambda (tname) |
︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 | (map (lambda (status) (iup:toggle status #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) (hash-table-set! *status-ignore-hash* status #t) (hash-table-delete! *status-ignore-hash* status)) (set-bg-on-filter)))) | | | | 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 | (map (lambda (status) (iup:toggle status #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) (hash-table-set! *status-ignore-hash* status #t) (hash-table-delete! *status-ignore-hash* status)) (set-bg-on-filter)))) (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) (apply iup:hbox (map (lambda (state) (iup:toggle state #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) (hash-table-set! *state-ignore-hash* state #t) (hash-table-delete! *state-ignore-hash* state)) (set-bg-on-filter)))) (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) (maxruns *tot-run-count*)) (set! *start-run-offset* val) (mark-for-update) (debug:print 6 "*start-run-offset* " *start-run-offset* " maxruns: " maxruns ", val: " val " oldmax: " oldmax) |
︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 | #:size "60x15" #:expand "HORIZONTAL" #:fontsize "10" #:action (lambda (x) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref *buttondat* button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) | > | | 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 | #:size "60x15" #:expand "HORIZONTAL" #:fontsize "10" #:action (lambda (x) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref *buttondat* button-key)) (test-id (db:test-get-id (vector-ref buttndat 3))) (run-id (db:test-get-run_id (vector-ref buttndat 3))) (cmd (conc toolpath " -test " run-id "," test-id "&"))) ;(print "Launching " cmd) (system cmd)))))) (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) (loop runnum (+ testnum 1) testvec (cons butn res)))))) ;; now assemble the hdrlst and bdylst and kick off the dialog (iup:show |
︙ | ︙ | |||
1400 1401 1402 1403 1404 1405 1406 | (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) controls)) (tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) (set! *please-update-buttons* #t) (set! *current-tab-number* curr)) | | | | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 | (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) controls)) (tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) (set! *please-update-buttons* #t) (set! *current-tab-number* curr)) (dashboard:summary db) runs-view (dashboard:one-run db) (dashboard:run-controls) ))) ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Summary") (iup:attribute-set! tabs "TABTITLE1" "Runs") (iup:attribute-set! tabs "TABTITLE2" "Run Summary") (iup:attribute-set! tabs "TABTITLE3" "Run Control") |
︙ | ︙ | |||
1430 1431 1432 1433 1434 1435 1436 | (define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... ;; | | | | | | | > > > > > > > > > | | 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 | (define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... ;; (define *last-db-update-time* (file-modification-time *db-file-path*)) ;; (conc *toppath* "/db/main.db"))) (define *last-recalc-ended-time* 0) (define (dashboard:been-changed) (> (file-modification-time *db-file-path*) *last-db-update-time*)) (define (dashboard:set-db-update-time) (set! *last-db-update-time* (file-modification-time *db-file-path*))) (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 *dbdir* "/monitor.db")) (define *last-monitor-update-time* 0) ;; Force creation of the db in case it isn't already there. (tasks:open-db) (define (dashboard:get-youngest-run-db-mod-time) (handle-exceptions exn (begin (debug:print 0 "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn)) (current-seconds)) ;; something went wrong - just print an error and return current-seconds (apply max (map (lambda (filen) (file-modification-time filen)) (glob (conc *dbdir* "/*.db")))))) (define (dashboard:run-update x) (let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*)) (monitor-modtime (if (file-exists? *monitor-db-path*) (file-modification-time *monitor-db-path*) -1)) (run-update-time (current-seconds)) (recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*))) (if (and (eq? *current-tab-number* 0) (> monitor-modtime *last-monitor-update-time*)) |
︙ | ︙ | |||
1506 1507 1508 1509 1510 1511 1512 | (cond ((args:get-arg "-run") (let ((runid (string->number (args:get-arg "-run")))) (if runid (begin (lambda (x) | | < | | | > > | > | | | | | | 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 | (cond ((args:get-arg "-run") (let ((runid (string->number (args:get-arg "-run")))) (if runid (begin (lambda (x) (on-exit std-exit-procedure) (examine-run *dbstruct-local* runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (map string->number (string-split (args:get-arg "-test") ","))) (run-id (car dat)) (test-id (cadr dat))) (if (and (number? run-id) (number? test-id) (>= test-id 0)) (examine-test run-id test-id) (begin (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") (gui-monitor *dbstruct-local*)) (else (set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) (let ((update-is-running #f)) (mutex-lock! *update-mutex*) (set! update-is-running *update-is-running*) (if (not update-is-running) |
︙ | ︙ | |||
1562 1563 1564 1565 1566 1567 1568 | ;; (if (not *please-update-buttons*) ;; (loop)))))) (th2 (make-thread iup:main-loop "Main loop"))) (thread-start! th1) (thread-start! th2) (thread-join! th2)) | | | 1575 1576 1577 1578 1579 1580 1581 1582 | ;; (if (not *please-update-buttons*) ;; (loop)))))) (th2 (make-thread iup:main-loop "Main loop"))) (thread-start! th1) (thread-start! th2) (thread-join! th2)) ;; (iup:main-loop)(db:close-all *dbstruct-local*) |
Deleted datashare-testing/.datashare.config version [1d9aef34b1].
|
| < < < < < < < < < < < < < < < < < < < |
Added datashare-testing/.sd.config version [3db28d187c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # Read in the users vars first (so the offical data cannot be overridden [include ~/.datashare.config] # Read in local overrides [include datashare.config] # Replace [storage] with settings entry - more secure [settings] storage /tmp/#{getenv USER}/datashare/disk1 \ /tmp/#{getenv USER}/datashare/disk2 basepath #{getenv BASEPATH} [areas] synthesis asic/synthesis verilog asic/verilog customlibs custom/oalibs megatest tools/megatest [quality] 0 untested 1 lightly tested 2 tested 3 full QA [database] location /tmp/#{getenv USER}/datashare [pathmaps] SHELF /tmp/#{getenv USER}/theshelf [buildmethods] customlibs make setup;make install |
Modified datashare.scm from [c941a31a14] to [2abd8aec1c].
︙ | ︙ | |||
28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | (use canvas-draw) (import canvas-draw-iup) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (uses configf)) (include "megatest-fossil-hash.scm") ;; ;; GLOBALS ;; (define *datashare:current-tab-number* 0) (define datashare:help (conc "Usage: datashare [action [params ...]] Note: run datashare without parameters to start the gui. | > > > > > > > > > > > | | | > > | > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > | > | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 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 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 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 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 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | (use canvas-draw) (import canvas-draw-iup) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) (declare (uses configf)) (declare (uses tree)) (declare (uses margs)) ;; (declare (uses dcommon)) ;; (declare (uses launch)) ;; (declare (uses gutils)) ;; (declare (uses db)) ;; (declare (uses synchash)) ;; (declare (uses server)) ;; (declare (uses megatest-version)) ;; (declare (uses tbd)) (include "megatest-fossil-hash.scm") ;; ;; GLOBALS ;; (define *datashare:current-tab-number* 0) (define *args-hash* (make-hash-table)) (define datashare:help (conc "Usage: datashare [action [params ...]] Note: run datashare without parameters to start the gui. list-areas : List the allowed areas list-versions <area> : List versions available in <area> options : -full, -vpatt patt publish <path> <area> <version> : Publish data for area and with version get <area> <version> : Get a link to data, put the link in destpath options : -i iteration update <area> : Update the link to data to the latest iteration. Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest Version: " megatest-fossil-hash)) ;; " ;;====================================================================== ;; RECORDS ;;====================================================================== ;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment ;; testing (define (make-datashare:pkg)(make-vector 15)) (define-inline (datashare:pkg-get-id vec) (vector-ref vec 0)) (define-inline (datashare:pkg-get-area vec) (vector-ref vec 1)) (define-inline (datashare:pkg-get-version_name vec) (vector-ref vec 2)) (define-inline (datashare:pkg-get-store_type vec) (vector-ref vec 3)) (define-inline (datashare:pkg-get-copied vec) (vector-ref vec 4)) (define-inline (datashare:pkg-get-source_path vec) (vector-ref vec 5)) (define-inline (datashare:pkg-get-iteration vec) (vector-ref vec 6)) (define-inline (datashare:pkg-get-submitter vec) (vector-ref vec 7)) (define-inline (datashare:pkg-get-datetime vec) (vector-ref vec 8)) (define-inline (datashare:pkg-get-storegrp vec) (vector-ref vec 9)) (define-inline (datashare:pkg-get-datavol vec) (vector-ref vec 10)) (define-inline (datashare:pkg-get-quality vec) (vector-ref vec 11)) (define-inline (datashare:pkg-get-disk_id vec) (vector-ref vec 12)) (define-inline (datashare:pkg-get-comment vec) (vector-ref vec 13)) (define-inline (datashare:pkg-get-stored_path vec) (vector-ref vec 14)) (define-inline (datashare:pkg-set-id! vec val)(vector-set! vec 0 val)) (define-inline (datashare:pkg-set-area! vec val)(vector-set! vec 1 val)) (define-inline (datashare:pkg-set-version_name! vec val)(vector-set! vec 2 val)) (define-inline (datashare:pkg-set-store_type! vec val)(vector-set! vec 3 val)) (define-inline (datashare:pkg-set-copied! vec val)(vector-set! vec 4 val)) (define-inline (datashare:pkg-set-source_path! vec val)(vector-set! vec 5 val)) (define-inline (datashare:pkg-set-iteration! vec val)(vector-set! vec 6 val)) (define-inline (datashare:pkg-set-submitter! vec val)(vector-set! vec 7 val)) (define-inline (datashare:pkg-set-datetime! vec val)(vector-set! vec 8 val)) (define-inline (datashare:pkg-set-storegrp! vec val)(vector-set! vec 9 val)) (define-inline (datashare:pkg-set-datavol! vec val)(vector-set! vec 10 val)) (define-inline (datashare:pkg-set-quality! vec val)(vector-set! vec 11 val)) (define-inline (datashare:pkg-set-disk_id! vec val)(vector-set! vec 12 val)) (define-inline (datashare:pkg-set-comment! vec val)(vector-set! vec 13 val)) (define-inline (datashare:pkg-set-stored_path! vec val)(vector-set! vec 14 val)) ;;====================================================================== ;; DB ;;====================================================================== (define (datashare:initialize-db db) (for-each (lambda (qry) (sqlite3:execute db qry)) (list "CREATE TABLE pkgs (id INTEGER PRIMARY KEY, area TEXT, version_name TEXT, store_type TEXT DEFAULT 'copy', copied INTEGER DEFAULT 0, source_path TEXT, stored_path TEXT, iteration INTEGER DEFAULT 0, submitter TEXT, datetime TIMESTAMP DEFAULT (strftime('%s','now')), storegrp TEXT, datavol INTEGER, quality TEXT, disk_id INTEGER, comment TEXT);" "CREATE TABLE refs (id INTEGER PRIMARY KEY, pkg_id INTEGER, destlink TEXT);" "CREATE TABLE disks (id INTEGER PRIMARY KEY, storegrp TEXT, path TEXT);"))) (define (datashare:register-data db area version-name store-type submitter quality source-path comment) (let ((iter-qry (sqlite3:prepare db "SELECT max(iteration) FROM pkgs WHERE area=? AND version_name=?;")) (next-iteration 0)) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (iteration) (if (and (number? iteration) (>= iteration next-iteration)) (set! next-iteration (+ iteration 1)))) iter-qry area version-name) ;; now store the data (sqlite3:execute db "INSERT INTO pkgs (area,version_name,iteration,store_type,submitter,source_path,quality,comment) VALUES (?,?,?,?,?,?,?,?);" area version-name next-iteration (conc store-type) submitter source-path quality comment))) (sqlite3:finalize! iter-qry) next-iteration)) (define (datashare:get-id db area version-name iteration) (let ((res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) db "SELECT id FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" area version-name iteration) res)) (define (datashare:set-stored-path db id path) (sqlite3:execute db "UPDATE pkgs SET stored_path=? WHERE id=?;" path id)) (define (datashare:set-copied db id value) (sqlite3:execute db "UPDATE pkgs SET copied=? WHERE id=?;" value id)) (define (datashare:get-pkg-record db area version-name iteration) (let ((res #f)) (sqlite3:for-each-row (lambda (a . b) (set! res (apply vector a b))) db "SELECT * FROM pkgs WHERE area=? AND version_name=? AND iteration=?;" area version-name iteration) res)) ;; take version-name iteration and register or update "lastest/0" ;; (define (datashare:set-latest db id area version-name iteration) (let* ((rec (datashare:get-pkg-record db area version-name iteration)) (latest-id (datashare:get-id db area "latest" 0)) (stored-path (datashare:pkg-get-stored_path rec))) (if latest-id ;; have a record - bump the link pointer (datashare:set-stored-path db latest-id stored-path) (datashare:register-data db area "latest" 'link "auto" "na" stored-path "latest data")))) ;; set a package ref, this is the location where the link back to the stored data ;; is put. ;; ;; if there is nothing at that location then the record can be removed ;; if there are no refs for a particular pkg-id then that pkg-id is a ;; candidate for removal ;; (define (datashare:record-pkg-ref db pkg-id dest-link) (sqlite3:execute db "INSERT INTO refs (pkg_id,destlink) VALUES (?,?);" pkg-id dest-link)) (define (datashare:count-refs db pkg-id) (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) db "SELECT count(id) FROM refs WHERE pkg_id=?;" pkg-id) res)) ;; Create the sqlite db (define (datashare:open-db configdat) (let ((path (configf:lookup configdat "database" "location"))) (if (and path (directory? path) (file-read-access? path)) (let* ((dbpath (conc path "/datashare.db")) (writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath)) (handler (make-busy-timeout 136000))) (handle-exceptions exn (begin (debug:print 2 "ERROR: problem accessing db " dbpath ((condition-property-accessor 'exn 'message) exn)) (exit)) (set! db (sqlite3:open-database dbpath))) (if *db-write-access* (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (datashare:initialize-db db))) db) (print "ERROR: invalid path for storing database: " path)))) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn (let ((sleep-time (random 30)) (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status ((busy) (thread-sleep! sleep-time)) (else (print "EXCEPTION: database overloaded or unreadable.") (print " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (print " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) (thread-sleep! sleep-time) (print "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) (apply open-run-close-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) (define (open-run-close-no-exception-handling proc idb . params) ;; (print "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (let* ((db (cond ((sqlite3:database? idb) idb) ((not idb) (print "ERROR: cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) (else (print "ERROR: cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) (if (not idb)(sqlite3:finalize! dbstruct)) ;; (print "open-run-close-no-exception-handling END" ) res)) (define open-run-close open-run-close-no-exception-handling) (define (datashare:get-pkgs db area-filter version-filter iter-filter) (let ((res '())) (sqlite3:for-each-row ;; replace with fold ... (lambda (a . b) (set! res (cons (list->vector (cons a b)) res))) db (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " " FROM pkgs WHERE area like ? AND version_name LIKE ? AND iteration " iter-filter ";") area-filter version-filter) (reverse res))) (define (datashare:get-pkg db area-name version-name #!key (iteration #f)) (let ((dat '()) (res #f)) (sqlite3:for-each-row ;; replace with fold ... (lambda (a . b) (set! dat (cons (list->vector (cons a b)) dat))) db (conc "SELECT id,area,version_name,store_type,copied,source_path,iteration,submitter,datetime,storegrp,datavol,quality,disk_id,comment,stored_path " " FROM pkgs WHERE area=? AND version_name=? ORDER BY iteration ASC;") area-name version-name) ;; now filter for iteration, either max if #f or specific one (if (null? dat) #f (let loop ((hed (car dat)) (tal (cdr dat)) (cur 0)) (let ((itr (datashare:pkg-get-iteration hed))) (if (equal? itr iteration) ;; this is the one if iteration is specified hed (if (null? tal) hed (loop (car tal)(cdr tal))))))))) (define (datashare:get-versions-for-area db area-name #!key (version-patt #f)) (let ((res '()) (data (make-hash-table))) (sqlite3:for-each-row (lambda (version-name submitter iteration submitted-time comment) ;; 0 1 2 3 4 (hash-table-set! data version-name (vector version-name submitter iteration submitted-time comment))) db "SELECT version_name,submitter,iteration,datetime,comment FROM pkgs WHERE area='megatest' AND version_name != 'latest' AND version_name LIKE ? ORDER BY datetime asc;" (or version-patt "%")) (map (lambda (x)(hash-table-ref data x))(sort (hash-table-keys data) string-ci>=)))) ;;====================================================================== ;; DATA IMPORT/EXPORT ;;====================================================================== (define (datashare:import-data configdat source-path dest-path area version iteration) (let* ((space-avail (car dest-path)) (disk-path (cdr dest-path)) (targ-path (conc disk-path "/" area "/" version "/" iteration)) (id (datashare:get-id db area version iteration)) (db (datashare:open-db configdat))) (if (> space-avail 10000) ;; dumb heuristic (begin (create-directory targ-path #t) (datashare:set-stored-path db id targ-path) (print "Running command: rsync -av " source-path "/ " targ-path "/") (let ((th1 (make-thread (lambda () (let ((pid (process-run "rsync" (list "-av" (conc source-path "/") (conc targ-path "/"))))) (process-wait pid) (datashare:set-copied db id "yes") (sqlite3:finalize! db))) "Data copy"))) (thread-start! th1)) #t) (begin (print "ERROR: Not enough space in storage area " dest-path) (datashare:set-copied db id "no") (sqlite3:finalize! db) #f)))) (define (datashare:get-areas configdat) (let* ((areadat (configf:get-section configdat "areas")) (areas (if areadat (map car areadat) '()))) areas)) (define (datashare:publish configdat publish-type area-name version comment spath submitter quality) ;; input checks (cond ((not (member area-name (datashare:get-areas configdat))) (cons #f (conc "Illegal area name \"" area-name "\""))) (else (let ((db (datashare:open-db configdat)) (iteration (datashare:register-data db area-name version publish-type submitter quality spath comment)) (dest-store (datashare:get-best-storage configdat))) (if iteration (if (eq? 'copy publish-type) (begin (datashare:import-data configdat spath dest-store area-name version iteration) (let ((id (datashare:get-id db area-name version iteration))) (datashare:set-latest db id area-name version iteration))) (let ((id (datashare:get-id db area-name version iteration))) (datashare:set-stored-path db id spath) (datashare:set-copied db id "yes") (datashare:set-copied db id "n/a") (datashare:set-latest db id area-name version iteration))) (print "ERROR: Failed to get an iteration number")) (sqlite3:finalize! db) (cons #t "Successfully saved data"))))) (define (datashare:get-best-storage configdat) (let* ((storage (configf:lookup configdat "settings" "storage")) (store-areas (if storage (string-split storage) '()))) (print "Looking for available space in " store-areas) (datashare:find-most-space store-areas))) ;; (string->number (list-ref (with-input-from-pipe "df -B1000000 /tmp" (lambda ()(read-line)(string-split (read-line)))) 3)) (define (datashare:find-most-space paths) (fold (lambda (area res) ;; (print "area=" area " res=" res) (let ((maxspace (car res)) (currpath (cdr res))) ;; (print currpath " " maxspace) (if (file-write-access? area) (let ((currspace (string->number (list-ref (with-input-from-pipe ;; (conc "df --output=avail " area) (conc "df -B1000000 " area) ;; (lambda ()(read)(read)) (lambda ()(read-line)(string-split (read-line)))) 3)))) (if (> currspace maxspace) (cons currspace area) res)) res))) (cons 0 #f) paths)) ;; remove existing link and if possible ... ;; create path to next of tip of target, create link back to source (define (datashare:build-dir-make-link source target) (if (file-exists? target)(datashare:backup-move target)) (create-directory (pathname-directory target) #t) (create-symbolic-link source target)) (define (datashare:backup-move path) (let* ((trashdir (conc (pathname-directory path) "/.trash")) (trashfile (conc trashdir "/" (current-seconds) "-" (pathname-file path)))) (create-directory trashdir #t) (if (directory? path) (system (conc "mv " path " " trashfile)) (file-move path trash-file)))) ;;====================================================================== ;; GUI ;;====================================================================== ;; The main menu (define (datashare:main-menu) |
︙ | ︙ | |||
127 128 129 130 131 132 133 | ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current ;; ;; #:x 'mouse ;; ;; #:y 'mouse ;; ) )))) (define (datashare:publish-view configdat) | > > | | > > > | > | > > | | > > > > > > > > > > > > > > > > > > > > > | > > > > > > > | > | > | | | > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > | > > | > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 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 | ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current ;; ;; #:x 'mouse ;; ;; #:y 'mouse ;; ) )))) (define (datashare:publish-view configdat) ;; (pp (hash-table->alist configdat)) (let* ((areas (configf:get-section configdat "areas")) (label-size "70x") (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) (version-tb (iup:textbox #:expand "HORIZONTAL")) ;; #:size "50x")) (areas-sel (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES")) (component (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" )) (version-val (iup:textbox #:expand "HORIZONTAL" #:size "50x")) ;; (copy-link (iup:toggle #:expand "HORIZONTAL")) ;; (iteration (iup:textbox #:expand "YES" #:size "20x")) ;; (iteration (iup:textbox #:expand "HORIZONTAL" #:size "20x")) (area-filter (iup:textbox #:expand "HORIZONTAL" #:value "%")) (comment-tb (iup:textbox #:expand "YES" #:multiline "YES")) (source-tb (iup:textbox #:expand "HORIZONTAL" #:value (or (configf:lookup configdat "settings" "basepath") ""))) (publish (lambda (publish-type) (let* ((area-num (or (string->number (iup:attribute areas-sel "VALUE")) 0)) (area-dat (if (> area-num 0)(list-ref areas (- area-num 1))'("NOT SELECTED" "NOT SELECTED"))) (area-path (cadr area-dat)) (area-name (car area-dat)) (version (iup:attribute version-tb "VALUE")) (comment (iup:attribute comment-tb "VALUE")) (spath (iup:attribute source-tb "VALUE")) (submitter (current-user-name)) (quality 2)) (datashare:publish configdat publish-type area-name version comment spath submitter quality)))) (copy (iup:button "Copy and Publish" #:expand "HORIZONTAL" #:action (lambda (obj) (publish 'copy)))) (link (iup:button "Link and Publish" #:expand "HORIZONTAL" #:action (lambda (obj) (publish 'link)))) (browse-btn (iup:button "Browse" #:size "40x" #:action (lambda (obj) (let* ((fd (iup:file-dialog #:dialogtype "DIR")) (top (iup:show fd #:modal? "YES"))) (iup:attribute-set! source-tb "VALUE" (iup:attribute fd "VALUE")) (iup:destroy! fd)))))) (print "areas") ;; (pp areas) (fold (lambda (areadat num) ;; (print "Adding num=" num ", areadat=" areadat) (iup:attribute-set! areas-sel (conc num) (car areadat)) (+ 1 num)) 1 areas) (iup:vbox (iup:hbox (iup:label "Area:" #:size label-size) ;; area-filter areas-sel) (iup:hbox (iup:label "Version:" #:size label-size) version-tb) ;; (iup:hbox (iup:label "Link only" #:size label-size) copy-link) ;; (iup:label "Iteration:") iteration) (iup:hbox (iup:label "Comment:" #:size label-size) comment-tb) (iup:hbox (iup:label "Source base path:" #:size label-size) source-tb browse-btn) (iup:hbox copy link)))) (define (datashare:lst->path pathlst) (conc "/" (string-intersperse (map conc pathlst) "/"))) (define (datashare:path->lst path) (string-split path "/")) (define (datashare:pathdat-apply-heuristics configdat path) (cond ((file-exists? path) "found") (else (conc path " not installed")))) (define (datashare:get-view configdat) (iup:vbox (iup:hbox (let* ((label-size "60x") ;; filter elements (area-filter "%") (version-filter "%") (iter-filter ">= 0") ;; reverse lookup from path to data for src and installed (srcdat (make-hash-table)) ;; reverse lookup (installed-dat (make-hash-table)) ;; config values (basepath (configf:lookup configdat "settings" "basepath")) ;; gui elements (submitter (iup:label "" #:expand "HORIZONTAL")) (date-submitted (iup:label "" #:expand "HORIZONTAL")) (comment (iup:label "" #:expand "HORIZONTAL")) (copy-link (iup:label "" #:expand "HORIZONTAL")) (quality (iup:label "" #:expand "HORIZONTAL")) (installed-status (iup:label "" #:expand "HORIZONTAL")) ;; misc (curr-record #f) ;; (source-data (iup:label "" #:expand "HORIZONTAL")) (tb (iup:treebox #:value 0 #:name "Packages" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((path (datashare:lst->path (cdr (tree:node->path obj id)))) (record (hash-table-ref/default srcdat path #f))) (if record (begin (set! curr-record record) (iup:attribute-set! submitter "TITLE" (datashare:pkg-get-submitter record)) (iup:attribute-set! date-submitted "TITLE" (time->string (seconds->local-time (datashare:pkg-get-datetime record)))) (iup:attribute-set! comment "TITLE" (datashare:pkg-get-comment record)) (iup:attribute-set! quality "TITLE" (datashare:pkg-get-quality record)) (iup:attribute-set! copy-link "TITLE" (datashare:pkg-get-store_type record)) )) ;; (print "id=" id " path=" path " record=" record);; (tree:node->path obj id) " run-id: " run-id) )))) (tb2 (iup:treebox #:value 0 #:name "Installed" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((path (datashare:lst->path (cdr (tree:node->path obj id)))) (status (hash-table-ref/default installed-dat path #f))) (iup:attribute-set! installed-status "TITLE" (if status status "")) )))) (refresh (lambda (obj) (let* ((db (datashare:open-db configdat)) (areas (or (configf:get-section configdat "areas") '()))) ;; ;; first update the Sources ;; (for-each (lambda (pkgitem) (let* ((pkg-path (list (datashare:pkg-get-area pkgitem) (datashare:pkg-get-version_name pkgitem) (datashare:pkg-get-iteration pkgitem))) (pkg-id (datashare:pkg-get-id pkgitem)) (path (datashare:lst->path pkg-path))) ;; (print "tree:add-node tb=" tb ", pkg-path=" pkg-path ", pkg-id=" pkg-id) (if (not (hash-table-ref/default srcdat path #f)) (tree:add-node tb "Packages" pkg-path userdata: (conc "pkg-id: " pkg-id))) ;; (print "path=" path " pkgitem=" pkgitem) (hash-table-set! srcdat path pkgitem))) (datashare:get-pkgs db area-filter version-filter iter-filter)) ;; ;; then update the installed ;; (for-each (lambda (area) (let* ((path (conc "/" (cadr area))) (fullpath (conc basepath path))) (if (not (hash-table-ref/default installed-dat path #f)) (tree:add-node tb2 "Installed" (datashare:path->lst path))) (hash-table-set! installed-dat path (datashare:pathdat-apply-heuristics configdat fullpath)))) areas) (sqlite3:finalize! db)))) (apply (iup:button "Apply" #:action (lambda (obj) (if curr-record (let* ((area (datashare:pkg-get-area curr-record)) (stored-path (datashare:pkg-get-stored_path curr-record)) (source-type (datashare:pkg-get-store_type curr-record)) (source-path (case source-type ;; (equal? source-type "link")) ((link)(datashare:pkg-get-source-path curr-record)) ((copy)stored-path) (else #f))) (dest-stub (configf:lookup configdat "areas" area)) (target-path (conc basepath "/" dest-stub))) (datashare:build-dir-make-link stored-path target-path) (print "Creating link from " stored-path " to " target-path))))))) (iup:vbox (iup:hbox tb tb2) (iup:frame #:title "Source Info" (iup:vbox (iup:hbox (iup:button "Refresh" #:action refresh) apply) (iup:hbox (iup:label "Submitter: ") ;; #:size label-size) submitter (iup:label "Submitted on: ") ;; #:size label-size) date-submitted) (iup:hbox (iup:label "Data stored: ") copy-link (iup:label "Quality: ") quality) (iup:hbox (iup:label "Comment: ") comment))) (iup:frame #:title "Installed Info" (iup:vbox (iup:hbox (iup:label "Installed status/path: ") installed-status))) ))))) (define (datashare:manage-view configdat) (iup:vbox (iup:hbox (iup:button "Pushme" #:expand "YES" )))) |
︙ | ︙ | |||
181 182 183 184 185 186 187 188 189 190 191 192 | ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Publish") (iup:attribute-set! tabs "TABTITLE1" "Get") (iup:attribute-set! tabs "TABTITLE2" "Manage") ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190") tabs))) (iup:main-loop)) ;;====================================================================== ;; MAIN ;;====================================================================== | > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 | ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c))) (iup:attribute-set! tabs "TABTITLE0" "Publish") (iup:attribute-set! tabs "TABTITLE1" "Get") (iup:attribute-set! tabs "TABTITLE2" "Manage") ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190") tabs))) (iup:main-loop)) ;;====================================================================== ;; MISC ;;====================================================================== (define (datashare:do-as-calling-user proc) (let ((eid (current-effective-user-id)) (cid (current-user-id))) (if (not (eq? eid cid)) ;; running suid (set! (current-effective-user-id) cid)) ;; (print "running as " (current-effective-user-id)) (proc) (if (not (eq? eid cid)) (set! (current-effective-user-id) eid)))) (define (datashare:find name paths) (if (null? paths) #f (let loop ((hed (car paths)) (tal (cdr paths))) (if (file-exists? (conc hed "/" name)) hed (if (null? tal) #f (loop (car tal)(cdr tal))))))) ;;====================================================================== ;; MAIN ;;====================================================================== (define (datashare:load-config exe-dir exe-name) (let* ((fname (conc exe-dir "/." exe-name ".config"))) (ini:property-separator-patt " * *") (ini:property-separator #\space) (if (file-exists? fname) ;; (ini:read-ini fname) (read-config fname #f #t) (make-hash-table)))) (define (datashare:process-action configdat action . args) (case (string->symbol action) ((get) (if (< (length args) 2) (begin (print "ERROR: Missing arguments; " (string-intersperse args ", ")) (exit 1)) (let* ((basepath (configf:lookup configdat "settings" "basepath")) (db (datashare:open-db configdat)) (area (car args)) (version (cadr args)) ;; iteration (remargs (args:get-args args '("-i") '() args:arg-hash 0)) (iteration (if (args:get-arg "-i")(string->number (args:get-arg "-i")) #f)) (curr-record (datashare:get-pkg db area version iteration: iteration))) (if (not curr-record) (begin (print "ERROR: No matching record found; area=" area ", version=" version ", iteration=" (if iteration iteration "(max)")) (exit 1)) (let* ((stored-path (datashare:pkg-get-stored_path curr-record)) (source-type (datashare:pkg-get-store_type curr-record)) (source-path (case source-type ;; (equal? source-type "link")) ((link) (datashare:pkg-get-source-path curr-record)) ((copy) stored-path) (else #f))) (dest-stub (configf:lookup configdat "areas" area)) (target-path (conc basepath "/" dest-stub))) (datashare:build-dir-make-link stored-path target-path) (datashare:record-pkg-ref db (datashare:pkg-get-id curr-record) target-path) (sqlite3:finalize! db) (print "Creating link from " stored-path " to " target-path)))))) ((publish) (if (< (length args) 3) (begin (print "ERROR: Missing arguments; " (string-intersperse args ", ")) (exit 1)) (let* ((srcpath (list-ref args 0)) (areaname (list-ref args 1)) (version (list-ref args 2)) (remargs (args:get-args (drop args 2) '("-type" ;; link or copy (default is copy) "-m") '() args:arg-hash 0)) (publish-type (if (equal? (args:get-arg "-type") "link") 'link 'copy)) (comment (or (args:get-arg "-m") "")) (submitter (current-user-name)) (quality (args:get-arg "-quality")) (publish-res (datashare:publish configdat publish-type areaname version comment srcpath submitter quality))) (if (not (car publish-res)) (begin (print "ERROR: " (cdr publish-res)) (exit 1)))))) ((list-versions) (let ((area-name (car args)) ;; version patt full print (remargs (args:get-args args '("-vpatt") '("-full") args:arg-hash 0)) (db (datashare:open-db configdat)) (versions (datashare:get-versions-for-area db (car args) version-patt: (args:get-arg "-vpatt")))) ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*)) (map (lambda (x) (if (args:get-arg "-full") (format #t "~10a~10a~4a~27a~30a\n" (vector-ref x 0) (vector-ref x 1) (vector-ref x 2) (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"") (conc "\"" (vector-ref x 4) "\"")) (print (vector-ref x 0)))) versions) (sqlite3:finalize! db))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) (let* ((args (argv)) (prog (car args)) (rema (cdr args)) (exe-name (pathname-file (car (argv)))) (exe-dir (or (pathname-directory prog) (datashare:find exe-name (string-split (get-environment-variable "PATH") ":")))) (configdat (datashare:load-config exe-dir exe-name))) (cond ;; one-word commands ((eq? (length rema) 1) (case (string->symbol (car rema)) ((help -h -help --h --help) (print datashare:help)) ((list-areas) (map print (datashare:get-areas configdat))) (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))) ;; multi-word commands ((null? rema)(datashare:gui configdat)) ((>= (length rema) 2) (apply datashare:process-action configdat (car rema)(cdr rema))) (else (print "ERROR: Unrecognised command. Try \"datashare help\""))))) (main) |
Modified db.scm from [eb228185ab] to [cbd895f712].
︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; PURPOSE. ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== | | < < | < < < < > > > | > > > | > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > | > > > > | > > > > | > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > > > > > > > > | | > > > > | < < < > > | | > | > > > > > > > | > > > > > > > > > > | > > | > > | > > > > > > > > > > > > > > > | < | > > > > > | | > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | > > > > > > > > > > > | > > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > > > > > > > > > > > > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > | > > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | | | | | | | | < < | < < < < < | < < < < < < < < < < < < | < | > | < | | > | | | | | | | < < < < < < < < < < < < < < < | < < < < < < | | < | < | | < | | < | < < < | | < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | > | | | | | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | > < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > | | < < < | | | < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | > | | | | > > | > | > | > > > | < | > > > > | < | > | | | < | < | > > | < | > > | | | | | | < > > > > > | > > > > > | | | | | | | | | > > > > > | | | | | | | | | 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 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 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 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 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 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 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 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 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 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 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 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 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 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 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 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 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 1057 1058 1059 1060 1061 1062 1063 1064 1065 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 | ;; PURPOSE. ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== (require-extension (srfi 18) extras tcp) (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit db)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses client)) (declare (uses mt)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") (define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's (define *number-of-writes* 0) (define *number-non-write-queries* 0) ;;====================================================================== ;; SQLITE3 HELPERS ;;====================================================================== ;; convert to -inline (define (db:first-result-default db stmt default . params) (handle-exceptions exn (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) ;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn) (if (eq? err-status 'done) default (begin (debug:print 0 "ERROR: query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) default))) (apply sqlite3:first-result db stmt params))) ;; Get/open a database ;; if run-id => get run specific db ;; if #f => get main db ;; if db already open - return inmem ;; if db not open, open inmem, rundb and sync then return inmem ;; inuse gets set automatically for rundb's ;; (define (db:get-db dbstruct run-id) (if (sqlite3:database? dbstruct) ;; pass sqlite3 databases on through dbstruct (begin (mutex-lock! *rundb-mutex*) (let ((dbdat (if (or (not run-id) (eq? run-id 0)) (db:open-main dbstruct) (db:open-rundb dbstruct run-id) ))) ;; db prunning would go here (mutex-unlock! *rundb-mutex*) dbdat)))) (define (db:dbdat-get-db dbdat) (if (pair? dbdat) (car dbdat) dbdat)) (define (db:dbdat-get-path dbdat) (if (pair? dbdat) (cdr dbdat) #f)) ;; mod-read: ;; 'mod modified data ;; 'read read data ;; (define (db:done-with dbstruct run-id mod-read) (if (not (sqlite3:database? dbstruct)) (begin (mutex-lock! *rundb-mutex*) (if (eq? mod-read 'mod) (dbr:dbstruct-set-mtime! dbstruct (current-milliseconds)) (dbr:dbstruct-set-rtime! dbstruct (current-milliseconds))) (dbr:dbstruct-set-inuse! dbstruct #f) (mutex-unlock! *rundb-mutex*)))) ;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;") ;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no ;; (define (db:with-db dbstruct run-id r/w proc . params) (let* ((dbdat (if (vector? dbstruct) (db:get-db dbstruct run-id) dbstruct)) ;; cheat, allow for passing in a dbdat (db (db:dbdat-get-db dbdat))) (db:delay-if-busy dbdat) (handle-exceptions exn (begin (debug:print 0 "ERROR: sqlite3 issue in db:with-db, dbstruct=" dbstruct ", run-id=" run-id ", proc=" proc ", params=" params " error: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port))) (let ((res (apply proc db params))) (if (vector? dbstruct)(db:done-with dbstruct run-id r/w)) res)))) ;;====================================================================== ;; K E E P F I L E D B I N dbstruct ;;====================================================================== ;; (define (db:get-filedb dbstruct run-id) ;; (let ((db (vector-ref dbstruct 2))) ;; (if db ;; db ;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db")))) ;; (vector-set! dbstruct 2 fdb) ;; fdb)))) ;; ;; ;; Can also be used to save arbitrary strings ;; ;; ;; (define (db:save-path dbstruct path) ;; (let ((fdb (db:get-filedb dbstruct)))b ;; (filedb:register-path fdb path))) ;; ;; ;; Use to get a path. To get an arbitrary string see next define ;; ;; ;; (define (db:get-path dbstruct id) ;; (let ((fdb (db:get-filedb dbstruct))) ;; (filedb:get-path db id))) ;; NB// #f => zeroth db with name=main.db ;; (define (db:dbfile-path run-id) (let* (;; (toppath (dbr:dbstruct-get-path dbstruct)) (link-tree-path (configf:lookup *configdat* "setup" "linktree")) (fname (if (eq? run-id 0) "main.db" (conc run-id ".db"))) (dbdir (conc link-tree-path "/.db/"))) (handle-exceptions exn (begin (debug:print 0 "ERROR: Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) (conc dbdir fname))) (define (db:set-sync db) (let ((syncprag (configf:lookup *configdat* "setup" "sychronous"))) (sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 1) ";")))) ;; open an sql database inside a file lock ;; ;; returns: db existed-prior-to-opening ;; (define (db:lock-create-open fname initproc) (if (file-exists? fname) (let ((db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") db) (let* ((parent-dir (pathname-directory fname)) (dir-writable (file-write-access? parent-dir))) (if dir-writable (let ((exists (file-exists? fname)) (lock (obtain-dot-lock fname 1 5 10)) (db (sqlite3:open-database fname))) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") (if (not exists)(initproc db)) (release-dot-lock fname) db) (begin (debug:print 0 "ERROR: no such db in non-writable dir " fname) (sqlite3:open-database fname)))))) ;; This routine creates the db. It is only called if the db is not already opened ;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((local (dbr:dbstruct-get-local dbstruct)) (rdb (if local (dbr:dbstruct-get-localdb dbstruct run-id) (dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem))) (if (or rdb do-not-open) rdb (let* ((dbpath (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db")) (dbexists (file-exists? dbpath)) (inmem (if local #f (db:open-inmem-db))) (refdb (if local #f (db:open-inmem-db))) (db (db:lock-create-open dbpath ;; this is the database physically on disk (lambda (db) (handle-exceptions exn (begin (release-dot-lock dbpath) (if (> attemptnum 2) (debug:print 0 "ERROR: tried twice, cannot create/initialize db for run-id " run-id ", at path " dbpath) (db:open-rundb dbstruct run-id attemptnum (+ attemptnum 1)))) (db:initialize-run-id-db db) (sqlite3:execute db "INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');" (* run-id 30000) ;; allow for up to 30k tests per run run-id) ;; do a dummy query to test that the table exists and the db is truly readable (sqlite3:execute db "SELECT * FROM tests WHERE id=?;" (* run-id 30000)) )))) ;; add strings db to rundb, not in use yet ;; )) ;; (sqlite3:open-database dbpath)) (olddb (if *megatest-db* *megatest-db* (let ((db (db:open-megatest-db))) (set! *megatest-db* db) db))) (write-access (file-write-access? dbpath)) ;; (handler (make-busy-timeout 136000)) ) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) ;; only unset so other db's also can use this control (dbr:dbstruct-set-rundb! dbstruct (cons db dbpath)) (dbr:dbstruct-set-inuse! dbstruct #t) (dbr:dbstruct-set-olddb! dbstruct olddb) ;; (dbr:dbstruct-set-run-id! dbstruct run-id) (if local (begin (dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ... db) (begin (dbr:dbstruct-set-inmem! dbstruct inmem) (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED';") ;; they just slow us down in this context (db:sync-tables db:sync-tests-only db inmem) (db:delay-if-busy refdb) ;; dbpath: (db:dbdat-get-path refdb)) (dbr:dbstruct-set-refdb! dbstruct refdb) (db:sync-tables db:sync-tests-only db refdb) ;; sync once more to deal with delays (db:sync-tables db:sync-tests-only db inmem) (db:sync-tables db:sync-tests-only db refdb) inmem)))))) ;; This routine creates the db. It is only called if the db is not already ls opened ;; (define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let ((mdb (dbr:dbstruct-get-main dbstruct))) (if mdb mdb (let* ((dbpath (db:dbfile-path 0)) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath db:initialize-main-db)) (olddb (db:open-megatest-db)) (write-access (file-write-access? dbpath)) (dbdat (cons db dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (dbr:dbstruct-set-main! dbstruct dbdat) (dbr:dbstruct-set-olddb! dbstruct olddb) ;; olddb is already a (cons db path) dbdat)))) ;; Make the dbstruct, setup up auxillary db's and call for main db at least once ;; (define (db:setup run-id #!key (local #f)) (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (dbstruct (make-dbr:dbstruct path: dbdir local: local))) dbstruct)) ;; Open the classic megatest.db file in toppath ;; (define (db:open-megatest-db) (let* ((dbpath (conc *toppath* "/megatest.db")) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) (db:initialize-run-id-db db)))) (write-access (file-write-access? dbpath))) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (cons db dbpath))) ;; sync run to disk if touched ;; (define (db:sync-touched dbstruct run-id #!key (force-sync #f)) (let ((mtime (dbr:dbstruct-get-mtime dbstruct)) (stime (dbr:dbstruct-get-stime dbstruct)) (rundb (dbr:dbstruct-get-rundb dbstruct)) (inmem (dbr:dbstruct-get-inmem dbstruct)) (maindb (dbr:dbstruct-get-main dbstruct)) (refdb (dbr:dbstruct-get-refdb dbstruct)) (olddb (dbr:dbstruct-get-olddb dbstruct)) ;; (runid (dbr:dbstruct-get-run-id dbstruct)) ) (debug:print-info 4 "Syncing for run-id: " run-id) (mutex-lock! *http-mutex*) (if (eq? run-id 0) ;; runid equal to 0 is main.db (if maindb (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) force-sync) (begin (db:delay-if-busy maindb) (db:delay-if-busy olddb) (let ((num-synced (db:sync-tables (db:sync-main-list maindb) maindb olddb))) (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) num-synced) 0)) (begin ;; this can occur when using local access (i.e. not in a server) ;; need a flag to turn it off. ;; (debug:print 3 "WARNING: call to sync main.db to megatest.db but main not initialized") 0)) ;; any other runid is a run (if (or (not (number? mtime)) (not (number? stime)) (> mtime stime) force-sync) (begin (db:delay-if-busy rundb) (db:delay-if-busy olddb) (let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb olddb))) (dbr:dbstruct-set-stime! dbstruct (current-milliseconds)) (mutex-unlock! *http-mutex*) num-synced) (begin (mutex-unlock! *http-mutex*) 0)))))) (define (db:close-main dbstruct) (let ((maindb (dbr:dbstruct-get-main dbstruct))) (if maindb (begin (sqlite3:finalize! (db:dbdat-get-db maindb)) (dbr:dbstruct-set-main! dbstruct #f))))) (define (db:close-run-db dbstruct run-id) (let ((rdb (db:open-rundb dbstruct run-id do-not-open: #t))) (if (and rdb (sqlite3:database? rdb)) (begin (sqlite3:finalize! rdb) (dbr:dbstruct-set-localdb! dbstruct run-id #f) (dbr:dbstruct-set-inmem! dbstruct #f))))) ;; close all opened run-id dbs (define (db:close-all dbstruct) ;; finalize main.db (db:sync-touched dbstruct 0 force-sync: #t) ;;(common:db-block-further-queries) ;; (mutex-lock! *db-sync-mutex*) ;; with this perhaps it isn't necessary to use the block-further-queries mechanism? (db:close-main dbstruct) (let ((locdbs (dbr:dbstruct-get-locdbs dbstruct))) (if (hash-table? locdbs) (for-each (lambda (run-id) (db:close-run-db dbstruct run-id)) (hash-table-keys locdbs)))) ;; (let* ((local (dbr:dbstruct-get-local dbstruct)) ;; (rundb (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct)))) ;; (if local ;; (for-each ;; (lambda (dbdat) ;; (let ((db (db:dbdat-get-db dbdat))) ;; (if (sqlite3:database? db) ;; (begin ;; (sqlite3:interrupt! db) ;; (sqlite3:finalize! db #t))))) ;; ;; TODO: Come back to this and rework to delete from hashtable when finalized ;; (hash-table-values (dbr:dbstruct-get-locdbs dbstruct)))) ;; (thread-sleep! 3) ;; (if (and rundb ;; (sqlite3:database? rundb)) ;; (handle-exceptions ;; exn ;; (begin ;; (debug:print 0 "WARNING: database files may not have been closed correctly. Consider running -cleanup-db") ;; (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) ;; (debug:print 0 " db: " rundb) ;; (print-call-chain (current-error-port)) ;; #f) ;; (sqlite3:interrupt! rundb) ;; (sqlite3:finalize! rundb #t)))) ;; ;; (mutex-unlock! *db-sync-mutex*) ) (define (db:open-inmem-db) (let* ((db (sqlite3:open-database ":memory:")) (handler (make-busy-timeout 3600))) (sqlite3:set-busy-handler! db handler) (db:initialize-run-id-db db) (cons db #f))) ;; just tests, test_steps and test_data tables (define db:sync-tests-only (list ;; (list "strs" ;; '("id" #f) ;; '("str" #f)) (list "tests" '("id" #f) '("run_id" #f) '("testname" #f) '("host" #f) '("cpuload" #f) '("diskfree" #f) '("uname" #f) '("rundir" #f) '("shortdir" #f) '("item_path" #f) '("state" #f) '("status" #f) '("attemptnum" #f) '("final_logf" #f) '("logdat" #f) '("run_duration" #f) '("comment" #f) '("event_time" #f) '("fail_count" #f) '("pass_count" #f) '("archived" #f)) (list "test_steps" '("id" #f) '("test_id" #f) '("stepname" #f) '("state" #f) '("status" #f) '("event_time" #f) '("comment" #f) '("logfile" #f)) (list "test_data" '("id" #f) '("test_id" #f) '("category" #f) '("variable" #f) '("value" #f) '("expected" #f) '("tol" #f) '("units" #f) '("comment" #f) '("status" #f) '("type" #f)))) ;; needs db to get keys, this is for syncing all tables ;; (define (db:sync-main-list db) (let ((keys (db:get-keys db))) (list (list "keys" '("id" #f) '("fieldname" #f) '("fieldtype" #f)) (list "metadat" '("var" #f) '("val" #f)) (append (list "runs" '("id" #f)) (map (lambda (k)(list k #f)) (append keys (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))) (list "test_meta" '("id" #f) '("testname" #f) '("owner" #f) '("description" #f) '("reviewed" #f) '("iterated" #f) '("avg_runtime" #f) '("avg_disk" #f) '("tags" #f) '("jobgroup" #f))))) ;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) ) ;; db's are dbdat's ;; (define (db:sync-tables tbls fromdb todb . slave-dbs) (mutex-lock! *db-sync-mutex*) (handle-exceptions exn (begin (debug:print 0 "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.") (print-call-chain (current-error-port)) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (debug:print 0 " src db: " (db:dbdat-get-path fromdb)) (for-each (lambda (dbdat) (debug:print 0 " dbpath: " (db:dbdat-get-path dbdat))) (cons todb slave-dbs)) (if *server-run* ;; we are inside a server (set! *time-to-exit* #t) ;; let watch dog know that it is time to die. (exit 1))) (cond ((not fromdb) (debug:print 3 "WARNING: db:sync-tables called with fromdb missing") -1) ((not todb) (debug:print 3 "WARNING: db:sync-tables called with todb missing") -2) ((not (sqlite3:database? (db:dbdat-get-db fromdb))) (debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3) ((not (sqlite3:database? (db:dbdat-get-db todb))) (debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4) (else (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) (start-time (current-milliseconds)) (tot-count 0)) (for-each ;; table (lambda (tabledat) (let* ((tablename (car tabledat)) (fields (cdr tabledat)) (num-fields (length fields)) (field->num (make-hash-table)) (num->field (apply vector (map car fields))) (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") " FROM " tablename ";")) (full-ins (conc "INSERT OR REPLACE INTO " tablename " ( " (string-intersperse (map car fields) ",") " ) " " VALUES ( " (string-intersperse (make-list num-fields "?") ",") " );")) (fromdat '()) (fromdats '()) (totrecords 0) (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "10"))) (todat (make-hash-table)) (count 0)) ;; set up the field->num table (for-each (lambda (field) (hash-table-set! field->num field count) (set! count (+ count 1))) fields) ;; read the source table (sqlite3:for-each-row (lambda (a . b) (set! fromdat (cons (apply vector a b) fromdat)) (if (> (length fromdat) batch-len) (begin (set! fromdats (cons fromdat fromdats)) (set! fromdat '()) (set! totrecords (+ totrecords 1))))) (db:dbdat-get-db fromdb) full-sel) (debug:print-info 2 "found " totrecords " records to sync") ;; read the target table (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) (db:dbdat-get-db todb) full-sel) ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) (let* ((db (db:dbdat-get-db targdb)) (stmth (sqlite3:prepare db full-ins))) ;; (db:delay-if-busy targdb) ;; NO WAITING (for-each (lambda (fromdat-lst) (sqlite3:with-transaction db (lambda () (for-each ;; (lambda (fromrow) (let* ((a (vector-ref fromrow 0)) (curr (hash-table-ref/default todat a #f)) (same #t)) (let loop ((i 0)) (if (or (not curr) (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) (set! same #f)) (if (and same (< i (- num-fields 1))) (loop (+ i 1)))) (if (not same) (begin (apply sqlite3:execute stmth (vector->list fromrow)) (hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0))))))) fromdat-lst)) )) fromdats) (sqlite3:finalize! stmth))) (append (list todb) slave-dbs)))) tbls) (let* ((runtime (- (current-milliseconds) start-time)) (should-print (common:low-noise-print 30 "db sync" (> runtime 500)))) ;; low and high sync times treated as separate. (if should-print (debug:print 0 "INFO: db sync, total run time " runtime " ms")) (for-each (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) (set! tot-count (+ tot-count count)) (if (> count 0) (if should-print (debug:print 0 (format #f " ~10a ~5a" tblname count)))))) (sort (hash-table->alist numrecs)(lambda (a b)(> (cdr a)(cdr b)))))) tot-count))) (mutex-unlock! *db-sync-mutex*))) ;; options: ;; ;; 'killservers - kills all servers ;; 'dejunk - removes junk records ;; 'adj-testids - move test-ids into correct ranges ;; 'old2new - sync megatest.db records to .db/{main,1,2 ...}.db ;; 'new2old - sync .db/{main,1,2,3 ...}.db to megatest.db ;; 'closeall - close all opened dbs ;; ;; run-ids: '(1 2 3 ...) or #f (for all) ;; (define (db:multi-db-sync run-ids . options) (let* ((toppath (launch:setup-for-run)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath) #f)) (mtdb (if toppath (db:open-megatest-db))) (run-ids (if run-ids run-ids (if toppath (begin (db:delay-if-busy mtdb) (db:get-all-run-ids mtdb))))) (tdbdat (tasks:open-db)) (servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) ;; kill servers (if (member 'killservers options) (for-each (lambda (server) (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration") (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) servers)) ;; clear out junk records ;; (if (member 'dejunk options) (begin (db:delay-if-busy mtdb) (db:clean-up mtdb))) ;; adjust test-ids to fit into proper range ;; (if (member 'adj-testids options) (begin (db:delay-if-busy mtdb) (db:prep-megatest.db-for-migration mtdb))) ;; sync runs, test_meta etc. ;; (if (member 'old2new options) (begin (db:sync-tables (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f)) (for-each (lambda (run-id) (db:delay-if-busy mtdb) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) (debug:print 0 "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db") (db:replace-test-records dbstruct run-id testrecs) (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-get-rundb dbstruct))))) run-ids))) ;; now ensure all newdb data are synced to megatest.db (if (member 'new2old options) (for-each (lambda (run-id) (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)) (frundb (db:dbdat-get-db (db:get-db fromdb run-id)))) ;; (db:delay-if-busy frundb) ;; (db:delay-if-busy mtdb) (if (eq? run-id 0) (db:sync-tables (db:sync-main-list dbstruct) (db:get-db fromdb #f) mtdb) (db:sync-tables db:sync-tests-only (db:get-db fromdb run-id) mtdb)))) (cons 0 run-ids))) ;; (db:close-all dbstruct) ;; (sqlite3:finalize! mdb) )) ;; keeping it around for debugging purposes only (define (open-run-close-no-exception-handling proc idb . params) (debug:print-info 11 "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params) (if (or *db-write-access* (not (member proc *db:all-write-procs*))) (let* ((db (cond ((pair? idb) (db:dbdat-get-db idb)) ((sqlite3:database? idb) idb) ((not idb) (debug:print 0 "ERROR: cannot open-run-close with #f anymore")) ((procedure? idb) (idb)) (else (debug:print 0 "ERROR: cannot open-run-close with #f anymore")))) (res #f)) (set! res (apply proc db params)) (if (not idb)(sqlite3:finalize! dbstruct)) (debug:print-info 11 "open-run-close-no-exception-handling END" ) res) #f)) (define (open-run-close-exception-handling proc idb . params) (handle-exceptions exn (let ((sleep-time (random 30)) (err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (case err-status ((busy) (thread-sleep! sleep-time)) (else (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)) (thread-sleep! sleep-time) (debug:print-info 0 "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up"))) (apply open-run-close-exception-handling proc idb params)) (apply open-run-close-no-exception-handling proc idb params))) ;; (define open-run-close (define open-run-close open-run-close-exception-handling) ;; open-run-close-no-exception-handling ;; open-run-close-exception-handling) ;;) (define (db:initialize-main-db dbdat) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (keys:config-get-fields configdat)) (havekeys (> (length keys) 0)) (keystr (keys->keystr keys)) (fieldstr (keys->key/field keys)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((keyn key)) (if (member (string-downcase keyn) (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")) (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and <linktree>/.db before trying again.") (exit 1))))) keys) (sqlite3:with-transaction db (lambda () (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") (for-each (lambda (key) (sqlite3:execute db "INSERT OR REPLACE INTO keys (fieldname,fieldtype) VALUES (?,?);" key "TEXT")) keys) (sqlite3:execute db (conc "CREATE TABLE IF NOT EXISTS runs (id INTEGER PRIMARY KEY, \n " fieldstr (if havekeys "," "") " runname TEXT DEFAULT 'norun', state TEXT DEFAULT '', status TEXT DEFAULT '', owner TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, CONSTRAINT runsconstraint UNIQUE (runname" (if havekeys "," "") keystr "));")) (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, testname TEXT DEFAULT '', author TEXT DEFAULT '', owner TEXT DEFAULT '', description TEXT DEFAULT '', reviewed TIMESTAMP, iterated TEXT DEFAULT '', avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") (sqlite3:execute db (conc "CREATE INDEX IF NOT EXISTS runs_index ON runs (runname" (if havekeys "," "") keystr ");")) ;; (sqlite3:execute db "CREATE VIEW runs_tests AS SELECT * FROM runs INNER JOIN tests ON runs.id=tests.run_id;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" megatest-version) (debug:print-info 11 "db:initialize END"))))) ;;====================================================================== ;; R U N S P E C I F I C D B ;;====================================================================== (define (db:initialize-run-id-db db) (sqlite3:with-transaction db (lambda () (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, diskfree INTEGER DEFAULT -1, uname TEXT DEFAULT 'n/a', rundir TEXT DEFAULT '/tmp/badname', shortdir TEXT DEFAULT '/tmp/badname', item_path TEXT DEFAULT '', state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'FAIL', attemptnum INTEGER DEFAULT 0, final_logf TEXT DEFAULT 'logs/final.log', logdat TEXT DEFAULT '', run_duration INTEGER DEFAULT 0, comment TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") ;; (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data ;; (id INTEGER PRIMARY KEY, ;; reviewed TIMESTAMP DEFAULT (strftime('%s','now')), ;; iterated TEXT DEFAULT '', ;; avg_runtime REAL DEFAULT -1, ;; avg_disk REAL DEFAULT -1, ;; tags TEXT DEFAULT '', ;; jobgroup TEXT DEFAULT 'default', ;; CONSTRAINT test_meta_constraint UNIQUE (testname));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") ;; Why use FULL here? This data is not that critical ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);"))) db) ;;====================================================================== ;; L O G G I N G D B ;;====================================================================== (define (open-logging-db) ;; (conc *toppath* "/megatest.db") (car *configinfo*))) (let* ((dbpath (conc (if *toppath* (conc *toppath* "/") "") "logging.db")) ;; fname) (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) ;; 136000))) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (begin (sqlite3:execute db "CREATE TABLE IF NOT EXISTS log (id INTEGER PRIMARY KEY,event_time TIMESTAMP DEFAULT (strftime('%s','now')),logline TEXT,pwd TEXT,cmdline TEXT,pid INTEGER);") (db:set-sync db) ;; (sqlite3:execute db (conc "PRAGMA synchronous = 0;")) )) db)) (define (db:log-local-event . loglst) (let ((logline (apply conc loglst))) (db:log-event logline))) (define (db:log-event logline) (let ((db (open-logging-db))) (sqlite3:execute db "INSERT INTO log (logline,pwd,cmdline,pid) VALUES (?,?,?,?);" logline (current-directory) (string-intersperse (argv) " ") (current-process-id)) (sqlite3:finalize! db) logline)) ;;====================================================================== ;; D B U T I L S ;;====================================================================== ;;====================================================================== ;; M A I N T E N A N C E ;;====================================================================== ;; select end_time-now from ;; (select testname,item_path,event_time+run_duration as ;; end_time,strftime('%s','now') as now from tests where state in ;; ('RUNNING','REMOTEHOSTSTART','LAUNCED')); (define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (incompleted '()) (oldlaunched '()) (toplevels '()) (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) (deadtime (if (and deadtime-str (string->number deadtime-str)) (string->number deadtime-str) 7200))) ;; two hours (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) (debug:print-info 0 "Found old toplevel test in RUNNING state, test-id=" test-id)) (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" run-id deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" run-id) (debug:print-info 18 "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE. ;; (db:delay-if-busy dbdat) (let* (;; (min-incompleted (filter (lambda (x) ;; (let* ((testpath (cadr x)) ;; (tdatpath (conc testpath "/testdat.db")) ;; (dbexists (file-exists? tdatpath))) ;; (or (not dbexists) ;; if no file then something wrong - mark as incomplete ;; (> (- (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 "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") (sqlite3:execute db (conc "UPDATE tests SET state='INCOMPLETE' WHERE id IN (" (string-intersperse (map conc all-ids) ",") ");"))))) ;; Now do rollups for the toplevel tests ;; (db:delay-if-busy dbdat) (for-each (lambda (toptest) (let ((test-name (list-ref toptest 3))) ;; (run-id (list-ref toptest 5))) (db:general-call db 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) ;; (list run-id test-name)))) toplevels))) ;; Clean out old junk and vacuum the database ;; ;; Ultimately do something like this: ;; ;; 1. Look at test records either deleted or part of deleted run: ;; a. If test dir exists, set the the test to state='UNKNOWN', Set the run to 'unknown' ;; b. If test dir gone, delete the test record ;; 2. Look at run records ;; a. If have tests that are not deleted, set state='unknown' ;; b. .... ;; (define (db:clean-up dbdat) (debug:print 0 "WARNING: db clean up not fully ported to v1.60, cleanup action will be on megatest.db") (let* ((db (db:dbdat-get-db dbdat)) (count-stmt (sqlite3:prepare db "SELECT (SELECT count(id) FROM tests)+(SELECT count(id) FROM runs);")) (statements (map (lambda (stmt) (sqlite3:prepare db stmt)) (list ;; delete all tests that belong to runs that are 'deleted' "DELETE FROM tests WHERE run_id in (SELECT id FROM runs WHERE state='deleted');" ;; delete all tests that are 'DELETED' "DELETE FROM tests WHERE state='DELETED';" ;; delete all tests that have no run "DELETE FROM tests WHERE run_id NOT IN (SELECT DISTINCT id FROM runs);" ;; delete all runs that are state='deleted' "DELETE FROM runs WHERE state='deleted';" ;; delete empty runs "DELETE FROM runs WHERE id NOT IN (SELECT DISTINCT r.id FROM runs AS r INNER JOIN tests AS t ON t.run_id=r.id);" )))) (db:delay-if-busy dbdat) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count before clean: " tot)) count-stmt) (map sqlite3:execute statements) (sqlite3:for-each-row (lambda (tot) (debug:print-info 0 "Records count after clean: " tot)) count-stmt))) (map sqlite3:finalize! statements) (sqlite3:finalize! count-stmt) ;; (db:find-and-mark-incomplete db) (db:delay-if-busy dbdat) (sqlite3:execute db "VACUUM;"))) ;;====================================================================== ;; M E T A G E T A N D S E T V A R S ;;====================================================================== ;; returns number if string->number is successful, string otherwise ;; also updates *global-delta* ;; ;; Operates on megatestdb ;; (define (db:get-var dbstruct var) (let* ((start-ms (current-milliseconds)) (throttle (let ((t (config-lookup *configdat* "setup" "throttle"))) (if t (string->number t) t))) (res #f) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) (if valnum (set! res valnum)))) ;; scale by 10, average with current value. (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) (if throttle throttle 0.01))) 2)) (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit (begin (debug:print-info 4 "launch throttle factor=" *global-delta*) (set! *last-global-delta-printed* *global-delta*))) res)) (define (db:set-var dbstruct var val) (let ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (db:delay-if-busy dbdat) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val))) (define (db:del-var dbstruct var) ;; (db:delay-if-busy) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "DELETE FROM metadat WHERE var=?;" var)))) ;; use a global for some primitive caching, it is just silly to ;; re-read the db over and over again for the keys since they never ;; change ;; why get the keys from the db? why not get from the *configdat* ;; using keys:config-get-fields? (define (db:get-keys dbstruct) (if *db-keys* *db-keys* (let ((res '())) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (key) (set! res (cons key res))) db "SELECT fieldname FROM keys ORDER BY id DESC;"))) (set! *db-keys* res) res))) ;; look up values in a header/data structure (define (db:get-value-by-header row header field) (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) (vector-ref row n) (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) ;; Accessors for the header/data structure ;; get rows and header from (define (db:get-header vec)(vector-ref vec 0)) (define (db:get-rows vec)(vector-ref vec 1)) ;;====================================================================== ;; R U N S ;;====================================================================== (define (db:get-run-name-from-id dbstruct run-id) (db:with-db dbstruct #f ;; this is for the main runs db #f ;; does not modify db (lambda (db) (let ((res #f)) (sqlite3:for-each-row (lambda (runname) (set! res runname)) db "SELECT runname FROM runs WHERE id=?;" run-id) res)))) (define (db:get-run-key-val dbstruct run-id key) (db:with-db dbstruct #f #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) db (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)))) ;; keys list to key1,key2,key3 ... (define (runs:get-std-run-fields keys remfields) (let* ((header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (list keystr header))) |
︙ | ︙ | |||
723 724 725 726 727 728 729 | (conc fieldname " " wildtype " '" patt "'"))) (if (null? patts) '("") patts)) comparator))) | | > > | < > > | | > | < | | | | | | | | | | | | | > > | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > | | | | | | | | | | | | > > > > > | | | | | | | | | > > > > > > > > > > > > > > | > > | > | > > > | < < < | | > > > > > > > > > > > > > > > > > > > > > > | > > > | | | > > | | | | | | | | > > | | > | | < | > > > > | | | < > > > > | | < < < | | < | | | < | > > > > | | > > | > > | | | | | < | | | | | > > | | | | | > > > > > | | | | | | | < < < < < < < < | | | | > | < | < < < | | < > > | | | < > | | | | | < | | | | < < < | | < | > > > > > > > > > > > > > > > > > | | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | > > > > > | | | | | < < > | | > > | | | | | | | > | > | | > > > > | > < < < < < | < | < | < < | < | | < < | < < | < < < < < < | | < | < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < | < > > > | > | | < > | > > | > > > > | > > > > > | | < | < | | < < < | < < | < < | | < | | > > > > | | | > | | | | | | > | | < < < < | | < | > > > | | | > > | > | | | | < | | < < < > | < > | < > | < > > > > | | | > > > | < > | | < | > > | > > | | > > > > > > > > > > > | > > > > | | < < | | | > > | | < > | < | > > > > > > > > > | | > | > > > | | > > | > | < > > > > > > > | | > > | > > > | > > > > > > > > > > > > > | > | > > | > > > > | > | > | > | | | < < | > > > > > > > > > > > > > | > | | | | | < > | < < | | | < < | | | > | > | > > > > > > > > | | | | | | < < | > | > | | > > > > | > > | > | < | | > > > > > > > | | > < | > | | < | > | | | | > > > > > | > > > > > > > > > > | > > > | > > > > > > > > > > | | > > > > > > > > > > > > > > > > | | < < | > > > > > > > > > > > | > | < > | > > > > | | | < | < | | | | < < > > > > > > > > | > > > > | | > > > | < > > | | < < > > > | < > > > > > > > > > > > > > > > > > > > > > > > > > > | < < | | | < < > | < < < | | | > > > > > > > > > > > > > > > > > > > > > | < > < < < < < < < < < < < < < < < < < < < < | < < < < < < | < < < < < < < < < < < < < < < < | < < < < < < | | | < > < < < < < < < | < < < < | < < < < < | < < < < < < < < | < < < | < | < > > > > > > > > > > > > > > > > > > > > > > | | | | | > > > | | > | | | > > | | < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < > | < < < < < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > | > | < | < | > > < < < < | < < | < < | < < < < < < < | < < | < < | | < < < < < < < < < < < < < < < < < < < < < | < < | < < < < | < < < < < | < < < < < < < < < < < | | < | | | > > | | | | | | | | | > > > | | | | | | | | | > | > | < | | | | | > | | | | > > > > > > > > > > | < > > > > > > > > | > > > | | < > | < < < < < < < < > | > > > | > | < > | | | > > | | < < > > | > > | < < < < < < < < < < < < | < < < < < < < < < < < < < < < | > | | > | < < | | | | | | | | | | | < > | | | | | | | | | | > > > > < < < < | < < > > | | < < > > | | < < < < < | > | < < < < < | < | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > | | | | | | | | > > > > > | | | > | | | | > | > > | | < < | < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < | < < < < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | > | | 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 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 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 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 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 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 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 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 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 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 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 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 | (conc fieldname " " wildtype " '" patt "'"))) (if (null? patts) '("") patts)) comparator))) ;; register a test run with the db, this accesses the main.db and does NOT ;; use server api ;; (define (db:register-run dbstruct keyvals runname state status user) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat)) (keys (map car keyvals)) (keystr (keys->keystr keys)) (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... (allvals (append (list runname state status user) (map cadr keyvals))) (qryvals (append (list runname) (map cadr keyvals))) (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) (debug:print 3 "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (let ((res #f)) (db:delay-if-busy dbdat) (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") allvals) (db:delay-if-busy dbdat) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");"))) ;(debug:print 4 "qry: " qry) qry) qryvals) (db:delay-if-busy dbdat) (sqlite3:execute db "UPDATE runs SET state=?,status=?,event_time=strftime('%s','now') WHERE id=? AND state='deleted';" state status res) res) (begin (debug:print 0 "ERROR: Called without all necessary keys") #f)))) ;; replace header and keystr with a call to runs:get-std-run-fields ;; ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) ;; runpatts: patt1,patt2 ... ;; (define (db:get-runs dbstruct runpatt count offset keypatts) (let* ((res '()) (keys (db:get-keys dbstruct)) (runpattstr (db:patt->like "runname" runpatt)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ","))) (qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? " ;; Generate: " AND x LIKE 'keypatt' ..." (if (null? keypatts) "" (conc " AND " (string-join (map (lambda (keypatt) (let ((key (car keypatt)) (patt (cadr keypatt))) (db:patt->like key patt))) keypatts) " AND "))) " AND state != 'deleted' ORDER BY event_time DESC " (if (number? count) (conc " LIMIT " count) "") (if (number? offset) (conc " OFFSET " offset) "")))) (debug:print-info 11 "db:get-runs START qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (a . x) (set! res (cons (apply vector a x) res))) db qrystr ))) (debug:print-info 11 "db:get-runs END qrystr: " qrystr " keypatts: " keypatts " offset: " offset " limit: " count) (vector header res))) ;; db:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; ;; NOTE: THIS IS COMPLETELY UNFINISHED. IT GOES WITH rmt:get-get-paths-matching-keynames ;; (define (db:get-run-ids-matching dbstruct keynames target res) ;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) (keystr (car tmp)) (header (cadr tmp)) (res '()) (key-patt "") (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) (qry-str #f) (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) (for-each (lambda (keyval) (let* ((key (car keyval)) (patt (cadr keyval)) (fulkey (conc ":" key)) (wildtype (if (substring-index "%" patt) "like" "glob"))) (if patt (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) (begin (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) (exit 6))))) keyvals) (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (db:with-db dbstruct #f #f ;; reads db, does not write to it. (lambda (db) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) (db:get-db dbstruct #f) qry-str runnamepatt))) (vector header res))) ;; Get all targets from the db ;; (define (db:get-targets dbstruct) (let* ((res '()) (keys (db:get-keys dbstruct)) (header keys) ;; (map key:get-fieldname keys)) (keystr (keys->keystr keys)) (qrystr (conc "SELECT " keystr " FROM runs WHERE state != 'deleted';")) (seen (make-hash-table))) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (a . x) (let ((targ (cons a x))) (if (not (hash-table-ref/default seen targ #f)) (begin (hash-table-set! seen targ #t) (set! res (cons (apply vector targ) res)))))) db qrystr) (debug:print-info 11 "db:get-targets END qrystr: " qrystr ) (vector header res))))) ;; just get count of runs (define (db:get-num-runs dbstruct runpatt) (db:with-db dbstruct #f #f (lambda (db) (let ((numruns 0)) (debug:print-info 11 "db:get-num-runs START " runpatt) (sqlite3:for-each-row (lambda (count) (set! numruns count)) db "SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt) (debug:print-info 11 "db:get-num-runs END " runpatt) numruns)))) (define (db:get-all-run-ids dbstruct) (db:with-db dbstruct #f #f (lambda (db) (let ((run-ids '())) (sqlite3:for-each-row (lambda (run-id) (set! run-ids (cons run-id run-ids))) db "SELECT id FROM runs WHERE state != 'deleted' ORDER BY event_time DESC;") (reverse run-ids))))) ;; get some basic run stats ;; ;; ( (runname (( state count ) ... )) ;; ( ... (define (db:get-run-stats dbstruct) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat)) (totals (make-hash-table)) (curr (make-hash-table)) (res '()) (runs-info '())) ;; First get all the runname/run-ids (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (run-id runname) (set! runs-info (cons (list run-id runname) runs-info))) db "SELECT id,runname FROM runs WHERE state != 'deleted';") ;; for each run get stats data (for-each (lambda (run-info) ;; get the net state/status counts for this run (let* ((run-id (car run-info)) (run-name (cadr run-info))) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (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 "SELECT state,status,count(id) FROM tests AS t GROUP BY state,status ORDER BY state,status DESC;") ;; add the per run counts to res (for-each (lambda (state) (set! res (cons (list run-name state (hash-table-ref curr state)) res))) (sort (hash-table-keys curr) string>=)) (set! curr (make-hash-table)))))) runs-info) (for-each (lambda (state) (set! res (cons (list "Totals" state (hash-table-ref totals state)) res))) (sort (hash-table-keys totals) string>=)) res)) ;; db:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; (define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name) (let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time"))) (keystr (car tmp)) (header (cadr tmp)) (res '()) (key-patt "") (runwildtype (if (substring-index "%" runnamepatt) "like" "glob")) (qry-str #f) (keyvals (if targpatt (keys:target->keyval keys targpatt) '()))) (for-each (lambda (keyval) (let* ((key (car keyval)) (patt (cadr keyval)) (fulkey (conc ":" key)) (wildtype (if (substring-index "%" patt) "like" "glob"))) (if patt (set! key-patt (conc key-patt " AND " key " " wildtype " '" patt "'")) (begin (debug:print 0 "ERROR: searching for runs with no pattern set for " fulkey) (exit 6))))) keyvals) (set! qry-str (conc "SELECT " keystr " FROM runs WHERE state != 'deleted' AND runname " runwildtype " ? " key-patt " ORDER BY event_time " (if limit (conc " LIMIT " limit) "") (if offset (conc " OFFSET " offset) "") ";")) (debug:print-info 4 "runs:get-runs-by-patt qry=" qry-str " " runnamepatt) (db:with-db dbstruct #f #f ;; reads db, does not write to it. (lambda (db) (sqlite3:for-each-row (lambda (a . r) (set! res (cons (list->vector (cons a r)) res))) db qry-str runnamepatt))) (vector header res))) ;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) (define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat)) (res (vector #f #f #f #f)) (keys (db:get-keys dbstruct)) (remfields (list "id" "runname" "state" "status" "owner" "event_time")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (a . x) (set! res (apply vector a x))) db (conc "SELECT " keystr " FROM runs WHERE id=? AND state != 'deleted';") run-id) (debug:print-info 11 "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (let ((finalres (vector header res))) ;; (hash-table-set! *run-info-cache* run-id finalres) finalres))) (define (db:set-comment-for-run dbstruct run-id comment) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:execute db "UPDATE runs SET comment=? WHERE id=?;" comment ;; (sdb:qry 'getid comment) run-id)))) ;; does not (obviously!) removed dependent data. But why not!!? (define (db:delete-run dbstruct run-id) ;; First set any related tests to DELETED (let* ((rdbdat (db:get-db dbstruct run-id)) (rdb (db:dbdat-get-db rdbdat)) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (db:delay-if-busy rdbdat) (sqlite3:execute rdb "UPDATE tests SET state='DELETED',comment='';") (sqlite3:execute rdb "DELETE FROM test_steps;") (sqlite3:execute rdb "DELETE FROM test_data;") (db:delay-if-busy dbdat) (sqlite3:execute db "UPDATE runs SET state='deleted',comment='' WHERE id=?;" run-id))) (define (db:update-run-event_time dbstruct run-id) (db:with-db dbstruct #f #t (lambda (db) (sqlite3:execute db "UPDATE runs SET event_time=strftime('%s','now') WHERE id=?;" run-id)))) (define (db:lock/unlock-run dbstruct run-id lock unlock user) (db:with-db dbstruct #f #t (lambda (db) (let ((newlockval (if lock "locked" (if unlock "unlocked" "locked")))) ;; semi-failsafe (sqlite3:execute db "UPDATE runs SET state=? WHERE id=?;" newlockval run-id) (sqlite3:execute db "INSERT INTO access_log (user,accessed,args) VALUES(?,strftime('%s','now'),?);" user (conc newlockval " " run-id)) (debug:print-info 1 "" newlockval " run number " run-id))))) (define (db:set-run-status dbstruct run-id status msg) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (db:delay-if-busy dbdat) (if msg (sqlite3:execute db "UPDATE runs SET status=?,comment=? WHERE id=?;" status msg run-id) (sqlite3:execute db "UPDATE runs SET status=? WHERE id=?;" status run-id)))) (define (db:get-run-status dbstruct run-id) (let ((res "n/a")) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (status) (set! res status)) db "SELECT status FROM runs WHERE id=?;" run-id) res)))) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; get key val pairs for a given run-id ;; ( (FIELDNAME1 keyval1) (FIELDNAME2 keyval2) ... ) (define (db:get-key-val-pairs dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) (res '()) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons (list key key-val) res))) db qry run-id))) keys) (reverse res))) ;; get key vals for a given run-id (define (db:get-key-vals dbstruct run-id) (let* ((keys (db:get-keys dbstruct)) (res '()) (dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (for-each (lambda (key) (let ((qry (conc "SELECT " key " FROM runs WHERE id=?;"))) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (key-val) (set! res (cons key-val res))) db qry run-id))) keys) (let ((final-res (reverse res))) (hash-table-set! *keyvals* run-id final-res) final-res))) ;; The target is keyval1/keyval2..., cached in *target* as it is used often (define (db:get-target dbstruct run-id) (let* ((keyvals (db:get-key-vals dbstruct run-id)) (thekey (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/"))) thekey)) ;; Get run-ids for runs with same target but different runnames and NOT run-id ;; (define (db:get-prev-run-ids dbstruct run-id) (let* ((keyvals (rmt:get-key-val-pairs run-id)) (kvalues (map cadr keyvals)) (keys (rmt:get-keys)) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (let ((prev-run-ids '())) (db:with-db dbstruct #f #f ;; #f means work with the zeroth db - i.e. the runs db (lambda (db) (apply sqlite3:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND state != 'deleted' AND id != ?;") (append kvalues (list run-id))))) prev-run-ids))) ;;====================================================================== ;; T E S T S ;;====================================================================== ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. ;; states and statuses are required to be lists, empty is ok ;; not-in #t = above behaviour, #f = must match (define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) (if (not (number? run-id)) (begin ;; no need to treat this as an error by default (debug:print 4 "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) ;; (print-call-chain (current-error-port)) '()) (let* ((qryvalstr (case qryvals ((shortlist) "id,run_id,testname,item_path,state,status") ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") (else qryvals))) (res '()) ;; if states or statuses are null then assume match all when not-in is false (states-qry (if (null? states) #f (conc " state " (if not-in " NOT IN ('" " IN ('") (string-intersperse states "','") "')"))) (statuses-qry (if (null? statuses) #f (conc " status " (if not-in " NOT IN ('" " IN ('") (string-intersperse statuses "','") "')"))) (states-statuses-qry (cond ((and states-qry statuses-qry) (conc " AND ( " states-qry " AND " statuses-qry " ) ")) (states-qry (conc " AND " states-qry)) (statuses-qry (conc " AND " statuses-qry)) (else ""))) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT " qryvalstr " FROM tests WHERE run_id=? AND state != 'DELETED' " states-statuses-qry (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") (case sort-by ((rundir) " ORDER BY length(rundir) ") ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) ((event_time) " ORDER BY event_time ") (else (if (string? sort-by) (conc " ORDER BY " sort-by " ") " "))) (if sort-order sort-order " ") (if limit (conc " LIMIT " limit) " ") (if offset (conc " OFFSET " offset) " ") ";" ))) (debug:print-info 8 "db:get-tests-for-run run-id=" run-id ", qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (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 run-id ))) (case qryvals ((shortlist)(map db:test-short-record->norm res)) ((#f) res) (else res))))) (define (db:test-short-record->norm inrec) ;; "id,run_id,testname,item_path,state,status" ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (vector (vector-ref inrec 0) ;; id (vector-ref inrec 1) ;; run_id (vector-ref inrec 2) ;; testname (vector-ref inrec 4) ;; state (vector-ref inrec 5) ;; status -1 "" -1 -1 "" "-" (vector-ref inrec 3) ;; item-path -1 "-" "-")) (define (db:get-tests-for-run-state-status dbstruct run-id testpatt) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")))) (debug:print-info 8 "db:get-tests-for-run qry=" qry) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) db qry run-id))) res)) (define (db:get-testinfo-state-status dbstruct run-id test-id) (let ((res #f)) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (run-id testname item-path state status) ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) db "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" test-id))) res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} ;; (define (db:get-tests-for-runs-mindata dbstruct run-ids testpatt states statuses not-in) (debug:print 0 "ERROR: BROKN!") ;; (db:get-tests-for-runs dbstruct run-ids testpatt states statuses not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) ) ;; get a useful subset of the tests data (used in dashboard ;; (define (db:get-tests-for-run-mindata dbstruct run-id testpatt states statuses not-in) (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f "id,run_id,testname,state,status,event_time,item_path")) ;; do not use. ;; (define (db:get-tests-for-runs dbstruct run-ids testpatt states statuses #!key (not-in #f)(qryvals #f)) ;; (db:delay-if-busy) (let ((res '())) (for-each (lambda (run-id) (set! res (append res (db:get-tests-for-run dbstruct run-id testpatt states statuses #f #f not-in #f #f qryvals)))) (if run-ids run-ids (db:get-all-run-ids dbstruct))) res)) ;; Convert calling routines to get list of run-ids and loop, do not use the get-tests-for-runs ;; (define (db:delete-test-records dbstruct run-id test-id) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat))) (db:general-call dbdat 'delete-test-step-records (list test-id)) ;; (db:delay-if-busy) (db:general-call dbdat 'delete-test-data-records (list test-id)) (sqlite3:execute db "UPDATE tests SET state='DELETED',status='n/a',comment='' WHERE id=?;" test-id))) (define (db:delete-old-deleted-test-records dbstruct) (let ((run-ids (db:get-all-run-ids dbstruct)) (targtime (- (current-seconds)(* 30 24 60 60)))) ;; one month in the past (for-each (lambda (run-id) (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "DELETE FROM tests WHERE state='DELETED' AND event_time<?;" targtime)))) run-ids))) ;; set tests with state currstate and status currstatus to newstate and newstatus ;; use currstate = #f and or currstatus = #f to apply to any state or status respectively ;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below ;; ;; AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) ;;(debug:print 0 "QRY: " qry) ;; (db:delay-if-busy) (define (db:set-tests-state-status dbstruct run-id testnames currstate currstatus newstate newstatus) (for-each (lambda (testname) (let ((qry (conc "UPDATE tests SET state=?,status=? WHERE " (if currstate (conc "state='" currstate "' AND ") "") (if currstatus (conc "status='" currstatus "' AND ") "") " run_id=? AND testname LIKE ?;"))) (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db qry newstate newstatus run-id testname))))) testnames)) ;; speed up for common cases with a little logic ;; NB// Ultimately this will be deprecated in deference to mt:test-set-state-status-by-id ;; (define (db:test-set-state-status-by-id dbstruct run-id test-id newstate newstatus newcomment) (db:with-db dbstruct run-id #t (lambda (db) (cond ((and newstate newstatus newcomment) (sqlite3:execute db "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;" newstate newstatus newcomment ;; (sdb:qry 'getid newcomment) test-id)) ((and newstate newstatus) (sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id)) (else (if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id)) (if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id)) (if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment) test-id)))) (mt:process-triggers run-id test-id newstate newstatus)))) ;; NEW BEHAVIOR: Count tests running in only one run! ;; (define (db:get-count-tests-running dbstruct run-id) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:first-result db ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ... ;; AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND NOT (uname = 'n/a' AND item_path = '');" ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" )))) ;; NEW BEHAVIOR: Count tests running in only one run! ;; (define (db:get-count-tests-actually-running dbstruct run-id) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:first-result db ;; WARNING BUG EDIT ME - merged from v1.55 - not sure what is right here ... ;; "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id NOT IN (SELECT id FROM runs WHERE state='deleted') AND NOT (uname = 'n/a' AND item_path = '');") "SELECT count(id) FROM tests WHERE state in ('RUNNING','REMOTEHOSTSTART') AND run_id=?;" run-id)))) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');") ;; NEW BEHAVIOR: Look only at single run with run-id ;; ;; (define (db:get-running-stats dbstruct run-id) (define (db:get-count-tests-running-for-run-id dbstruct run-id) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:first-result db "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=? AND NOT (uname = 'n/a' AND item_path = '');" run-id)))) (define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat))) (if (not jobgroup) 0 ;; (let ((testnames '())) ;; get the testnames (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (testname) (set! testnames (cons testname testnames))) db "SELECT testname FROM test_meta WHERE jobgroup=?" jobgroup) ;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS? (if (not (null? testnames)) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:first-result db (conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('" (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 = '');" ;; 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 #f (lambda (db) (sqlite3:first-result db "SELECT count(id) FROM tests WHERE state in ('LAUNCHED','NOT_STARTED','REMOTEHOSTSTART','RUNNING','KILLREQ');")))) ;; map run-id, testname item-path to test-id (define (db:get-test-id dbstruct run-id testname item-path) (db:with-db dbstruct run-id #f (lambda (db) (db:first-result-default db "SELECT id FROM tests WHERE testname=? AND item_path=?;" #f ;; the default testname item-path)))) ;; overload the unused attemptnum field for the process id of the runscript or ;; ezsteps step script in progress ;; (define (db:test-set-top-process-pid dbstruct run-id test-id pid) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:execute db "UPDATE tests SET attemptnum=? WHERE id=?;" pid test-id)))) (define (db:test-get-top-process-pid dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (db) (db:first-result-default db "SELECT attemptnum FROM tests WHERE id=?;" #f test-id)))) (define db:test-record-fields '("id" "run_id" "testname" "state" "status" "event_time" "host" "cpuload" "diskfree" "uname" "rundir" "item_path" "run_duration" "final_logf" "comment" "shortdir" "attemptnum")) ;; fields *must* be a non-empty list ;; (define (db:field->number fieldname fields) (if (null? fields) #f (let loop ((hed (car fields)) (tal (cdr fields)) (indx 0)) (if (equal? fieldname hed) indx (if (null? tal) #f (loop (car tal)(cdr tal)(+ indx 1))))))) (define db:test-record-qry-selector (string-intersperse db:test-record-fields ",")) ;; NOTE: Use db:test-get* to access records ;; NOTE: This needs rundir decoding? Decide, decode here or where used? For the moment decode where used. (define (db:get-all-tests-info-by-run-id dbstruct run-id) (let* ((dbdat (if (vector? dbstruct) (db:get-db dbstruct run-id) dbstruct)) ;; still settling on when to use dbstruct or dbdat (db (db:dbdat-get-db dbdat)) (res '())) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 (set! res (cons (vector id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment shortdir attemptnum) res))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE state != 'DELETED' AND run_id=?;") run-id) res)) (define (db:replace-test-records dbstruct run-id testrecs) (db:with-db dbstruct run-id #t (lambda (db) (let* ((qmarks (string-intersperse (make-list (length db:test-record-fields) "?") ",")) (qrystr (conc "INSERT OR REPLACE INTO tests (" db:test-record-qry-selector ") VALUES (" qmarks ");")) (qry (sqlite3:prepare db qrystr))) (debug:print 0 "INFO: migrating test records for run with id " run-id) (sqlite3:with-transaction db (lambda () (for-each (lambda (rec) ;; (debug:print 0 "INFO: Inserting values: " (string-intersperse (map conc (vector->list rec)) ",") "\n") (apply sqlite3:execute qry (vector->list rec))) testrecs))) (sqlite3:finalize! qry))))) ;; map a test-id into the proper range ;; (define (db:adj-test-id mtdb min-test-id test-id) (if (>= test-id min-test-id) test-id (let loop ((new-id min-test-id)) (let ((test-id-found #f)) (sqlite3:for-each-row (lambda (id) (set! test-id-found id)) (db:dbdat-get-db mtdb) "SELECT id FROM tests WHERE id=?;" new-id) ;; if test-id-found then need to try again (if test-id-found (loop (+ new-id 1)) (begin (debug:print-info 0 "New test id " new-id " selected for test with id " test-id) (sqlite3:execute mtdb "UPDATE tests SET id=? WHERE id=?;" new-id test-id))))))) ;; move test ids into the 30k * run_id range ;; (define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) (debug:print-info 0 "Adjusting test ids in megatest.db for run " run-id) (let ((min-test-id (* run-id 30000))) (for-each (lambda (testrec) (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields)))) (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) testrecs))) ;; 1. move test ids into the 30k * run_id range ;; 2. move step ids into the 30k * run_id range ;; (define (db:prep-megatest.db-for-migration mtdb) (let* ((run-ids (db:get-all-run-ids mtdb))) (for-each (lambda (run-id) (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id))) (db:prep-megatest.db-adj-test-ids (db:dbdat-get-db mtdb) run-id testrecs))) run-ids))) ;; Get test data using test_id (define (db:get-test-info-by-id dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)))) ;; Use db:test-get* to access ;; Get test data using test_ids. NB// Only works within a single run!! ;; (define (db:get-test-info-by-ids dbstruct run-id test-ids) (db:with-db dbstruct run-id #f (lambda (db) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 (set! res (cons (apply vector a b) res))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id in (" (string-intersperse (map conc test-ids) ",") ");")) res)))) (define (db:get-test-info dbstruct run-id testname item-path) (db:with-db dbstruct run-id #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row (lambda (a . b) (set! res (apply vector a b))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE testname=? AND item_path=?;") test-name item-path) res)))) (define (db:test-get-rundir-from-test-id dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (db) (db:first-result-default db "SELECT rundir FROM tests WHERE id=?;" #f ;; default result test-id)))) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile) (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,?,?,?);" test-id teststep-name state-in status-in (current-seconds) (if comment comment "") (if logfile logfile ""))))) ;; db-get-test-steps-for-run (define (db:get-steps-for-test dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (db) (let* ((res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) (define (db:get-steps-data dbstruct run-id test-id) (db:with-db dbstruct run-id #f (lambda (db) (let ((res '())) (sqlite3:for-each-row (lambda (id test-id stepname state status event-time logfile) (set! res (cons (vector id test-id stepname state status event-time (if (string? logfile) logfile "")) res))) db "SELECT id,test_id,stepname,state,status,event_time,logfile FROM test_steps WHERE status != 'DELETED' AND test_id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-id) (reverse res))))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== ;; WARNING: Do NOT call this for the parent test on an iterated test ;; Roll up test_data pass/fail results ;; look at the test_data status field, ;; if all are pass (any case) and the test status is PASS or NULL or '' then set test status to PASS. ;; if one or more are fail (any case) then set test status to PASS, non "pass" or "fail" are ignored (define (db:test-data-rollup dbstruct run-id test-id status) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (fail-count 0) (pass-count 0)) (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (fcount pcount) (set! fail-count fcount) (set! pass-count pcount)) db "SELECT (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail') AS fail_count, (SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') AS pass_count;" test-id test-id) ;; Now rollup the counts to the central megatest.db (db:general-call dbdat 'pass-fail-counts (list pass-count fail-count test-id)) ;; if the test is not FAIL then set status based on the fail and pass counts. (db:general-call dbdat 'test_data-pf-rollup (list test-id test-id test-id test-id)))) (define (db:csv->test-data dbstruct run-id test-id csvdata) (debug:print 4 "test-id " test-id ", csvdata: " csvdata) (let* ((dbdat (db:get-db dbstruct run-id)) (db (db:dbdat-get-db dbdat)) (csvlist (csv->list (make-csv-reader (open-input-string csvdata) '((strip-leading-whitespace? #t) (strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata))) (for-each (lambda (csvrow) (let* ((padded-row (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9)) (category (list-ref padded-row 0)) (variable (list-ref padded-row 1)) (value (any->number-if-possible (list-ref padded-row 2))) (expected (any->number-if-possible (list-ref padded-row 3))) (tol (any->number-if-possible (list-ref padded-row 4))) ;; >, <, >=, <=, or a number (units (list-ref padded-row 5)) (comment (list-ref padded-row 6)) (status (let ((s (list-ref padded-row 7))) (if (and (string? s)(or (string-match (regexp "^\\s*$") s) (string-match (regexp "^n/a$") s))) #f s))) ;; if specified on the input then use, else calculate (type (list-ref padded-row 8))) ;; look up expected,tol,units from previous best fit test if they are all either #f or '' (debug:print 4 "BEFORE: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment " type: " type) (if (and (or (not expected)(equal? expected "")) (or (not tol) (equal? expected "")) (or (not units) (equal? expected ""))) (let-values (((new-expected new-tol new-units)(tdb:get-prev-tol-for-test tdb test-id category variable))) (set! expected new-expected) (set! tol new-tol) (set! units new-units))) (debug:print 4 "AFTER: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) ;; calculate status if NOT specified (if (and (not status)(number? expected)(number? value)) ;; need expected and value to be numbers (if (number? tol) ;; if tol is a number then we do the standard comparison (let* ((max-val (+ expected tol)) (min-val (- expected tol)) (result (and (>= value min-val)(<= value max-val)))) (debug:print 4 "max-val: " max-val " min-val: " min-val " result: " result) (set! status (if result "pass" "fail"))) (set! status ;; NB// need to assess each one (i.e. not return operator since need to act if not valid op. (case (string->symbol tol) ;; tol should be >, <, >=, <= ((>) (if (> value expected) "pass" "fail")) ((<) (if (< value expected) "pass" "fail")) ((>=) (if (>= value expected) "pass" "fail")) ((<=) (if (<= value expected) "pass" "fail")) (else (conc "ERROR: bad tol comparator " tol)))))) (debug:print 4 "AFTER2: category: " category " variable: " variable " value: " value ", expected: " expected " tol: " tol " units: " units " status: " status " comment: " comment) (db:delay-if-busy dbdat) (sqlite3:execute db "INSERT OR REPLACE INTO test_data (test_id,category,variable,value,expected,tol,units,comment,status,type) VALUES (?,?,?,?,?,?,?,?,?,?);" test-id category variable value expected tol units (if comment comment "") status type))) csvlist))) ;;====================================================================== ;; Misc. test related queries ;;====================================================================== (define (db:get-run-ids-matching-target dbstruct keynames target res runname testpatt statepatt statuspatt) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat)) (row-ids '()) (keystr (string-intersperse (map (lambda (key val) (conc key " like '" val "'")) keynames (string-split target "/")) " AND ")) ;; (testqry (tests:match->sqlqry testpatt)) (runsqry (sqlite3:prepare db (conc "SELECT id FROM runs WHERE " keystr " AND runname LIKE '" runname "';")))) ;; (debug:print 8 "db:test-get-paths-matching-keynames-target-new\n runsqry=" runsqry "\n tstsqry=" testqry) (sqlite3:for-each-row (lambda (rid) (set! row-ids (cons rid row-ids))) runsqry) (sqlite3:finalize! runsqry) row-ids)) (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)) (tstsqry (conc "SELECT rundir FROM tests WHERE " testqry " AND state LIKE '" statepatt "' AND status LIKE '" statuspatt "' ORDER BY event_time ASC;"))) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (p) (set! res (cons p res))) db tstsqry) res)))) (define (db:test-toplevel-num-items dbstruct run-id testname) (db:with-db dbstruct run-id #f (lambda (db) (let ((res 0)) (sqlite3:for-each-row (lambda (num-items) (set! res num-items)) db "SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state NOT IN ('DELETED');" run-id testname) res)))) ;;====================================================================== ;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS ;;====================================================================== ;; NOTE: Can remove the regex and base64 encoding for zmq (define (db:obj->string obj) (case *transport-type* ;; ((fs) obj) ((http fs) (string-substitute (regexp "=") "_" (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda ()(serialize obj))))) #t)) ((zmq)(with-output-to-string (lambda ()(serialize obj)))) (else obj))) (define (db:string->obj msg) (case *transport-type* ;; ((fs) msg) ((http fs) (if (string? msg) (with-input-from-string (z3:decode-buffer (base64:base64-decode (string-substitute (regexp "_") "=" msg #t))) (lambda ()(deserialize))) (begin (debug:print 0 "ERROR: reception failed. Received " msg " but cannot translate it.") #f))) ;; crude reply for when things go awry ((zmq)(with-input-from-string msg (lambda ()(deserialize)))) (else msg))) (define (db:test-set-status-state dbstruct run-id test-id status state msg) (let ((dbdat (db:get-db dbstruct run-id))) (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (db:general-call dbdat 'set-test-start-time (list test-id))) (if msg (db:general-call dbdat 'state-status-msg (list state status msg test-id)) (db:general-call dbdat 'state-status (list state status test-id))))) (define (db:roll-up-pass-fail-counts dbstruct run-id test-name item-path status) (if (and (not (equal? item-path "")) (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP" "LAUNCHED"))) (let ((dbdat (db:get-db dbstruct run-id))) (db:general-call dbdat 'update-pass-fail-counts (list test-name test-name test-name)) (if (equal? status "RUNNING") (db:general-call dbdat 'top-test-set-running (list test-name)) (if (equal? status "LAUNCHED") (db:general-call dbdat 'top-test-set (list "LAUNCHED" test-name)) (db:general-call dbdat 'top-test-set-per-pf-counts (list test-name run-id test-name test-name test-name)))) #f) #f)) (define (db:tests-register-test dbstruct run-id test-name item-path) (db:with-db dbstruct run-id #t (lambda (db) (sqlite3:execute db 'register-test run-id test-name item-path)))) (define (db:test-get-logfile-info dbstruct run-id test-name) (db:with-db dbstruct run-id #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row (lambda (path final_logf) ;; (let ((path (sdb:qry 'getstr path-id)) ;; (final_logf (sdb:qry 'getstr final_logf-id))) (set! logf final_logf) (set! res (list path final_logf)) (if (directory? path) (debug:print 2 "Found path: " path) (debug:print 2 "No such path: " path))) ;; ) db "SELECT rundir,final_logf FROM tests WHERE testname=? AND item_path='';" test-name) res)))) ;;====================================================================== ;; A G R E G A T E D T R A N S A C T I O N D B W R I T E S ;;====================================================================== (define db:queries (list '(update-run-duration "UPDATE tests SET run_duration=? WHERE id=?;") ;; TESTS '(register-test "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');") ;; Test state and status '(set-test-state "UPDATE tests SET state=? WHERE id=?;") '(set-test-status "UPDATE tests SET state=? WHERE id=?;") '(state-status "UPDATE tests SET state=?,status=? WHERE id=?;") ;; DONE '(state-status-msg "UPDATE tests SET state=?,status=?,comment=? WHERE id=?;") ;; DONE ;; Test comment '(set-test-comment "UPDATE tests SET comment=? WHERE id=?;") '(set-test-start-time "UPDATE tests SET event_time=strftime('%s','now') WHERE id=?;") ;; DONE '(pass-fail-counts "UPDATE tests SET pass_count=?,fail_count=? WHERE id=?;") ;; test_data-pf-rollup is used to set a tests PASS/FAIL based on the pass/fail info from the steps '(test_data-pf-rollup "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' WHEN (SELECT pass_count FROM tests WHERE id=?) > 0 AND (SELECT status FROM tests WHERE id=?) NOT IN ('WARN','FAIL') THEN 'PASS' ELSE status END WHERE id=?;") ;; DONE '(test-set-log "UPDATE tests SET final_logf=? WHERE id=?;") ;; DONE ;; '(test-set-rundir-by-test-id "UPDATE tests SET rundir=? WHERE id=?") ;; DONE ;; '(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=?;") '(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-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')), pass_count=(SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status IN ('PASS','WARN','WAIVED')) WHERE testname=? AND item_path='';") ;; DONE '(top-test-set "UPDATE tests SET state=? WHERE testname=? AND item_path='';") ;; DONE '(top-test-set-running "UPDATE tests SET state='RUNNING' WHERE testname=? AND item_path='';") ;; DONE '(top-test-set-per-pf-counts "UPDATE tests SET state=CASE WHEN (SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status NOT IN ('TEN_STRIKES','BLOCKED') AND state in ('RUNNING','NOT_STARTED','LAUNCHED','REMOTEHOSTSTART')) > 0 THEN 'RUNNING' ELSE 'COMPLETED' END, status=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state IN ('NOT_STARTED','BLOCKED')) > 0 THEN 'FAIL' WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' WHEN (SELECT count(id) FROM tests WHERE testname=? AND item_path != '' AND status = 'SKIP') > 0 THEN 'SKIP' ELSE 'UNKNOWN' END WHERE testname=? AND item_path='';") ;; DONE ;; STEPS '(delete-test-step-records "UPDATE test_steps SET status='DELETED' WHERE test_id=?;") '(delete-test-data-records "UPDATE test_data SET status='DELETED' WHERE test_id=?;") ;; using status since no state field )) (define (db:lookup-query qry-name) (let ((q (alist-ref qry-name db:queries))) (if q (car q) #f))) ;; do not run these as part of the transaction (define db:special-queries '(rollup-tests-pass-fail ;; db:roll-up-pass-fail-counts ;; WHY NOT!? login immediate flush sync set-verbosity killserver )) (define (db:login dbstruct calling-path calling-version run-id client-signature) (cond ((not (equal? calling-path *toppath*)) (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*)) ((not (equal? *run-id* run-id)) (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*)) ((not (equal? megatest-version calling-version)) (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version)) (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) (define (db:general-call dbdat stmtname params) (let ((query (let ((q (alist-ref (if (string? stmtname) (string->symbol stmtname) stmtname) db:queries))) (if q (car q) #f)))) (db:delay-if-busy dbdat) (apply sqlite3:execute (db:dbdat-get-db dbdat) query params) #t)) ;; BUG or Sillyness, why do I return #t instead of the query result? ;; get the previous records for when these tests were run where all keys match but runname ;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests ;; can use wildcards. Also can likely be factored in with get test paths? ;; ;; Run this remotely!! ;; (define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat)) (keys (db:get-keys db)) (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id (db:delay-if-busy dbdat) (sqlite3:for-each-row (lambda (a . b) (set! keyvals (cons a b))) db (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id) (if (not keyvals) '() (let ((prev-run-ids '())) (apply sqlite3:for-each-row (lambda (id) (set! prev-run-ids (cons id prev-run-ids))) db (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id))) ;; 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 dbstruct run-id 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))) (if (or (not stored-test) (and stored-test (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test)))) ;; this test is younger, store it in the hash (hash-table-set! tests-hash full-testname testdat)))) results) (if (null? tal) (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests (loop (car tal)(cdr tal)))))))))) (define (db:delay-if-busy dbdat #!key (count 6)) (if (not (configf:lookup *configdat* "server" "delay-on-busy")) (and dbdat (db:dbdat-get-db dbdat)) (if dbdat (let* ((dbpath (db:dbdat-get-path dbdat)) (db (db:dbdat-get-db dbdat)) ;; we'll return this so (db:delay--if-busy can be called inline (dbfj (conc dbpath "-journal"))) (if (handle-exceptions exn (begin (debug:print-info 0 "WARNING: failed to test for existance of " dbfj) (thread-sleep! 1) (db:delay-if-busy count (- count 1))) (file-exists? dbfj)) (case count ((6) (thread-sleep! 0.2) (db:delay-if-busy count: 5)) ((5) (thread-sleep! 0.4) (db:delay-if-busy count: 4)) ((4) (thread-sleep! 0.8) (db:delay-if-busy count: 3)) ((3) (thread-sleep! 1.6) (db:delay-if-busy count: 2)) ((2) (thread-sleep! 3.2) (db:delay-if-busy count: 1)) ((1) (thread-sleep! 6.4) (db:delay-if-busy count: 0)) (else (debug:print-info 0 "delaying db access due to high database load.") (thread-sleep! 12.8)))) db) "bogus result from db:delay-if-busy"))) (define (db:test-get-records-for-index-file dbstruct run-id test-name) (let ((res '())) (db:with-db dbstruct run-id #f (lambda (db) (sqlite3:for-each-row (lambda (id itempath state status run_duration logf comment) (set! res (cons (vector id itempath state status run_duration logf comment) res))) db "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE testname=? AND item_path != '';" test-name) res)))) ;;====================================================================== ;; Tests meta data ;;====================================================================== ;; read the record given a testname (define (db:testmeta-get-record dbstruct testname) (let ((res #f)) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup) (set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup))) db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;" testname) res)))) ;; create a new record for a given testname (define (db:testmeta-add-record dbstruct testname) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:execute db "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname)))) ;; update one of the testmeta fields (define (db:testmeta-update-field dbstruct testname field value) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:execute db (conc "UPDATE test_meta SET " field "=? WHERE testname=?;") value testname)))) (define (db:testmeta-get-all dbstruct) (db:with-db dbstruct #f #f (lambda (db) (let ((res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") res)))) ;;====================================================================== ;; M I S C M A N A G E M E N T I T E M S ;;====================================================================== ;; A routine to map itempaths using a itemmap (define (db:compare-itempaths patha pathb itemmap) (debug:print-info 6 "ITEMMAP is " itemmap) (if itemmap (let* ((mapparts (string-split itemmap)) (pattern (car mapparts)) (replacement (if (> (length mapparts) 1) (cadr mapparts) ""))) (if replacement (equal? (string-substitute pattern replacement patha) (string-substitute pattern replacement pathb)) (equal? (string-substitute pattern "" patha) (string-substitute pattern "" pathb)))) (equal? patha pathb))) ;; the new prereqs calculation, looks also at itempath if specified ;; all prereqs must be met: ;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f)) (if (or (not waitons) (null? waitons)) '() (let* ((unmet-pre-reqs '()) (result '())) (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items ;; next should be using mt:get-tests-for-run? (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... (let* ((state (db:test-get-state test)) |
︙ | ︙ | |||
2570 2571 2572 2573 2574 2575 2576 | ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) | < < < < < < < < < < < < < < < < < < > > | | 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 | ;; if the test is not found then clearly the waiton is not met... ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) (if (not ever-seen) (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) waitons) (delete-duplicates result)))) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== ;; NOT REWRITTEN YET!!!!! ;; runspatt is a comma delimited list of run patterns ;; keypatt-alist must contain *all* keys with an associated pattern: '( ("KEY1" "%") .. ) (define (db:extract-ods-file dbstruct outputfile keypatt-alist runspatt pathmod) (let* ((keysstr (string-intersperse (map car keypatt-alist) ",")) (keyqry (string-intersperse (map (lambda (p)(conc (car p) " LIKE ? ")) keypatt-alist) " AND ")) (numkeys (length keypatt-alist)) (test-ids '()) (windows (and pathmod (substring-index "\\" pathmod))) (tempdir (conc "/tmp/" (current-user-name) "/" runspatt "_" (random 10000) "_" (current-process-id))) (runsheader (append (list "Run Id" "Runname") ; 0 1 |
︙ | ︙ | |||
2715 2716 2717 2718 2719 2720 2721 | ;; brutal clean up (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") ;; This is a list of all procs that write to the db ;; | | | | | | | | | | | | | | | | | < | | < | | 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 | ;; brutal clean up (system "rm -rf tempdir"))) ;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%") ;; This is a list of all procs that write to the db ;; ;; (define *db:all-write-procs* ;; (list ;; db:set-var ;; db:del-var ;; db:register-run ;; db:set-comment-for-run ;; db:delete-run ;; db:update-run-event_time ;; db:lock/unlock-run ;; db:delete-test-step-records ;; db:delete-test-records ;; db:delete-tests-for-run ;; db:delete-old-deleted-test-records ;; db:set-tests-state-status ;; db:test-set-state-status-by-id ;; db:test-set-state-status-by-run-id-testname ;; db:testmeta-add-record ;; db:csv->test-data ;; )) |
Modified db_records.scm from [02b88af351] to [858bdddce0].
|
| > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 89 90 91 92 93 94 95 | ;;====================================================================== ;; dbstruct ;;====================================================================== ;; ;; -path-|-megatest.db ;; |-db-|-main.db ;; |-monitor.db ;; |-sdb.db ;; |-fdb.db ;; |-1.db ;; |-<N>.db ;; ;; ;; Accessors for a dbstruct ;; (define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) ;; ( db path ) (define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1)) ;; ( db path ) (define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2)) (define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3)) (define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4)) ;; ( db path ) (define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5)) ;; ( db #f ) (define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6)) (define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7)) (define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8)) (define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9)) (define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10)) ;; ( db path ) (define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11)) (define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12)) ;; ( db path ) ;; (define-inline (dbr:dbstruct-get-main-path vec) (vector-ref vec 13)) ;; (define-inline (dbr:dbstruct-get-rundb-path vec) (vector-ref vec 14)) ;; (define-inline (dbr:dbstruct-get-run-id vec) (vector-ref vec 13)) (define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val)) (define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val)) (define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val)) (define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val)) (define-inline (dbr:dbstruct-set-rundb! vec val)(vector-set! vec 4 val)) (define-inline (dbr:dbstruct-set-inmem! vec val)(vector-set! vec 5 val)) (define-inline (dbr:dbstruct-set-mtime! vec val)(vector-set! vec 6 val)) (define-inline (dbr:dbstruct-set-rtime! vec val)(vector-set! vec 7 val)) (define-inline (dbr:dbstruct-set-stime! vec val)(vector-set! vec 8 val)) (define-inline (dbr:dbstruct-set-inuse! vec val)(vector-set! vec 9 val)) (define-inline (dbr:dbstruct-set-refdb! vec val)(vector-set! vec 10 val)) (define-inline (dbr:dbstruct-set-locdbs! vec val)(vector-set! vec 11 val)) (define-inline (dbr:dbstruct-set-olddb! vec val)(vector-set! vec 12 val)) (define-inline (dbr:dbstruct-set-main-path! vec val)(vector-set! vec 13 val)) (define-inline (dbr:dbstruct-set-rundb-path! vec val)(vector-set! vec 14 val)) ; (define-inline (dbr:dbstruct-set-run-id! vec val)(vector-set! vec 13 val)) ;; constructor for dbstruct ;; (define (make-dbr:dbstruct #!key (path #f)(local #f)) (let ((v (make-vector 15 #f))) (dbr:dbstruct-set-path! v path) (dbr:dbstruct-set-local! v local) (dbr:dbstruct-set-locdbs! v (make-hash-table)) v)) (define (dbr:dbstruct-get-localdb v run-id) (hash-table-ref/default (dbr:dbstruct-get-locdbs v) run-id #f)) (define (dbr:dbstruct-set-localdb! v run-id db) (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db)) (define (make-db:test)(make-vector 20)) (define-inline (db:test-get-id vec) (vector-ref vec 0)) (define-inline (db:test-get-run_id vec) (vector-ref vec 1)) (define-inline (db:test-get-testname vec) (vector-ref vec 2)) (define-inline (db:test-get-state vec) (vector-ref vec 3)) (define-inline (db:test-get-status vec) (vector-ref vec 4)) (define-inline (db:test-get-event_time vec) (vector-ref vec 5)) (define-inline (db:test-get-host vec) (vector-ref vec 6)) (define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) (define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) (define-inline (db:test-get-uname vec) (vector-ref vec 9)) ;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) (define-inline (db:test-get-rundir vec) (vector-ref vec 10)) (define-inline (db:test-get-item-path vec) (vector-ref vec 11)) (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) (define-inline (db:test-get-comment vec) (vector-ref vec 14)) (define-inline (db:test-get-process_id vec) (vector-ref vec 16)) ;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) ;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) (define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) (define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) (define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) |
︙ | ︙ | |||
34 35 36 37 38 39 40 | ;; Is a test a toplevel? ;; (define (db:test-get-is-toplevel vec) (and (equal? (db:test-get-item-path vec) "") ;; test is not an item (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run | < < < < | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | ;; Is a test a toplevel? ;; (define (db:test-get-is-toplevel vec) (and (equal? (db:test-get-item-path vec) "") ;; test is not an item (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run ;; make-vector-record "" db mintest id run_id testname state status event_time item_path ;; (define (make-db:mintest)(make-vector 7)) (define-inline (db:mintest-get-id vec) (vector-ref vec 0)) (define-inline (db:mintest-get-run_id vec) (vector-ref vec 1)) (define-inline (db:mintest-get-testname vec) (vector-ref vec 2)) (define-inline (db:mintest-get-state vec) (vector-ref vec 3)) |
︙ | ︙ | |||
105 106 107 108 109 110 111 | ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Run steps ;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time (define (make-db:step)(make-vector 7)) | | | | | | | | | | | | | | | | | | | | | | | | | < < < | 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 204 205 206 207 208 209 210 211 212 | ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Run steps ;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time (define (make-db:step)(make-vector 7)) (define-inline (tdb:step-get-id vec) (vector-ref vec 0)) (define-inline (tdb:step-get-test_id vec) (vector-ref vec 1)) (define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) (define-inline (tdb:step-get-state vec) (vector-ref vec 3)) (define-inline (tdb:step-get-status vec) (vector-ref vec 4)) (define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) (define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) (define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) (define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) (define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) ;; The steps table (define (make-db:steps-table)(make-vector 5)) (define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) (define-inline (tdb:steps-table-get-start vec) (vector-ref vec 1)) (define-inline (tdb:steps-table-get-end vec) (vector-ref vec 2)) (define-inline (tdb:steps-table-get-status vec) (vector-ref vec 3)) (define-inline (tdb:steps-table-get-runtime vec) (vector-ref vec 4)) (define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) ;; The data structure for handing off requests via wire (define (make-cdb:packet)(make-vector 6)) (define-inline (cdb:packet-get-client-sig vec) (vector-ref vec 0)) (define-inline (cdb:packet-get-qtype vec) (vector-ref vec 1)) (define-inline (cdb:packet-get-immediate vec) (vector-ref vec 2)) (define-inline (cdb:packet-get-query-sig vec) (vector-ref vec 3)) |
︙ | ︙ |
Added dbwars/NOTES version [8f8ee6c6d0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Before using prepare: matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert Adding 1047 test3 item/39 host0-0.3-200000-240-this one sucks eh? (added 51886 records so far) Adding 1122 test5 item/52 host2-0.2-200000-120-this is a good one eh? (added 78889 records so far) Adding 1050 test7 item/31 host1-0.1-100000-120-this is a good one eh? (added 110641 records so far) create-tests ran register-test 144000 times in 41.0 seconds After using prepare: matt@xena:/tmp/megatest/dbwars$ csc sqlite3-test.scm && ./sqlite3-test insert Adding 1082 test4 item/74 host1-0.3-100000-120-this is a good one eh? (added 61281 records so far) Adding 1138 test7 item/43 host2-0.3-200000-120-this is a good one eh? (added 109001 records so far) Adding 1023 test9 item/00 host0-0.2-100000-240-this one sucks eh? (added 143878 records so far) create-tests ran register-test 144000 times in 38.0 seconds After moving the prepare outside the call (so it isn't done each time): matt@xena:/tmp/megatest/dbwars$ ./sqlite3-test insert Adding 1042 test4 item/59 host0-0.3-200000-120-this is a good one eh? (added 63401 records so far) Adding 1011 test6 item/40 host0-0.1-200000-120-this one sucks eh? (added 94906 records so far) Adding 1076 test9 item/34 host1-0.2-200000-120-just eh, eh? (added 139035 records so far) create-tests ran register-test 144000 times in 33.0 seconds Using sql-de-lite with very similar code: matt@xena:/tmp/megatest/dbwars$ ./sql-de-lite-test insert Adding 1029 test4 item/53 host0-0.2-200000-240- (added 64252 records so far) Adding 1134 test7 item/64 host2-0.3-100000-240-this is a good one eh? (added 105973 records so far) create-tests ran register-test 144000 times in 31.0 seconds |
Added dbwars/sql-de-lite-test.scm version [004f7cb8d7].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | (use sql-de-lite) (include "test-common.scm") (define db (open-database "test.db")) (exec (sql db test-table-defn)) (exec (sql db syncsetup)) (define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time) (exec stmth ;; (sql db test-insert) run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)) (let ((stmth (sql db test-insert))) (create-tests stmth)) (close-database db) |
Added dbwars/sqlite3-test.scm version [338a298923].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | (use sqlite3) (include "test-common.scm") (define db (open-database "test.db")) (execute db test-table-defn) (execute db syncsetup) (define (register-test stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time) (execute stmth run-id testname host cpuload diskfree uname rundir shortdir item-path state status final-logf run-duration comment event-time)) (let ((stmth (prepare db test-insert))) (create-tests stmth) (finalize! stmth)) (finalize! db) |
Added dbwars/test-common.scm version [02dcd9f2da].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 128 129 | (use srfi-18 srfi-69 apropos) (define args (argv)) (if (not (eq? (length args) 2)) (begin (print "Usage: sqlitecompare [insert|update]") (exit 0))) (define action (string->symbol (cadr args))) (system "rm -f test.db") (define test-table-defn "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER, testname TEXT, host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, diskfree INTEGER DEFAULT -1, uname TEXT DEFAULT 'n/a', rundir TEXT DEFAULT 'n/a', shortdir TEXT DEFAULT '', item_path TEXT DEFAULT '', state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'FAIL', attemptnum INTEGER DEFAULT 0, final_logf TEXT DEFAULT 'logs/final.log', logdat BLOB, run_duration INTEGER DEFAULT 0, comment TEXT DEFAULT '', event_time TIMESTAMP, fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, 1=in progress, 2=yes CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path) );") (define test-insert "INSERT INTO tests (run_id,testname,host,cpuload,diskfree,uname,rundir,shortdir,item_path,state,status,final_logf,run_duration,comment,event_time) values (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? );") (define syncsetup "PRAGMA synchronous = OFF;") (define tests '("test0" "test1" "test2" "test3" "test4" "test5" "test6" "test7" "test8" "test9")) (define items '()) (for-each (lambda (n) (for-each (lambda (m) (set! items (cons (conc "item/" n m) items))) '(0 1 2 3 4 5 6 7 8 9))) '(0 1 2 3 4 5 6 7 8 9)) (define hosts '("host0" "host1" "host2")) ;; "host3" "host4" "host5" "host6" "host7" "host8" "host9")) (define cpuloads '(0.1 0.2 0.3)) ;; 0.4 0.5 0.6 0.7 0.8 0.9)) (define diskfrees '(100000 200000)) ;; 300000 400000 500000 600000 700000 800000 900000)) (define uname "Linux xena 3.5.0-40-generic #62~precise1-Ubuntu SMP Fri Aug 23 17:59:10 UTC 2013 i686 i686 i386 GNU/Linux") (define basedir "/mfs/matt/data/megatest/runs/testing") (define final-logf "finallog.html") (define run-durations (list 120 240)) ;; 260)) (define comments '("" "this is a good one eh?" "this one sucks eh?" "just eh, eh?")) (define run-ids (make-hash-table)) (define max-run-id 1000) (define (test-factors->run-id host cpuload diskfree run-duration comment) (let* ((factor (conc host "-" cpuload "-" diskfree "-" run-duration "-" comment)) (run-id (hash-table-ref/default run-ids factor #f))) (if run-id (list run-id factor) (let ((new-id (+ max-run-id 1))) (set! max-run-id new-id) (hash-table-set! run-ids factor new-id) (list new-id factor))))) (define (create-tests stmth) (let ((num-created 0) (last-print (current-seconds)) (start-time (current-seconds))) (for-each (lambda (test) (for-each (lambda (item) (for-each (lambda (host) (for-each (lambda (cpuload) (for-each (lambda (diskfree) (for-each (lambda (run-duration) (for-each (lambda (comment) (let* ((run-id-dat (test-factors->run-id host cpuload diskfree run-duration comment)) (run-id (car run-id-dat)) (factor (cadr run-id-dat)) (curr-time (current-seconds))) (if (> (- curr-time last-print) 10) (begin (print "Adding " run-id " " test " " item " " factor " (added " num-created " records so far)") (set! last-print curr-time))) (set! num-created (+ num-created 1)) (register-test stmth ;; db run-id test ;; testname host cpuload diskfree uname (conc basedir "/" test "/" item) ;; rundir (conc test "/" item) ;; shortdir item ;; item-path "NOT_STARTED" ;; state "NA" ;; status final-logf run-duration comment (current-seconds)))) comments)) run-durations)) diskfrees)) cpuloads)) hosts)) items)) tests) (print "create-tests ran register-test " num-created " times in " (- (current-seconds) start-time) " seconds"))) |
Modified dcommon.scm from [a40d1c9411] to [31fd59f2b3].
︙ | ︙ | |||
125 126 127 128 129 130 131 | ;; TO-DO ;; 1. Make "data" hash-table hierarchial store of all displayed data ;; 2. Update synchash to understand "get-runs", "get-tests" etc. ;; 3. Add extraction of filters to synchash calls ;; ;; Mode is 'full or 'incremental for full refresh or incremental refresh | | | | 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 | ;; TO-DO ;; 1. Make "data" hash-table hierarchial store of all displayed data ;; 2. Update synchash to understand "get-runs", "get-tests" etc. ;; 3. Add extraction of filters to synchash calls ;; ;; Mode is 'full or 'incremental for full refresh or incremental refresh (define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id) (let* (;; count and offset => #f so not used ;; the synchash calls modify the "data" hash (get-runs-sig (conc (client:get-signature) " get-runs")) (get-tests-sig (conc (client:get-signature) " get-tests")) (get-details-sig (conc (client:get-signature) " get-test-details")) ;; test-ids to get and display are indexed on window-id in curr-test-ids hash (test-ids (hash-table-values (dboard:data-get-curr-test-ids *data*))) (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data runname #f #f keypatts)) (tests-detail-changes (if (not (null? test-ids)) (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids) '())) ;; Now can calculate the run-ids (run-hash (hash-table-ref/default data get-runs-sig #f)) (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '())) (test-changes (synchash:client-get 'db:get-tests-for-runs-mindata get-tests-sig 0 data run-ids testpatt states statuses #f)) |
︙ | ︙ | |||
226 227 228 229 230 231 232 | (testname (db:mintest-get-testname test)) (itempath (db:mintest-get-item_path test)) (fullname (conc testname "/" itempath)) (dispname (if (string=? itempath "") testname (conc " " itempath))) (rownum (hash-table-ref/default testname-to-row fullname #f)) (test-path (append run-path (if (equal? itempath "") (list testname) | | > > > > > > | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 | (testname (db:mintest-get-testname test)) (itempath (db:mintest-get-item_path test)) (fullname (conc testname "/" itempath)) (dispname (if (string=? itempath "") testname (conc " " itempath))) (rownum (hash-table-ref/default testname-to-row fullname #f)) (test-path (append run-path (if (equal? itempath "") (list testname) (list testname itempath)))) (tb (dboard:data-get-tests-tree *data*))) (print "INFONOTE: run-path: " run-path) (tree:add-node (dboard:data-get-tests-tree *data*) "Runs" test-path userdata: (conc "test-id: " test-id)) (let ((node-num (tree:find-node tb (cons "Runs" test-path))) (color (car (gutils:get-color-for-state-status state status)))) (debug:print 0 "node-num: " node-num ", color: " color) (iup:attribute-set! tb (conc "COLOR" node-num) color)) (hash-table-set! (dboard:data-get-path-test-ids *data*) test-path test-id) (if (not rownum) (let ((rownums (hash-table-values testname-to-row))) (set! rownum (if (null? rownums) 1 (+ 1 (apply max rownums)))) (hash-table-set! testname-to-row fullname rownum) |
︙ | ︙ | |||
356 357 358 359 360 361 362 | ;; General data ;; (define (dcommon:general-info) (let ((general-matrix (iup:matrix #:alignment1 "ALEFT" #:expand "YES" ;; "HORIZONTAL" #:numcol 1 | | | | | | | | | | | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 | ;; General data ;; (define (dcommon:general-info) (let ((general-matrix (iup:matrix #:alignment1 "ALEFT" #:expand "YES" ;; "HORIZONTAL" #:numcol 1 #:numlin 2 #:numcol-visible 1 #:numlin-visible 2))) (iup:attribute-set! general-matrix "WIDTH1" "150") (iup:attribute-set! general-matrix "0:1" "About this Megatest area") ;; User (this is not always obvious - it is common to run as a different user (iup:attribute-set! general-matrix "1:0" "User") (iup:attribute-set! general-matrix "1:1" (current-user-name)) ;; Megatest area ;; (iup:attribute-set! general-matrix "2:0" "Area") ;; (iup:attribute-set! general-matrix "2:1" *toppath*) ;; Megatest version (iup:attribute-set! general-matrix "2:0" "Version") (iup:attribute-set! general-matrix "2:1" (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) general-matrix)) (define (dcommon:run-stats dbstruct) (let* ((stats-matrix (iup:matrix expand: "YES")) (changed #f) (updater (lambda () (let* ((run-stats (db:get-run-stats dbstruct)) (indices (common:sparse-list-generate-index run-stats)) ;; proc: set-cell)) (row-indices (car indices)) (col-indices (cadr indices)) (max-row (if (null? row-indices) 1 (apply max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (apply max (map cadr col-indices)))) (max-visible (max (- *num-tests* 15) 3)) |
︙ | ︙ | |||
438 439 440 441 442 443 444 | (set! dashboard:update-summary-tab updater) (iup:attribute-set! stats-matrix "WIDTHDEF" "40") (iup:vbox ;; (iup:label "Run statistics" #:expand "HORIZONTAL") stats-matrix))) (define (dcommon:servers-table) | > | | | | > | | < < | | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 | (set! dashboard:update-summary-tab updater) (iup:attribute-set! stats-matrix "WIDTHDEF" "40") (iup:vbox ;; (iup:label "Run statistics" #:expand "HORIZONTAL") stats-matrix))) (define (dcommon:servers-table) (let* ((tdbdat (tasks:open-db)) (colnum 0) (rownum 0) (servers-matrix (iup:matrix #:expand "YES" #:numcol 7 #:numcol-visible 7 #:numlin-visible 5 )) (colnames (list "Id" "MTver" "Pid" "Host" "Interface:OutPort" "RunTime" "State" "RunId")) (updater (lambda () (let ((servers (tasks:get-all-servers (db:delay-if-busy tdbdat)))) (iup:attribute-set! servers-matrix "NUMLIN" (length servers)) ;; (set! colnum 0) ;; (for-each (lambda (colname) ;; ;; (print "colnum: " colnum " colname: " colname) ;; (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) ;; (set! colnum (+ 1 colnum))) ;; colnames) (set! rownum 1) (for-each (lambda (server) (set! colnum 0) (let* ((vals (list (vector-ref server 0) ;; Id (vector-ref server 9) ;; MT-Ver (vector-ref server 1) ;; Pid (vector-ref server 2) ;; Hostname (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6))) ;; (vector-ref server 5) ;; Pubport ;; (vector-ref server 10) ;; Last beat ;; (vector-ref server 6) ;; Start time ;; (vector-ref server 7) ;; Priority ;; (vector-ref server 8) ;; State (vector-ref server 8) ;; State (vector-ref server 12) ;; RunId ))) (for-each (lambda (val) (let* ((row-col (conc rownum ":" colnum)) (curr-val (iup:attribute servers-matrix row-col))) (if (not (equal? (conc val) curr-val)) (begin (iup:attribute-set! servers-matrix row-col val) (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)))) (set! colnum (+ 1 colnum)))) vals) (set! rownum (+ rownum 1))) (iup:attribute-set! servers-matrix "REDRAW" "ALL")) servers))))) (set! colnum 0) (for-each (lambda (colname) (iup:attribute-set! servers-matrix (conc "0:" colnum) colname) (iup:attribute-set! servers-matrix "FITTOTEXT" (conc "C" colnum)) (set! colnum (+ colnum 1))) colnames) (set! dashboard:update-servers-table updater) ;; (iup:attribute-set! servers-matrix "WIDTHDEF" "40") ;; (iup:hbox ;; (iup:vbox ;; (iup:button "Start" ;; ;; #:size "50x" ;; #:expand "YES" ;; #:action (lambda (obj) ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" ;; "megatest -server - &"))) ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) ;; (system cmd)))) ;; (iup:button "Stop" ;; #:expand "YES" ;; ;; #:size "50x" ;; #:action (lambda (obj) ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" ;; "megatest -stop-server 0 &"))) ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) ;; (system cmd)))) ;; (iup:button "Restart" ;; #:expand "YES" ;; ;; #:size "50x" ;; #:action (lambda (obj) ;; (let ((cmd (conc ;; "xterm -geometry 180x20 -e \"" ;; "megatest -stop-server 0;megatest -server - &"))) ;; ;; ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &"))) ;; (system cmd))))) ;; servers-matrix ;; ))) servers-matrix )) ;; The main menu (define (dcommon:main-menu) (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top) (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options (iup:menu-item "Open" action: (lambda (obj) (iup:show (iup:file-dialog)) (print "File->open " obj))) |
︙ | ︙ | |||
567 568 569 570 571 572 573 | (boxh 25) (gapx 20) (gapy 30) (tests-hash (hash-table-ref tests-draw-state 'tests-info)) (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) (hash-table-set! tests-draw-state 'xtorig xtorig) (hash-table-set! tests-draw-state 'ytorig ytorig) | | > | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 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 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 | (boxh 25) (gapx 20) (gapy 30) (tests-hash (hash-table-ref tests-draw-state 'tests-info)) (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) (hash-table-set! tests-draw-state 'xtorig xtorig) (hash-table-set! tests-draw-state 'ytorig ytorig) (let ((longest-str (if (null? sorted-testnames) " " (car (sort sorted-testnames (lambda (a b)(>= (string-length a)(string-length b)))))))) (let-values (((x-max y-max) (canvas-text-size cnv longest-str))) (if (> x-max boxw)(set! boxw (+ 10 x-max))))) ;; (print "sizex: " sizex " sizey: " sizey " font: " (canvas-font cnv) " originx: " originx " originy: " originy " xtorig: " xtorig " ytorig: " ytorig " xadj: " xadj " yadj: " yadj) (if (not (null? sorted-testnames)) (let loop ((hed (car (reverse sorted-testnames))) (tal (cdr (reverse sorted-testnames))) (llx xtorig) (lly ytorig) (urx (+ xtorig boxw)) (ury (+ ytorig boxh))) ; (print "hed " hed " llx " llx " lly " lly " urx " urx " ury " ury) (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) ;; data used by mouse click calc. keep the wacky order for now. (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) ;; (list llx lly boxw boxh)) ;; NB// Swap ury and lly (if (not (null? tal)) ;; leave a column of space to the right to list items (let ((have-room (if #t ;; put "auto" here where some form of auto rearanging can be done (> (* 3 (+ boxw gapx)) (- urx xtorig)) (< urx (- sizex boxw gapx boxw))))) ;; is there room for another column? (loop (car tal) (cdr tal) (if have-room (+ llx boxw gapx) xtorig) ;; have room, (if have-room lly (+ lly boxh gapy)) (if have-room (+ urx boxw gapx) (+ xtorig boxw)) (if have-room ury (+ ury boxh gapy))))))))) (define (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames) (let* ((scalef (hash-table-ref/default tests-draw-state 'scalef 8)) (test-browse-xoffset (hash-table-ref tests-draw-state 'test-browse-xoffset)) (test-browse-yoffset (hash-table-ref tests-draw-state 'test-browse-yoffset)) (xtorig (+ test-browse-xoffset (* (/ sizex 2) scalef (- 0.5 xadj)))) ;; (- xadj 1)))) (ytorig (+ test-browse-yoffset (* (/ sizey 2) scalef (- yadj 0.5)))) (xdelta (- (hash-table-ref tests-draw-state 'xtorig) xtorig)) (ydelta (- (hash-table-ref tests-draw-state 'ytorig) ytorig)) (tests-hash (hash-table-ref tests-draw-state 'tests-info)) (selected-tests (hash-table-ref tests-draw-state 'selected-tests ))) (hash-table-set! tests-draw-state 'xtorig xtorig) (hash-table-set! tests-draw-state 'ytorig ytorig) (if (not (null? sorted-testnames)) (let loop ((hed (car (reverse sorted-testnames))) (tal (cdr (reverse sorted-testnames)))) (let* ((tvals (hash-table-ref tests-hash hed)) (llx (+ xdelta (list-ref tvals 0))) (lly (+ ydelta (list-ref tvals 4))) (boxw (list-ref tvals 5)) (boxh (list-ref tvals 6)) (urx (+ llx boxw)) (ury (+ lly boxh))) (dcommon:draw-test cnv llx lly boxw boxh hed (hash-table-ref/default selected-tests hed #f)) (hash-table-set! tests-hash hed (list llx urx (- sizey ury)(- sizey lly) lly boxw boxh)) (if (not (null? tal)) ;; leave a column of space to the right to list items (loop (car tal) (cdr tal)))))))) ;;====================================================================== ;; S T E P S ;;====================================================================== ;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!! ;; ;; get a pretty table to summarize steps ;; (define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f)) ;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area))) ;; 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 (dcommon:get-compressed-steps dbstruct run-id test-id) (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) (comprsteps (dcommon:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) (let ((s (vector-ref x 1))) (if (number? s)(seconds->time-string s) s)) (let ((s (vector-ref x 2))) (if (number? s)(seconds->time-string s) s)) (vector-ref x 3) ;; status (vector-ref x 4) (vector-ref x 5))) ;; time delta (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) (time-b (vector-ref b 1))) (if (and (number? time-a)(number? time-b)) (if (< time-a time-b) #t (if (eq? time-a time-b) (string<? (conc (vector-ref a 2)) (conc (vector-ref b 2))) #f)) (string<? (conc time-a)(conc time-b))))))))) (define (dcommon:populate-steps teststeps steps-matrix) (let ((max-row 0)) (if (null? teststeps) (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS") (let loop ((hed (car teststeps)) (tal (cdr teststeps)) (rownum 1) (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) (let ((val (vector-ref hed (- colnum 1))) (mtrx-rc (conc rownum ":" colnum))) (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) (if (< colnum 6) (loop hed tal rownum (+ colnum 1)) (if (not (null? tal)) (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) (if (> max-row 0) (begin ;; we are going to speculatively clear rows until we find a row that is already cleared (let loop ((rownum (+ max-row 1)) (colnum 0) (deleted #f)) ;; (debug:print-info 0 "cleaning " rownum ":" colnum) (let* ((next-row (if (eq? colnum 6) (+ rownum 1) rownum)) (next-col (if (eq? colnum 6) 1 (+ colnum 1))) (mtrx-rc (conc rownum ":" colnum)) (curr-val (iup:attribute steps-matrix mtrx-rc))) ;; (debug:print-info 0 "cleaning " rownum ":" colnum " currval= " curr-val) (if (and (string? curr-val) (not (equal? curr-val ""))) (begin (iup:attribute-set! steps-matrix mtrx-rc "") (loop next-row next-col #t)) (if (eq? colnum 6) ;; not done, didn't get a full blank row (if deleted (loop next-row next-col #f)) ;; exit on this not met (loop next-row next-col deleted))))) (iup:attribute-set! steps-matrix "REDRAW" "ALL"))))) |
Modified docs/html/megatest.html from [637f8cb216] to [d407d07366].
1 2 3 4 5 6 | <?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> <head> <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/> <meta name="generator" content="http://www.nongnu.org/elyxer/"/> | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | <?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> <head> <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/> <meta name="generator" content="http://www.nongnu.org/elyxer/"/> <meta name="create-date" content="2014-01-25"/> <link rel="stylesheet" href="http://elyxer.nongnu.org/lyx.css" type="text/css" media="all"/> <title>Megatest User Manual</title> </head> <body> <div id="globalWrapper"> <div class="Standard"> |
︙ | ︙ | |||
780 781 782 783 784 785 786 | <h2 class="Subsection"> <a class="toc" name="toc-Subsection-13.1">13.1</a> Monitor logic </h2> <div class="Standard"> Note: The monitor is usable but incomplete as of Megatest v1.31. Click on the “Monitor” button on the dashboard to start the monitor and give it a try. </div> <div class="Standard"> | | | 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 | <h2 class="Subsection"> <a class="toc" name="toc-Subsection-13.1">13.1</a> Monitor logic </h2> <div class="Standard"> Note: The monitor is usable but incomplete as of Megatest v1.31. Click on the “Monitor” button on the dashboard to start the monitor and give it a try. </div> <div class="Standard"> <img class="embedded" src="monitor-state-diagram.png" alt="figure monitor-state-diagram.png" style="max-width: 531px; max-height: 465px;"/> </div> <h1 class="Section"> <a class="toc" name="toc-Section-14">14</a> Reference </h1> <h2 class="Subsection"> <a class="toc" name="toc-Subsection-14.1">14.1</a> Configuration file Syntax |
︙ | ︙ | |||
1706 1707 1708 1709 1710 1711 1712 | </h1> <h1 class="Section"> <a class="toc" name="toc-Appendix-B">B</a> References </h1> <hr class="footer"/> <div class="footer" id="generated-by"> | | | 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 | </h1> <h1 class="Section"> <a class="toc" name="toc-Appendix-B">B</a> References </h1> <hr class="footer"/> <div class="footer" id="generated-by"> Document generated by <a href="http://elyxer.nongnu.org/">eLyXer 1.2.3 (2011-08-31)</a> on <span class="create-date">2014-01-25T22:27:14.268137</span> </div> </div> </body> </html> |
Modified docs/html/monitor-state-diagram.png from [14f1bb59f3] to [83e4cb1ce3].
cannot compute difference between binary files
Modified docs/manual/Makefile from [c10ea440f6] to [038153bc89].
1 2 3 4 5 6 7 | megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt asciidoc megatest_manual.txt dos2unix megatest_manual.html clean: rm -f megatest_manual.html | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | all : server.pdf megatest_manual.html client.pdf megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt asciidoc megatest_manual.txt dos2unix megatest_manual.html server.pdf : server.dot dot -Tpdf server.dot > server.pdf client.pdf : client.dot dot -Tpdf client.dot > client.pdf clean: rm -f megatest_manual.html |
Added docs/manual/client.dot version [23d472e170].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | digraph G { // put client after server so server_start node is visible // subgraph cluster_2 { node [style=filled,shape=box]; "client:setup start" -> runremote_lookup_server; runremote_lookup_server -> login_attempt [label="have server"]; runremote_lookup_server -> monitordb_lookup_server [label="no server"]; monitordb_lookup_server -> login_attempt [label="have server"]; monitordb_lookup_server -> server_start_remote [label="no server"]; server_start_remote -> delay_2_sec; delay_2_sec -> runremote_lookup_server; login_attempt -> "rmt:send-receive_start" [label="login sucessful"]; "rmt:send-receive_start" -> "rmt:send-receive_start"; "rmt:send-receive_start" -> runremote_lookup_server [label=exception]; login_attempt -> clear_runremote [label="login failed"]; "remove_running > 5s" -> runremote_lookup_server; subgraph cluster_3 { node [style=filled]; clear_runremote -> "remove_running > 5s"; } label = "client:setup"; color=green; } } |
Modified docs/manual/howto.txt from [ad8e0484e1] to [b28c4b0da6].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | How To Do Things ================ Tricks ------ This section is a compendium of a various useful tricks for debugging, configuring and generally getting the most out of Megatest. Debugging Tricks ---------------- Examining The Environment ~~~~~~~~~~~~~~~~~~~~~~~~~ During Config File Processing ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Organising Your Tests and Tasks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | > > > > > > > > > > > > > > > > > > > > > > > | | < < | < < < | > | > > | 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 | How To Do Things ================ Tricks ------ This section is a compendium of a various useful tricks for debugging, configuring and generally getting the most out of Megatest. Limiting your running jobs -------------------------- The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously. In your testconfig: ---------------- [test_meta] jobgroup group1 ---------------- In your megatest.config: --------------- [jobgroups] group1 10 custdes 4 --------------- Debugging Tricks ---------------- Examining The Environment ~~~~~~~~~~~~~~~~~~~~~~~~~ During Config File Processing ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Organising Your Tests and Tasks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ---------------------------- [tests-paths] 1 #{get misc parent}/simplerun/tests ---------------------------- ------------------- [setup] ------------------- The runscript method is a brute force way to run scripts where the user is responsible for setting STATE and STATUS ------------------- runscript main.csh ------------------- Debugging Server Problems ~~~~~~~~~~~~~~~~~~~~~~~~~ ---------------- sudo lsof -i sudo netstat -lptu sudo netstat -tulpn ---------------- |
Modified docs/manual/megatest_manual.html from [25f641c57e] to [191f1255c5].
1 2 3 4 5 | <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en"> <head> <meta http-equiv="Content-Type" content="application/xhtml+xml; charset=UTF-8" /> | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en"> <head> <meta http-equiv="Content-Type" content="application/xhtml+xml; charset=UTF-8" /> <meta name="generator" content="AsciiDoc 8.6.9" /> <title>The Megatest Users Manual</title> <style type="text/css"> /* Shared CSS for AsciiDoc xhtml11 and html5 backends */ /* Default font. */ body { font-family: Georgia,serif; |
︙ | ︙ | |||
83 84 85 86 87 88 89 | ul, ol, li > p { margin-top: 0; } ul > li { color: #aaa; } ul > li > * { color: black; } | | > > > > > > | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | ul, ol, li > p { margin-top: 0; } ul > li { color: #aaa; } ul > li > * { color: black; } .monospaced, code, pre { font-family: "Courier New", Courier, monospace; font-size: inherit; color: navy; padding: 0; margin: 0; } pre { white-space: pre-wrap; } #author { color: #527bbd; font-weight: bold; font-size: 1.1em; } #email { |
︙ | ︙ | |||
215 216 217 218 219 220 221 | div.exampleblock > div.content { border-left: 3px solid #dddddd; padding-left: 0.5em; } div.imageblock div.content { padding-left: 0; } | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 | div.exampleblock > div.content { border-left: 3px solid #dddddd; padding-left: 0.5em; } div.imageblock div.content { padding-left: 0; } span.image img { border-style: none; vertical-align: text-bottom; } a.image:visited { color: white; } dl { margin-top: 0.8em; margin-bottom: 0.8em; } dt { |
︙ | ︙ | |||
411 412 413 414 415 416 417 | /* * xhtml11 specific * * */ | < < < < < < | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 | /* * xhtml11 specific * * */ div.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } div.tableblock > table { border: 3px solid #527bbd; } |
︙ | ︙ | |||
450 451 452 453 454 455 456 | /* * html5 specific * * */ | < < < < < < | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 | /* * html5 specific * * */ table.tableblock { margin-top: 1.0em; margin-bottom: 1.5em; } thead, p.tableblock.header { font-weight: bold; color: #527bbd; |
︙ | ︙ | |||
535 536 537 538 539 540 541 542 543 544 545 546 547 548 | body.manpage div.sectionbody { margin-left: 3em; } @media print { body.manpage div#toc { display: none; } } </style> <script type="text/javascript"> /*<![CDATA[*/ var asciidoc = { // Namespace. ///////////////////////////////////////////////////////////////////// // Table Of Contents generator | > > | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 | body.manpage div.sectionbody { margin-left: 3em; } @media print { body.manpage div#toc { display: none; } } </style> <script type="text/javascript"> /*<![CDATA[*/ var asciidoc = { // Namespace. ///////////////////////////////////////////////////////////////////// // Table Of Contents generator |
︙ | ︙ | |||
735 736 737 738 739 740 741 | /*]]>*/ </script> </head> <body class="book"> <div id="header"> <h1>The Megatest Users Manual</h1> <span id="author">Matt Welland</span><br /> | | | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 | /*]]>*/ </script> </head> <body class="book"> <div id="header"> <h1>The Megatest Users Manual</h1> <span id="author">Matt Welland</span><br /> <span id="email"><code><<a href="mailto:matt@kiatoa.com">matt@kiatoa.com</a>></code></span><br /> <span id="revnumber">version 1.0,</span> <span id="revdate">April 2012</span> </div> <div id="content"> <div class="sect1"> <h2 id="_preface">Preface</h2> <div class="sectionbody"> |
︙ | ︙ | |||
779 780 781 782 783 784 785 | which can launch jobs on local and remote Linux hosts. Currently megatest uses the network filesystem to call home to your master sqlite3 database.</p></div> </div> </div> </div> <h1 id="_road_map">Road Map</h1> | | > > > > | > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | < > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < > < < < < < < < < < < < < | < < < < < < > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < | | 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 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 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 | which can launch jobs on local and remote Linux hosts. Currently megatest uses the network filesystem to call home to your master sqlite3 database.</p></div> </div> </div> </div> <h1 id="_road_map">Road Map</h1> <div class="paragraph"><p>Note 1: This road-map is tentative and subject to change without notice.</p></div> <div class="paragraph"><p>Note 2: Starting over. Old plan is commented out.</p></div> <div class="sect1"> <h2 id="_current_items">Current Items</h2> <div class="sectionbody"> <div class="sect2"> <h3 id="_ww05_migrate_to_inmem_db">ww05 - migrate to inmem-db</h3> <div class="paragraph"><p>Keep as much the same as possible. Add internal reference to almost eliminate contention on db(s).</p></div> <div class="olist arabic"><ol class="arabic"> <li> <p> Add internal reference db </p> </li> <li> <p> Verify that actions are accessing correct db </p> <div class="olist loweralpha"><ol class="loweralpha"> <li> <p> -runtests - inmem </p> </li> <li> <p> -list-runs - local (but not megatest.db) </p> </li> <li> <p> dashboard - local (but not megatest.db) </p> </li> </ol></div> </li> <li> <p> Mirror db to /var/tmp… </p> </li> <li> <p> Dashboard read db from per-run db. </p> </li> <li> <p> Dashboard read db from /var/tmp </p> </li> <li> <p> Runs register in tasks table in monitor.db </p> </li> <li> <p> Server polls tasks table for next action (in addition?) </p> </li> <li> <p> Change run loop to execute in server, triggered by call to polling of tasks table </p> </li> </ol></div> </div> </div> </div> <h1 id="_getting_started">Getting Started</h1> <div class="openblock"> <div class="title">Getting started with Megatest</div> <div class="content"> <div class="paragraph"><p>How to install Megatest and set it up for running your regressions and continuous integration process.</p></div> </div></div> |
︙ | ︙ | |||
1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 | <h1 id="_how_to_do_things">How To Do Things</h1> <div class="sect1"> <h2 id="_tricks">Tricks</h2> <div class="sectionbody"> <div class="paragraph"><p>This section is a compendium of a various useful tricks for debugging, configuring and generally getting the most out of Megatest.</p></div> </div> </div> <div class="sect1"> <h2 id="_debugging_tricks">Debugging Tricks</h2> <div class="sectionbody"> <div class="sect2"> <h3 id="_examining_the_environment">Examining The Environment</h3> <div class="sect3"> <h4 id="_during_config_file_processing">During Config File Processing</h4> </div> <div class="sect3"> <h4 id="_organising_your_tests_and_tasks">Organising Your Tests and Tasks</h4> | > > > > > > > > > > > > > > > > > > > < | | | | > > | < > | | > > > | | | > > | > | > > > > > > > > > | | > > > > > > | > > > | | > > > | | | | | > > > | > > > > > > | > > > | | > > > | > > > | | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < > > > | | 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 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 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 1057 1058 1059 1060 1061 1062 1063 1064 1065 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 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 | <h1 id="_how_to_do_things">How To Do Things</h1> <div class="sect1"> <h2 id="_tricks">Tricks</h2> <div class="sectionbody"> <div class="paragraph"><p>This section is a compendium of a various useful tricks for debugging, configuring and generally getting the most out of Megatest.</p></div> </div> </div> <div class="sect1"> <h2 id="_limiting_your_running_jobs">Limiting your running jobs</h2> <div class="sectionbody"> <div class="paragraph"><p>The following example will limit a test in the jobgroup "group1" to no more than 10 tests simultaneously.</p></div> <div class="paragraph"><p>In your testconfig:</p></div> <div class="listingblock"> <div class="content"> <pre><code>[test_meta] jobgroup group1</code></pre> </div></div> <div class="paragraph"><p>In your megatest.config:</p></div> <div class="listingblock"> <div class="content"> <pre><code>[jobgroups] group1 10 custdes 4</code></pre> </div></div> </div> </div> <div class="sect1"> <h2 id="_debugging_tricks">Debugging Tricks</h2> <div class="sectionbody"> <div class="sect2"> <h3 id="_examining_the_environment">Examining The Environment</h3> <div class="sect3"> <h4 id="_during_config_file_processing">During Config File Processing</h4> </div> <div class="sect3"> <h4 id="_organising_your_tests_and_tasks">Organising Your Tests and Tasks</h4> <div class="listingblock"> <div class="content"> <pre><code>[tests-paths] 1 #{get misc parent}/simplerun/tests</code></pre> </div></div> <div class="listingblock"> <div class="content"> <pre><code>[setup]</code></pre> </div></div> <div class="paragraph"><p>The runscript method is a brute force way to run scripts where the user is responsible for setting STATE and STATUS</p></div> <div class="listingblock"> <div class="content"> <pre><code>runscript main.csh</code></pre> </div></div> </div> </div> <div class="sect2"> <h3 id="_debugging_server_problems">Debugging Server Problems</h3> <div class="listingblock"> <div class="content"> <pre><code>sudo lsof -i sudo netstat -lptu sudo netstat -tulpn</code></pre> </div></div> </div> </div> </div> <h1 id="_reference">Reference</h1> <div class="sect1"> <h2 id="_the_first_chapter_of_the_second_part_2">The First Chapter of the Second Part</h2> <div class="sectionbody"> <div class="paragraph"><p>Chapters grouped into book parts are at level 1 and can contain sub-sections.</p></div> </div> </div> <div class="sect1"> <h2 id="_the_testconfig_file">The testconfig File</h2> <div class="sectionbody"> <div class="sect2"> <h3 id="_setup_section">Setup section</h3> <div class="sect3"> <h4 id="_header">Header</h4> <div class="listingblock"> <div class="content"> <pre><code>[setup]</code></pre> </div></div> <div class="paragraph"><p>The runscript method is a brute force way to run scripts where the user is responsible for setting STATE and STATUS</p></div> <div class="listingblock"> <div class="content"> <pre><code>runscript main.csh</code></pre> </div></div> </div> </div> <div class="sect2"> <h3 id="_requirements_section">Requirements section</h3> <div class="sect3"> <h4 id="_header_2">Header</h4> <div class="listingblock"> <div class="content"> <pre><code>[requirements]</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_wait_on_other_tests">Wait on Other Tests</h4> <div class="listingblock"> <div class="content"> <pre><code># A normal waiton waits for the prior tests to be COMPLETED # and PASS, CHECK or WAIVED waiton test1 test2</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_mode">Mode</h4> <div class="paragraph"><p>The default (i.e. if mode is not specified) is normal. All pre-dependent tests must be COMPLETED and PASS, CHECK or WAIVED before the test will start</p></div> <div class="listingblock"> <div class="content"> <pre><code>mode normal</code></pre> </div></div> <div class="paragraph"><p>The toplevel mode requires only that the prior tests are COMPLETED.</p></div> <div class="listingblock"> <div class="content"> <pre><code>mode toplevel</code></pre> </div></div> <div class="paragraph"><p>A item based waiton will start items in a test when the same-named item is COMPLETED and PASS, CHECK or WAIVED in the prior test</p></div> <div class="listingblock"> <div class="content"> <pre><code>mode itemmatch</code></pre> </div></div> <div class="listingblock"> <div class="content"> <pre><code># With a toplevel test you may wish to generate your list # of tests to run dynamically # # waiton #{shell get-valid-tests-to-run.sh}</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_run_time_limit">Run time limit</h4> <div class="listingblock"> <div class="content"> <pre><code>runtimelim 1h 2m 3s # this will automatically kill the test if it runs for more than 1h 2m and 3s</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_skip">Skip</h4> </div> <div class="sect3"> <h4 id="_header_3">Header</h4> <div class="listingblock"> <div class="content"> <pre><code>[skip]</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_skip_on_still_running_tests">Skip on Still-running Tests</h4> <div class="listingblock"> <div class="content"> <pre><code># NB// If the prevrunning line exists with *any* value the test will # automatically SKIP if the same-named test is currently RUNNING prevrunning x</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_skip_if_a_file_exists">Skip if a File Exists</h4> <div class="listingblock"> <div class="content"> <pre><code>fileexists /path/to/a/file # skip if /path/to/a/file exists</code></pre> </div></div> </div> <div class="sect3"> <h4 id="_controlled_waiver_propagation">Controlled waiver propagation</h4> <div class="paragraph"><p>If test is FAIL and previous test in run with same MT_TARGET is WAIVED then apply the following rules from the testconfig: If a waiver check is specified in the testconfig apply the check and if it passes then set this FAIL to WAIVED</p></div> <div class="paragraph"><p>Waiver check has two parts, 1) a list of waiver, rulename, filepatterns and 2) the rulename script spec (note that "diff" and "logpro" are predefined)</p></div> <div class="listingblock"> <div class="content"> <pre><code>###### EXAMPLE FROM testconfig ######### # matching file(s) will be diff'd with previous run and logpro applied # if PASS or WARN result from logpro then WAIVER state is set # [waivers] # logpro_file rulename input_glob waiver_1 logpro lookittmp.log [waiver_rules] # This builtin rule is the default if there is no <waivername>.logpro file # diff diff %file1% %file2% # This builtin rule is applied if a <waivername>.logpro file exists # logpro diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html</code></pre> </div></div> </div> </div> <div class="sect2"> <h3 id="_ezsteps">Ezsteps</h3> <div class="paragraph"><p>To transfer the environment to the next step you can do the following:</p></div> <div class="listingblock"> <div class="content"> <pre><code>$MT_MEGATEST -env2file .ezsteps/${stepname}</code></pre> </div></div> </div> <div class="sect2"> <h3 id="_triggers">Triggers</h3> <div class="paragraph"><p>In your testconfig triggers can be specified</p></div> <div class="listingblock"> <div class="content"> <pre><code>[triggers] # Call script running.sh when test goes to state=RUNNING, status=PASS RUNNING/PASS running.sh # Call script running.sh any time state goes to RUNNING RUNNING/ running.sh # Call script onpass.sh any time status goes to PASS PASS/ onpass.sh</code></pre> </div></div> <div class="paragraph"><p>Scripts called will have; test-id test-rundir trigger, added to the commandline.</p></div> <div class="paragraph"><p>HINT</p></div> <div class="paragraph"><p>To start an xterm (useful for debugging), use a command line like the following:</p></div> <div class="listingblock"> <div class="content"> <pre><code>[triggers] COMPLETED/ xterm -e bash -s --</code></pre> </div></div> <div class="admonitionblock"> <table><tr> <td class="icon"> <div class="title">Note</div> </td> <td class="content">There is a trailing space after the --</td> </tr></table> </div> </div> <div class="sect2"> <h3 id="_megatest_internals">Megatest Internals</h3> <div class="imageblock graphviz"> <div class="content"> <img src="server.png" alt="server.png" /> </div> </div> </div> </div> </div> <div class="sect1"> <h2 id="_example_appendix">Appendix A: Example Appendix</h2> <div class="sectionbody"> <div class="paragraph"><p>One or more optional appendixes go here at section level zero.</p></div> <div class="sect2"> <h3 id="_appendix_sub_section">Appendix Sub-section</h3> <div class="admonitionblock"> <table><tr> <td class="icon"> <div class="title">Note</div> </td> <td class="content">Preface and appendix subsections start out of sequence at level 2 (level 1 is skipped). This only applies to multi-part book documents.</td> </tr></table> </div> </div> </div> </div> <div class="sect1"> <h2 id="_example_bibliography">Example Bibliography</h2> <div class="sectionbody"> <div class="paragraph"><p>The bibliography list is a style of AsciiDoc bulleted list.</p></div> <div class="ulist bibliography"><ul> <li> <p> <a id="taoup"></a>[taoup] Eric Steven Raymond. <em>The Art of Unix Programming</em>. Addison-Wesley. ISBN 0-13-142901-9. </p> </li> <li> <p> <a id="walsh-muellner"></a>[walsh-muellner] Norman Walsh & Leonard Muellner. <em>DocBook - The Definitive Guide</em>. O’Reilly & Associates. 1999. ISBN 1-56592-580-7. </p> </li> </ul></div> </div> </div> <div class="sect1"> <h2 id="_example_glossary">Example Glossary</h2> <div class="sectionbody"> <div class="paragraph"><p>Glossaries are optional. Glossaries entries are an example of a style of AsciiDoc labeled lists.</p></div> <div class="dlist glossary"><dl> <dt> A glossary term </dt> <dd> <p> The corresponding (indented) definition. </p> </dd> <dt> A second glossary term </dt> <dd> <p> The corresponding (indented) definition. </p> </dd> </dl></div> </div> </div> <div class="sect1"> <h2 id="_example_colophon">Example Colophon</h2> <div class="sectionbody"> <div class="paragraph"><p>Text at the end of a book describing facts about its production.</p></div> </div> </div> <div class="sect1"> <h2 id="_example_index">Example Index</h2> <div class="sectionbody"> </div> </div> </div> <div id="footnotes"><hr /></div> <div id="footer"> <div id="footer-text"> Version 1.0<br /> Last updated 2014-10-08 23:02:21 MST </div> </div> </body> </html> |
Modified docs/manual/megatest_manual.txt from [20ce759875] to [38919c0414].
︙ | ︙ | |||
46 47 48 49 50 51 52 53 54 55 56 57 58 59 | sqlite3 database. include::../plan.txt[] include::getting_started.txt[] include::writing_tests.txt[] include::howto.txt[] include::reference.txt[] [appendix] Example Appendix ================ One or more optional appendixes go here at section level zero. Appendix Sub-section | > > > > > > > > > | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | sqlite3 database. include::../plan.txt[] include::getting_started.txt[] include::writing_tests.txt[] include::howto.txt[] include::reference.txt[] Megatest Internals ~~~~~~~~~~~~~~~~~~ ["graphviz", "server.png"] ---------------------------------------------------------------------- include::server.dot[] ---------------------------------------------------------------------- [appendix] Example Appendix ================ One or more optional appendixes go here at section level zero. Appendix Sub-section |
︙ | ︙ |
Modified docs/manual/reference.txt from [6d8b51499a] to [eff8aa5426].
1 2 3 4 5 6 7 8 9 10 11 12 13 | Reference ========= The First Chapter of the Second Part ------------------------------------ Chapters grouped into book parts are at level 1 and can contain sub-sections. The testconfig File ------------------- Setup section | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | Reference ========= The First Chapter of the Second Part ------------------------------------ Chapters grouped into book parts are at level 1 and can contain sub-sections. The testconfig File ------------------- Setup section |
︙ | ︙ | |||
145 146 147 148 149 150 151 152 153 | To transfer the environment to the next step you can do the following: ---------------------------- $MT_MEGATEST -env2file .ezsteps/${stepname} ---------------------------- :numbered!: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | To transfer the environment to the next step you can do the following: ---------------------------- $MT_MEGATEST -env2file .ezsteps/${stepname} ---------------------------- Triggers ~~~~~~~~ In your testconfig triggers can be specified ----------------- [triggers] # Call script running.sh when test goes to state=RUNNING, status=PASS RUNNING/PASS running.sh # Call script running.sh any time state goes to RUNNING RUNNING/ running.sh # Call script onpass.sh any time status goes to PASS PASS/ onpass.sh ----------------- Scripts called will have; test-id test-rundir trigger, added to the commandline. HINT To start an xterm (useful for debugging), use a command line like the following: ----------------- [triggers] COMPLETED/ xterm -e bash -s -- ----------------- NOTE: There is a trailing space after the -- :numbered!: |
Added docs/manual/server.dot version [5b6f6b599f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | digraph G { subgraph cluster_1 { node [style=filled,shape=box]; check_available_queue -> remove_entries_over_10s_old; remove_entries_over_10s_old -> set_available [label="num_avail < 3"]; remove_entries_over_10s_old -> exit [label="num_avail > 2"]; set_available -> delay_2s; delay_2s -> check_place_in_queue; check_place_in_queue -> "http:transport-launch" [label="at head"]; check_place_in_queue -> exit [label="not at head"]; "client:login" -> "server:shutdown" [label="login failed"]; "server:shutdown" -> exit; subgraph cluster_2 { "http:transport-launch" -> "http:transport-run"; "http:transport-launch" -> "http:transport-keep-running"; "http:transport-keep-running" -> "tests running?"; "tests running?" -> "client:login" [label=yes]; "tests running?" -> "server:shutdown" [label=no]; "client:login" -> delay_5s [label="login ok"]; delay_5s -> "http:transport-keep-running"; } // start_server -> "server_running?"; // "server_running?" -> set_available [label="no"]; // "server_running?" -> delay_2s [label="yes"]; // delay_2s -> "still_running?"; // "still_running?" -> ping_server [label=yes]; // "still_running?" -> set_available [label=no]; // ping_server -> exit [label=alive]; // ping_server -> remove_server_record [label=dead]; // remove_server_record -> set_available; // set_available -> avail_delay [label="delay 3s"]; // avail_delay -> "first_in_queue?"; // // "first_in_queue?" -> set_running [label=yes]; // set_running -> get_next_port -> handle_requests; // "first_in_queue?" -> "dead_entry_in_queue?" [label=no]; // "dead_entry_in_queue?" -> "server_running?" [label=no]; // "dead_entry_in_queue?" -> "remove_dead_entries" [label=yes]; // remove_dead_entries -> "server_running?"; // // handle_requests -> start_shutdown [label="no traffic\nno running tests"]; // handle_requests -> shutdown_request; // start_shutdown -> shutdown_delay; // shutdown_request -> shutdown_delay; // shutdown_delay -> exit; label = "server:launch"; color=brown; } // client_start_server -> start_server; // handle_requests -> read_write; // read_write -> handle_requests; } |
Added docs/manual/server.pdf version [710fc5512e].
cannot compute difference between binary files
Added docs/manual/server.png version [a508d3edd1].
cannot compute difference between binary files
Modified docs/plan.txt from [a80831142b] to [0ead7d4df0].
1 2 3 | Road Map ======== | | > | > > | > > > > | > > | > > > | < | > > > | < < < > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | Road Map ======== Note 1: This road-map is tentative and subject to change without notice. Note 2: Starting over. Old plan is commented out. Current Items ------------- ww05 - migrate to inmem-db ~~~~~~~~~~~~~~~~~~~~~~~~~~ Keep as much the same as possible. Add internal reference to almost eliminate contention on db(s). . Add internal reference db . Verify that actions are accessing correct db .. -runtests - inmem .. -list-runs - local (but not megatest.db) .. dashboard - local (but not megatest.db) . Mirror db to /var/tmp... . Dashboard read db from per-run db. . Dashboard read db from /var/tmp . Runs register in tasks table in monitor.db . Server polls tasks table for next action (in addition?) . Change run loop to execute in server, triggered by call to polling of tasks table // ww32 // ~~~~ // // . Rerun step and or subsequent steps from gui // . Refresh test area files from gui // . Clean and re-run button // . Clean up STATE and STATUS handling. // .. Dashboard and Test control panel are reverse order - choose and fix // .. Move seldom used states and status to drop down selector // . Access test control panel when clicking on Run Summary tests // . Feature: -generate-index-tree // . Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2 // // ww33 // ~~~~ // // . http api available for use with Perl, Ruby etc. scripts // . megatest.config setup entries for: // .. run launching (e.g. /bin/sh %CMD% > /dev/null) // .. browser "konqueror %FNAME% // // ww34 // ~~~~ // // . Mark dependent tests for clean/rerun -rerun-downstream // . On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify // . Fix: refresh of gui sometimes fails on last item (race condition?) // // ww35 // ~~~~ // // . refdb: Add export of csv, json and sexp // . Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process. // . Re-work text interface wizards. Several bugs on record. Possibly convert to gui based. // . Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test // . Refactor Run Summary view, currently very clumsy // . Add option to show steps in Run Summary view // // ww36 // ~~~~ // // . Refactor guis for resizeablity // . Add filters to Run Summary view and Run Control view // . Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS... // . Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G // // Bin List // ~~~~~~~~ // // . Quality improvements // .. Server stutters occasionally // .. Large number of items or tests still has some issues. // .. Code refactoring // .. Replace remote process with true API using json (supports Web app also) // . Streamline the gui // .. Everything resizable // .. Less clutter // .. Tool tips // .. Filters on Run Summary, Summary and Run Control panel // .. Built in log viewer (partially implemented) // .. Refactor the test control panel // . Help and documentation // .. Complete the user manual (I’ve been working on this lately). // .. Online help in the gui // . Streamlined install // .. Deployed version (download a location independent ready to run binary bundle) // .. Install Makefile (in progress, needed for Mike to install on VMs) // .. Added option to compile IUP (needed for VMs) // . Server side run launching // . Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement). // . Launch process needs built in daemonizing (easy to do, just need to test it thoroughly). // . Wizards for creating tests, regression areas (current ones are text only and limited). // . Fully functional built in web service (currently you can browse runs but it is very simplistic). // . Wildcards in runconfigs: e.g. [p1271/9/%/%] // . Gui panels for editing megatest.config and runconfigs.config // . Fully isolated tests (no use of NFS to see regression area files) // . Windows version |
Added docs/results.pdf version [8c482a4606].
cannot compute difference between binary files
Modified ezsteps.scm from [5bdb7484d4] to [18ab86f9c8].
︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 | (import (prefix sqlite3 sqlite3:)) (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (define (ezsteps:run-from testdat start-step-name run-one) | > > > | > | 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 | (import (prefix sqlite3 sqlite3:)) (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (define (ezsteps:run-from testdat start-step-name run-one) (let* ((test-run-dir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())) (run-mutex (make-mutex)) (rollup-status 0) (exit-info (vector #t #t #t)) (test-id (db:test-get-id testdat)) (run-id (db:test-get-run_id testdat)) (test-name (db:test-get-testname testdat)) (kill-job #f)) ;; for future use (on re-factoring with launch.scm code (let loop ((count 5)) (if (file-exists? test-run-dir) (push-directory test-run-dir) (if (> count 0) (begin |
︙ | ︙ | |||
75 76 77 78 79 80 81 | (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t)) ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) | < | < | | | 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 | (if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t)) ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) (let processloop ((i 0)) (let-values (((pid-val exit-status exit-code)(process-wait pid #t))) (mutex-lock! run-mutex) (vector-set! exit-info 0 pid) (vector-set! exit-info 1 exit-status) (vector-set! exit-info 2 exit-code) (mutex-unlock! run-mutex) (if (eq? pid-val 0) (begin (thread-sleep! 1) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) (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) |
︙ | ︙ | |||
136 137 138 139 140 141 142 | (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop (loop (car tal) (cdr tal) stepname runflag)))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))) ;; Once done with step/steps update the test record ;; (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop (loop (car tal) (cdr tal) stepname runflag)))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))) ;; Once done with step/steps update the test record ;; (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) (testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr ;; Am I completed? (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test ) (new-status (cond |
︙ | ︙ |
Modified filedb.scm from [d77bc6ba17] to [91e90bcdc7].
︙ | ︙ | |||
21 22 23 24 25 26 27 | (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath))) (filedb:fdb-set-db! fdb db) (filedb:fdb-set-dbpath! fdb dbpath) (filedb:fdb-set-pathcache! fdb (make-hash-table)) (filedb:fdb-set-idcache! fdb (make-hash-table)) (filedb:fdb-set-partcache! fdb (make-hash-table)) | | > > > > > > > > | 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 | (dbexists (file-exists? dbpath)) (db (sqlite3:open-database dbpath))) (filedb:fdb-set-db! fdb db) (filedb:fdb-set-dbpath! fdb dbpath) (filedb:fdb-set-pathcache! fdb (make-hash-table)) (filedb:fdb-set-idcache! fdb (make-hash-table)) (filedb:fdb-set-partcache! fdb (make-hash-table)) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) (if (not dbexists) (begin (sqlite3:execute db "PRAGMA synchronous = OFF;") (sqlite3:execute db "CREATE TABLE names (id INTEGER PRIMARY KEY,name TEST);") ;; for future use - change path in paths table to path_id (sqlite3:execute db "CREATE INDEX name_index ON names (name);") ;; NB// We store a useful subset of file attributes but do not attempt to store all (sqlite3:execute db "CREATE TABLE paths (id INTEGER PRIMARY KEY, path TEXT, parent_id INTEGER, mode INTEGER DEFAULT -1, uid INTEGER DEFAULT -1, gid INTEGER DEFAULT -1, size INTEGER DEFAULT -1, mtime INTEGER DEFAULT -1);") (sqlite3:execute db "CREATE INDEX path_index ON paths (path,parent_id);") (sqlite3:execute db "CREATE TABLE bases (id INTEGER PRIMARY KEY,base TEXT, updated TIMESTAMP);"))) ;; close the sqlite3 db and open it as needed (filedb:finalize-db! fdb) (filedb:fdb-set-db! fdb #f) fdb)) (define (filedb:reopen-db fdb) (let ((db (sqlite3:open-database (filedb:fdb-get-dbpath fdb)))) (filedb:fdb-set-db! fdb db) (sqlite3:set-busy-handler! db (make-busy-timeout 136000)))) (define (filedb:finalize-db! fdb) (sqlite3:finalize! (filedb:fdb-get-db fdb))) (define (filedb:get-current-time-string) (string-chomp (time->string (seconds->local-time (current-seconds))))) (define (filedb:get-base-id db path) |
︙ | ︙ | |||
106 107 108 109 110 111 112 113 114 115 116 117 118 119 | (sqlite3:finalize! stmt))) (define (filedb:register-path fdb path #!key (save-stat #f)) (let* ((db (filedb:fdb-get-db fdb)) (pathcache (filedb:fdb-get-pathcache fdb)) (stat (if save-stat (file-stat path #t))) (id (hash-table-ref/default pathcache path #f))) (if id id (let ((plist (string-split path "/"))) (let loop ((head (car plist)) (tail (cdr plist)) (parent 0)) (let ((id (filedb:get-path-id db head parent)) (done (null? tail))) | > | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | (sqlite3:finalize! stmt))) (define (filedb:register-path fdb path #!key (save-stat #f)) (let* ((db (filedb:fdb-get-db fdb)) (pathcache (filedb:fdb-get-pathcache fdb)) (stat (if save-stat (file-stat path #t))) (id (hash-table-ref/default pathcache path #f))) (if (not db)(filedb:reopen-db fdb)) (if id id (let ((plist (string-split path "/"))) (let loop ((head (car plist)) (tail (cdr plist)) (parent 0)) (let ((id (filedb:get-path-id db head parent)) (done (null? tail))) |
︙ | ︙ | |||
212 213 214 215 216 217 218 219 220 221 222 223 224 225 | parent-id search-patt) res)) (define (filedb:get-path fdb id) (let* ((db (filedb:fdb-get-db fdb)) (idcache (filedb:fdb-get-idcache fdb)) (path (hash-table-ref/default idcache id #f))) (if path path (let loop ((curr-id id) (path "")) (let ((path-record (filedb:get-path-record fdb curr-id))) (if (not path-record) #f ;; this id has no path (let* ((parent-id (list-ref path-record 1)) (pname (list-ref path-record 0)) | > | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 | parent-id search-patt) res)) (define (filedb:get-path fdb id) (let* ((db (filedb:fdb-get-db fdb)) (idcache (filedb:fdb-get-idcache fdb)) (path (hash-table-ref/default idcache id #f))) (if (not db)(filedb:reopen-db fdb)) (if path path (let loop ((curr-id id) (path "")) (let ((path-record (filedb:get-path-record fdb curr-id))) (if (not path-record) #f ;; this id has no path (let* ((parent-id (list-ref path-record 1)) (pname (list-ref path-record 0)) |
︙ | ︙ |
Deleted fs-transport.scm version [8a07492e90].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Modified http-transport.scm from [b92335f5bd] to [907ced71b2].
︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | (declare (uses common)) (declare (uses db)) (declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses server)) (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") (define (http-transport:make-server-url hostport) (if (not hostport) #f | > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | (declare (uses common)) (declare (uses db)) (declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses server)) (declare (uses daemon)) (declare (uses portlogger)) (include "common_records.scm") (include "db_records.scm") (define (http-transport:make-server-url hostport) (if (not hostport) #f |
︙ | ︙ | |||
56 57 58 59 60 61 62 | (set! res adr))) (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) | | < < < < < < < < | | | < < < < < < | | > | > > > > > > > | | | | | | | | | | | | | | | | | | | | | > > > | | | | | | > > > > | | | < > | > > > > > | | | < | | | | | | | | > > | > > > > | > > | > > > > > > > > > | > > > > > > > > > | > > > > > | > > > > > > > > > > > > | | > > | > > > | | | | | > > | < > | > > > > | | | > > > > | | < < | > > > > > > > > > > > > > | | | > > | > | | > < < < < < < < < | < < < < | > > | | < | > > > | | | | > > > > > > | > | | | | > > | | | | > > > > > > > > > | > | > > > > | | > > > > > > > > > > | < < < | | > > | < | > | > > > > > > > > | > > > > > > > > > | > > > > | | | | | | | | | | | | | | | < | < < < | < | | | > | > > > > > | > | | > > > > > | | > > > > > > > | > | > > | | | > > > > > | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < > | > > | > > > > > > > > > > > > > | > | > > > | < > > > > | > > | | > | > > | > > | > | > | < < > > > > < < | 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 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 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 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 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 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 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 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 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 | (set! res adr))) (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) (define (http-transport:run hostn run-id server-id) (debug:print 2 "Attempting to start the server ...") (let* ((db #f) ;; (open-db)) ;; we don't want the server to be opening and closing the db unnecesarily (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (portlogger:open-run-close portlogger:find-port)) (link-tree-path (configf:lookup *configdat* "setup" "linktree"))) ;; (set! db *inmemdb*) (debug:print-info 0 "portlogger recommended port: " start-port) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! (handle-directory spiffy-directory-listing) ;; http-transport:handle-directory) ;; simple-directory-handler) ;; Setup the web server and a /ctrl interface ;; (vhost-map `(((* any) . ,(lambda (continue) ;; open the db on the first call ;; This is were we set up the database connections (let* (($ (request-vars source: 'both)) (dat ($ 'dat)) (res #f)) (cond ((equal? (uri-path (request-uri (current-request))) '(/ "api")) (send-response body: (api:process-request *inmemdb* $) ;; the $ is the request vars proc headers: '((content-type text/plain))) (mutex-lock! *heartbeat-mutex*) (set! *last-db-access* (current-seconds)) (mutex-unlock! *heartbeat-mutex*)) ;; This is the /ctrl path where data is handed to the server and ;; responses ;; ((equal? (uri-path (request-uri (current-request))) ;; '(/ "ctrl")) ;; (let* ((packet (db:string->obj dat)) ;; (qtype (cdb:packet-get-qtype packet))) ;; (debug:print-info 12 "server=> received packet=" packet) ;; (if (not (member qtype '(sync ping))) ;; (begin ;; (mutex-lock! *heartbeat-mutex*) ;; (set! *last-db-access* (current-seconds)) ;; (mutex-unlock! *heartbeat-mutex*))) ;; ;; (mutex-lock! *db:process-queue-mutex*) ;; trying a mutex ;; ;; (set! res (open-run-close db:process-queue-item open-db packet)) ;; (set! res (db:process-queue-item db packet)) ;; ;; (mutex-unlock! *db:process-queue-mutex*) ;; (debug:print-info 11 "Return value from db:process-queue-item is " res) ;; (send-response body: (conc "<head>ctrl data</head>\n<body>" ;; res ;; "</body>") ;; headers: '((content-type text/plain))))) ((equal? (uri-path (request-uri (current-request))) '(/ "")) (send-response body: (http-transport:main-page))) ((equal? (uri-path (request-uri (current-request))) '(/ "runs")) (send-response body: (http-transport:main-page))) ((equal? (uri-path (request-uri (current-request))) '(/ any)) (send-response body: "hey there!\n" headers: '((content-type text/plain)))) ((equal? (uri-path (request-uri (current-request))) '(/ "hey")) (send-response body: "hey there!\n" headers: '((content-type text/plain)))) (else (continue)))))))) (http-transport:try-start-server run-id ipaddrstr start-port server-id))) ;; This is recursively run by http-transport:run until sucessful ;; (define (http-transport:try-start-server run-id ipaddrstr portnum server-id) (let ((config-hostname (configf:lookup *configdat* "server" "hostname")) (tdbdat (tasks:open-db))) (debug:print-info 0 "http-transport:try-start-server run-id=" run-id " ipaddrsstr=" ipaddrstr " portnum=" portnum " server-id=" server-id " config-hostname=" config-hostname) (handle-exceptions exn (begin (print-error-message exn) (if (< portnum 64000) (begin (debug:print 0 "WARNING: attempt to start server failed. Trying again ...") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 "exn=" (condition->list exn)) (portlogger:open-run-close portlogger:set-failed portnum) (debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port") (thread-sleep! 0.1) ;; get_next_port goes here (http-transport:try-start-server run-id ipaddrstr (portlogger:open-run-close portlogger:find-port) server-id)) (begin (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server") (print "ERROR: Tried and tried but could not start the server")))) ;; any error in following steps will result in a retry (set! *server-info* (list ipaddrstr portnum)) (tasks:server-set-interface-port (db:delay-if-busy tdbdat) server-id ipaddrstr portnum) (debug:print 0 "INFO: Trying to start server on " ipaddrstr ":" portnum) ;; This starts the spiffy server ;; NEED WAY TO SET IP TO #f TO BIND ALL ;; (start-server bind-address: ipaddrstr port: portnum) (if config-hostname ;; this is a hint to bind directly (start-server port: portnum bind-address: (if (equal? config-hostname "-") ipaddrstr config-hostname)) (start-server port: portnum)) ;; (portlogger:open-run-close portlogger:set-port portnum "released") (tasks:server-force-clean-run-record (db:delay-if-busy tdbdat) run-id ipaddrstr portnum " http-transport:try-start-server") (debug:print 1 "INFO: server has been stopped")))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;;====================================================================== ;; C L I E N T S ;;====================================================================== (define *http-mutex* (make-mutex)) ;; NOTE: Large block of code from 32436b426188080f72fceb6894af541fbad9921e removed here ;; I'm pretty sure it is defunct. ;; This next block all imported en-mass from the api branch (define *http-requests-in-progress* 0) (define *http-connections-next-cleanup* (current-seconds)) (define (http-transport:get-time-to-cleanup) (let ((res #f)) (mutex-lock! *http-mutex*) (set! res (> (current-seconds) *http-connections-next-cleanup*)) (mutex-unlock! *http-mutex*) res)) (define (http-transport:inc-requests-count) (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*)) ;; Use this opportunity to slow things down iff there are too many requests in flight (if (> *http-requests-in-progress* 5) (begin (debug:print-info 0 "Whoa there buddy, ease up...") (thread-sleep! 1))) (mutex-unlock! *http-mutex*)) (define (http-transport:dec-requests-count proc) (mutex-lock! *http-mutex*) (proc) (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) (mutex-unlock! *http-mutex*)) (define (http-transport:dec-requests-count-and-close-all-connections) (set! *http-requests-in-progress* (- *http-requests-in-progress* 1)) (let loop ((etime (+ (current-seconds) 5))) ;; give up in five seconds (if (> *http-requests-in-progress* 0) (if (> etime (current-seconds)) (begin (thread-sleep! 0.05) (loop etime)) (debug:print 0 "ERROR: requests still in progress after 5 seconds of waiting. I'm going to pass on cleaning up http connections")) (close-all-connections!))) (set! *http-connections-next-cleanup* (+ (current-seconds) 10)) (mutex-unlock! *http-mutex*)) (define (http-transport:inc-requests-and-prep-to-close-all-connections) (mutex-lock! *http-mutex*) (set! *http-requests-in-progress* (+ 1 *http-requests-in-progress*))) ;; Send "cmd" with json payload "params" to serverdat and receive result ;; (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 "FATAL ERROR: http-transport:client-api-send-receive called with no server info") (exit 1)))) (res #f) (success #t)) (handle-exceptions exn (if (> numretries 0) (begin (mutex-unlock! *http-mutex*) (thread-sleep! 1) (handle-exceptions exn (debug:print 0 "WARNING: closing connections failed. Server at " fullurl " almost certainly dead") (close-all-connections!)) (debug:print 0 "WARNING: Failed to communicate with server, trying again, numretries left: " numretries) (http-transport:client-api-send-receive run-id serverdat cmd params numretries: (- numretries 1))) (begin (mutex-unlock! *http-mutex*) (tasks:kill-server-run-id run-id) #f)) (begin (debug:print-info 11 "fullurl=" fullurl ", cmd=" cmd ", params=" params ", run-id=" run-id "\n") ;; set up the http-client here (max-retry-attempts 1) ;; consider all requests indempotent (retry-request? (lambda (request) #f)) ;; send the data and get the response ;; extract the needed info from the http data and ;; process and return it. (let* ((send-recieve (lambda () (mutex-lock! *http-mutex*) ;; (condition-case (with-input-from-request "http://localhost"; #f read-lines) ;; ((exn http client-error) e (print e))) (set! res (vector success (handle-exceptions exn (begin (set! success #f) (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ". Killing associated server to allow clean retry.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (hash-table-delete! *runremote* run-id) ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine. #f) (with-input-from-request ;; was dat fullurl (list (cons 'key "thekey") (cons 'cmd cmd) (cons 'params params)) read-string)))) ;; Shouldn't this be a call to the managed call-all-connections stuff above? (close-all-connections!) (mutex-unlock! *http-mutex*) )) (time-out (lambda () (thread-sleep! 45) #f)) (th1 (make-thread send-recieve "with-input-from-request")) (th2 (make-thread time-out "time out"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) (thread-terminate! th2) (debug:print-info 11 "got res=" res) res))))) ;; careful closing of connections stored in *runremote* ;; (define (http-transport:close-connections run-id) (let* ((server-dat (hash-table-ref/default *runremote* run-id #f))) (if (vector? server-dat) (let ((api-dat (http-transport:server-dat-get-api-uri server-dat))) (close-connection! api-dat) #t) #f))) (define (make-http-transport:server-dat)(make-vector 5)) (define (http-transport:server-dat-get-iface vec) (vector-ref vec 0)) (define (http-transport:server-dat-get-port vec) (vector-ref vec 1)) (define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2)) (define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3)) (define (http-transport:server-dat-get-api-req vec) (vector-ref vec 4)) (define (http-transport:server-dat-get-last-access vec) (vector-ref vec 5)) (define (http-transport:server-dat-make-url vec) (if (and (http-transport:server-dat-get-iface vec) (http-transport:server-dat-get-port vec)) (conc "http://" (http-transport:server-dat-get-iface vec) ":" (http-transport:server-dat-get-port vec)) #f)) (define (http-transport:server-dat-update-last-access vec) (vector-set! vec 5 (current-seconds))) ;; ;; connect ;; (define (http-transport:client-connect iface port) (let* ((api-url (conc "http://" iface ":" port "/api")) (api-uri (uri-reference (conc "http://" iface ":" port "/api"))) (api-req (make-request method: 'POST uri: api-uri)) (server-dat (vector iface port api-uri api-url api-req (current-seconds)))) server-dat)) ;; run http-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; (define (http-transport:keep-running server-id run-id) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (let* ((tdbdat (tasks:open-db)) (server-info (let loop ((start-time (current-seconds)) (changed #t) (last-sdat "not this")) (let ((sdat #f)) (thread-sleep! 0.01) (debug:print-info 0 "Waiting for server alive signature") (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if (and sdat (not changed) (> (- (current-seconds) start-time) 2)) sdat (begin (debug:print-info 0 "Still waiting, last-sdat=" last-sdat) (sleep 4) (if (> (- (current-seconds) start-time) 120) ;; been waiting for two minutes (begin (debug:print 0 "ERROR: transport appears to have died, exiting server " server-id " for run " run-id) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id "failed to start, never received server alive signature") (exit)) (loop start-time (equal? sdat last-sdat) sdat))))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) (server-timeout (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (string->number tmo)) (* 60 60 (string->number tmo)) ;; (* 3 24 60 60) ;; default to three days (* 60 1) ;; default to one minute ;; (* 60 60 25) ;; default to 25 hours )))) (let loop ((count 0) (server-state 'available)) ;; Use this opportunity to sync the inmemdb to db (let ((start-time (current-milliseconds)) (sync-time #f) (rem-time #f)) ;; inmemdb is a dbstruct (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t)) (set! sync-time (- (current-milliseconds) start-time)) (set! rem-time (quotient (- 4000 sync-time) 1000)) (debug:print 2 "SYNC: time= " sync-time ", rem-time=" rem-time) ;; ;; set_running after our first pass through and start the db ;; (if (eq? server-state 'available) (begin (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep") (thread-sleep! 5) ;; give some margin for queries to complete before switching from file based access to server based access (set! *inmemdb* (db:setup run-id)) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running"))) (if (and (<= rem-time 4) (> rem-time 0)) (thread-sleep! rem-time) (thread-sleep! 4))) ;; fallback for if the math is changed ... (if (< count 1) ;; 3x3 = 9 secs aprox (loop (+ count 1) 'running)) ;; Check that iface and port have not changed (can happen if server port collides) (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if (or (not (equal? sdat (list iface port))) (not server-id)) (begin (debug:print-info 0 "interface changed, refreshing iface and port info") (set! iface (car sdat)) (set! port (cadr sdat)))) ;; Transfer *last-db-access* to last-access to use in checking that we are still alive (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) ;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout) ;; ;; no_traffic, no running tests, if server 0, no running servers ;; ;; (let ((wait-on-running (configf:lookup *configdat* "server" "wait-on-running"))) ;; wait on running tasks (if not true then exit on time out) ;; (if (and *server-run* ;; (or (> (+ last-access server-timeout) (current-seconds))) ;; (and (eq? run-id 0) ;; (> (tasks:num-servers-non-zero-running tdb) 0)) ;; (and (not (eq? run-id 0)) ;; only makes sense in non-zero run-id servers ;; (> (db:get-count-tests-actually-running *inmemdb* run-id) 0)) ;; )) (begin (debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) ;; ;; Consider implementing some smarts here to re-insert the record or kill self is ;; the db indicates so ;; ;; (if (tasks:server-am-i-the-server? tdb run-id) ;; (tasks:server-set-state! tdb server-id "running")) ;; (loop 0 server-state)) (http-transport:server-shutdown server-id port))))) (define (http-transport:server-shutdown server-id port) (let ((tdbdat (tasks:open-db))) (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) (if *inmemdb* (db:sync-touched *inmemdb* *run-id* force-sync: #t)) ;; ;; start_shutdown ;; (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "shutting-down") (portlogger:open-run-close portlogger:set-port port "released") (thread-sleep! 5) (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Number of cached writes " *number-of-writes*) (debug:print-info 0 "Average cached write time " (if (eq? *number-of-writes* 0) "n/a (no writes)" (/ *writes-total-delay* *number-of-writes*)) " ms") (debug:print-info 0 "Number non-cached queries " *number-non-write-queries*) (debug:print-info 0 "Average non-cached time " (if (eq? *number-non-write-queries* 0) "n/a (no queries)" (/ *total-non-write-delay* *number-non-write-queries*)) " ms") (debug:print-info 0 "Server shutdown complete. Exiting") (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id " http-transport:keep-running complete") (exit))) ;; all routes though here end in exit ... ;; ;; start_server? ;; (define (http-transport:launch run-id) (let* ((tdbdat (tasks:open-db))) (set! *run-id* run-id) (if (args:get-arg "-daemonize") (begin (daemon:ize) (if *alt-log-file* ;; we should re-connect to this port, I think daemon:ize disrupts it (begin (current-error-port *alt-log-file*) (current-output-port *alt-log-file*))))) (if (server:check-if-running run-id) (begin (debug:print 0 "INFO: Server for run-id " run-id " already running") (exit 0))) (let loop ((server-id (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id)) (remtries 4)) (if (not server-id) (if (> remtries 0) (begin (thread-sleep! 2) (loop (tasks:server-lock-slot (db:delay-if-busy tdbdat) run-id) (- remtries 1))) (begin ;; since we didn't get the server lock we are going to clean up and bail out (debug:print-info 2 "INFO: server pid=" (current-process-id) ", hostname=" (get-host-name) " not starting due to other candidates ahead in start queue") (tasks:server-delete-records-for-this-pid (db:delay-if-busy tdbdat) " http-transport:launch") )) (let* ((th2 (make-thread (lambda () (debug:print-info 0 "Server run thread started") (http-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-") run-id server-id)) "Server run")) (th3 (make-thread (lambda () (debug:print-info 0 "Server monitor thread started") (http-transport:keep-running server-id run-id)) "Keep running"))) (thread-start! th2) (thread-sleep! 0.25) ;; give the server time to settle before starting the keep-running monitor. (thread-start! th3) (set! *didsomething* #t) (thread-join! th2) (exit)))))) (define (http-transport:server-signal-handler signum) (signal-mask! signum) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () (thread-sleep! 1)) "eat response")) (th2 (make-thread (lambda () (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 3) ;; give the flush three seconds to do it's stuff (debug:print 0 " Done.") (exit 4)) "exit on ^C timer"))) |
︙ | ︙ |
Modified launch.scm from [69229ba1dd] to [34882953c1].
︙ | ︙ | |||
9 10 11 12 13 14 15 | ;; PURPOSE. ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== | | > > > | 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 | ;; PURPOSE. ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== (use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3) (import (prefix base64 base64:)) (import (prefix sqlite3 sqlite3:)) (declare (unit launch)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) ;; (declare (uses sdb)) (declare (uses tdb)) ;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") ;;====================================================================== ;; ezsteps |
︙ | ︙ | |||
43 44 45 46 47 48 49 | (or (eq? exitcode 0) (and logpro (eq? exitcode 2)))) ;; if handed a string, process it, else look for MT_CMDINFO (define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f)) (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) (if enccmd | | | | > | > | > > > > > > > > > > > > > > > > > < < < < < | 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 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 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | (or (eq? exitcode 0) (and logpro (eq? exitcode 2)))) ;; if handed a string, process it, else look for MT_CMDINFO (define (launch:get-cmdinfo-assoc-list #!key (encoded-cmd #f)) (let ((enccmd (if encoded-cmd encoded-cmd (getenv "MT_CMDINFO")))) (if enccmd (common:read-encoded-string enccmd) '()))) (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd))) (setenv "MT_CMDINFO" encoded-cmd) (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) (transport (assoc/default 'transport cmdinfo)) ;; (serverinf (assoc/default 'serverinf cmdinfo)) (port (assoc/default 'port cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (target (assoc/default 'target cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (env-ovrd (assoc/default 'env-ovrd cmdinfo)) (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) (runtlim (assoc/default 'runtlim cmdinfo)) (item-path (item-list->path itemdat)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (keys #f) (keyvals #f) (fullrunscript (if (not runscript) #f (if (substring-index "/" runscript) runscript ;; use unadultered if contains slashes (let ((fulln (conc testpath "/" runscript))) (if (and (file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path (rollup-status 0)) (change-directory top-path) ;; (set-signal-handler! signal/int (lambda () ;; Do not run the test if it is REMOVING, RUNNING, KILLREQ or REMOTEHOSTSTART, ;; Mark the test as REMOTEHOSTSTART *IMMEDIATELY* ;; (let ((test-info (rmt:get-testinfo-state-status run-id test-id))) (if (not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") (begin (debug:print 0 "ERROR: test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys)) ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... (if (not (launch:setup-for-run force: #t)) (begin (debug:print 0 "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) (change-directory *toppath*) ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This ;; seems non-ideal but could well break stuff ;; BUG? BUG? BUG? (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target) ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; Now have runconfigs data loaded, set environment vars (for-each (lambda (section) (for-each (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if (and (string? var)(string? val)) (begin (setenv var (config:eval-string-in-environment val))) ;; val) (debug:print 0 "ERROR: bad variable spec, " var "=" val)))) (configf:get-section rconfig section))) (list "default" target))) (change-directory work-area) (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) (debug:print 4 "varpairs: " varpairs) (map (lambda (varpair) |
︙ | ︙ | |||
142 143 144 145 146 147 148 149 150 151 | (begin (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting") (exit))))) (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) | > | > > > > < < | 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 193 194 195 | (begin (debug:print 0 "ERROR: required variable " var " does not have a valid value. Exiting") (exit))))) (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) (list "MT_LINKTREE" (configf:lookup *configdat* "setup" "linktree")) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) (runs: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 #f test-id run-id 0 work-area) ;; (tests:set-full-meta-info test-id run-id 0 work-area) (tests:set-full-meta-info #f test-id run-id 0 work-area 10) (thread-sleep! 0.3) ;; NFS slowness has caused grief here (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) ;; We are about to actually kick off the test |
︙ | ︙ | |||
189 190 191 192 193 194 195 | ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) ;; Since we should have a clean slate at this time there is no need to do ;; any of the other stuff that tests:test-set-status! does. Let's just ;; force RUNNING/n/a (thread-sleep! 0.3) | | > > | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 | ;; (tests:test-set-status! test-id "RUNNING" "n/a" #f #f) ;; Since we should have a clean slate at this time there is no need to do ;; any of the other stuff that tests:test-set-status! does. Let's just ;; force RUNNING/n/a (thread-sleep! 0.3) (tests:test-force-state-status! run-id test-id "RUNNING" "n/a") (rmt:roll-up-pass-fail-counts run-id test-name item-path "RUNNING") (thread-sleep! 0.3) ;; NFS slowness has caused grief here ;; if there is a runscript do it first (if fullrunscript (let ((pid (process-run fullrunscript))) (rmt:test-set-top-process-pid run-id test-id pid) (let loop ((i 0)) (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) (mutex-lock! m) (vector-set! exit-info 0 pid) (vector-set! exit-info 1 exit-status) (vector-set! exit-info 2 exit-code) |
︙ | ︙ | |||
247 248 249 250 251 252 253 | ;; (if (and prevstep (file-exists? prev-env)) ;; (set! script (conc script "source " prev-env)))) ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) | < | > < | | | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 | ;; (if (and prevstep (file-exists? prev-env)) ;; (set! script (conc script "source " prev-env)))) ;; call the command using mt_ezstep (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd)) (debug:print 4 "script: " script) (rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f) ;; now launch (let ((pid (process-run script))) (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) (vector-set! exit-info 0 pid) (vector-set! exit-info 1 exit-status) (vector-set! exit-info 2 exit-code) (mutex-unlock! m) (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1)))) )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) (if logpro-used (rmt:test-set-log! run-id 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) |
︙ | ︙ | |||
296 297 298 299 300 301 302 | (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood | | | | > > | < | | > > | > > > | | < < | > > | < < < < < < < | | < | < > | > | | | | < < < | > | | > < < < | | > < < < < | | 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 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 | (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood (tests:test-set-status! run-id test-id next-state "WARN" (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) (monitorjob (lambda () (let* ((start-seconds (current-seconds)) (calc-minutes (lambda () (inexact->exact (round (- (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))) (begin (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) (time-exceeded (> run-seconds runtlim))) (if time-exceeded (begin (debug:print-info 0 "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) #t) #f))))) (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f) (if kill-job? (begin (mutex-lock! m) ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this ;; section and the runit section? Or add a loop that tries three times with a 1/4 second ;; between tries? (let* ((pid1 (vector-ref exit-info 0)) (pid2 (rmt:test-get-top-process-pid run-id test-id)) (pids (delete-duplicates (filter number? (list pid1 pid2))))) (if (not (null? pids)) (begin (for-each (lambda (pid) (handle-exceptions exn (begin (debug:print-info 0 "Unable to kill process with pid " pid ", possibly already killed.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) (debug:print 0 "WARNING: Request received to kill job " pid) ;; " (attempt # " kill-tries ")") (if (process:alive? pid) (begin (process-signal pid signal/int) (thread-sleep! 5) (if (process:process-alive? pid) (process-signal pid signal/kill)))))) pids) (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) (begin (debug:print 0 "ERROR: Nothing to kill, pid1=" pid1 ", pid2=" pid2) (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) ))) (mutex-unlock! m) ;; no point in sticking around. Exit now. (exit))) (if keep-going (begin (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses (if keep-going (loop (calc-minutes))))))) (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f)))) ;; NOTE: Checking twice for keep-going is intentional (th1 (make-thread monitorjob "monitor job")) (th2 (make-thread runit "run job"))) (set! job-thread th2) (thread-start! th1) (thread-start! th2) (thread-join! th2) (debug:print-info 0 "Megatest exectute of test " test-name ", item path " item-path " complete. Notifying the db ...") (set! keep-going #f) (thread-join! th1) (thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test ) (new-status (cond ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run ((eq? rollup-status 0) ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) ((eq? rollup-status 1) "FAIL") ((eq? rollup-status 2) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) (else "FAIL")))) ;; (db:test-get-status testinfo))) (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status) (tests:test-set-status! run-id test-id new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest ;; NO NEED TO CALL roll-up-pass-fail-counts HERE, THIS IS DONE IN roll-up-pass-fail-counts called by tests:test-set-status! )) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items run-id test-id test-name #f))) ;; don't force - just update if no (mutex-unlock! m) (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") (if (not (vector-ref exit-info 1)) (exit 4))))))) ;; set up the very basics needed for doing anything here. |
︙ | ︙ | |||
443 444 445 446 447 448 449 | (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") environ-patt: "env-override" given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") pathenvvar: "MT_RUN_AREA_HOME")) (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) | > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > | > | > > > > | > > > | < > | > > | | > | | | | | | > | > | < < < < < < < < < < < < < < < | 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 | (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") environ-patt: "env-override" given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") pathenvvar: "MT_RUN_AREA_HOME")) (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) (let ((linktree (configf:lookup *configdat* "setup" "linktree"))) ;; link tree is critical (if linktree (if (not (file-exists? linktree)) (begin (handle-exceptions exn (begin (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1)) (create-directory linktree #t)))) (begin (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config") (exit 1))) (if linktree (let ((dbdir (conc linktree "/.db"))) (handle-exceptions exn (begin (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))) (if (not (directory-exists? dbdir))(create-directory dbdir))) (setenv "MT_LINKTREE" linktree)) (begin (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section") (exit 1))) (if (and *toppath* (directory-exists? *toppath*)) (setenv "MT_RUN_AREA_HOME" *toppath*) (begin (debug:print 0 "ERROR: failed to find the top path to your Megatest area.") (exit 1)))))) *toppath*) (define (get-best-disk confdat) (let* ((disks (hash-table-ref/default confdat "disks" #f)) (best #f) (bestsize 0)) (if disks (for-each (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (freespc (cond ((not (directory? dirpath)) (if (common:low-noise-print 50 "disks not a dir " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a directory - ignoring it.")) -1) ((not (file-write-access? dirpath)) (if (common:low-noise-print 50 "disks not writeable " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not writeable - ignoring it.")) -1) ((not (eq? (string-ref dirpath 0) #\/)) (if (common:low-noise-print 50 "disks not a proper path " disk-num) (debug:print 0 "WARNING: disk " disk-num " at path " dirpath " is not a fully qualified path - ignoring it.")) -1) (else (get-df dirpath))))) (if (> freespc bestsize) (begin (set! best dirpath) (set! bestsize freespc))))) (map car disks))) (if (and best (> bestsize 0)) best (begin (if (common:low-noise-print 20 "no valid disks") (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section and ensure the directory exists!")) (exit 1))))) ;; Desired directory structure: ;; ;; <linkdir> - <target> - <testname> -. ;; | ;; v ;; <rundir> - <target> - <testname> -|- <itempath(s)> ;; ;; dir stored in test is: ;; ;; <linkdir> - <target> - <testname> [ - <itempath> ] ;; ;; All log file links should be stored relative to the top of link path ;; ;; <target> - <testname> [ - <itempath> ] ;; (define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat #!key (remtries 2)) (let* ((item-path (item-list->path itemdat)) (runname (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname")) ;; convert back to db: from rdb: - this is always run at server end (target (string-intersperse (map cadr keyvals) "/")) (not-iterated (equal? "" item-path)) ;; all tests are found at <rundir>/test-base or <linkdir>/test-base (testtop-base (conc target "/" runname "/" testname)) (test-base (conc testtop-base (if not-iterated "" "/") item-path)) ;; nb// if itempath is not "" then it is prefixed with "/" (toptest-path (conc disk-path "/" testtop-base)) (test-path (conc disk-path "/" test-base)) ;; ensure this exists first as links to subtests must be created there (linktree (let ((rd (config-lookup *configdat* "setup" "linktree"))) (if rd rd (conc *toppath* "/runs")))) (lnkbase (conc linktree "/" target "/" runname)) (lnkpath (conc lnkbase "/" testname)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)) (lnktarget (conc lnkpath "/" item-path))) ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical ;; rundir shortdir (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path) (debug:print 2 "INFO:\n lnkbase=" lnkbase "\n lnkpath=" lnkpath "\n toptest-path=" toptest-path "\n test-path=" test-path) (if (not (file-exists? linktree)) (begin (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree) (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree)))) ;; create the directory for the tests dir links, this is needed no matter what... (if (and (not (directory-exists? lnkbase)) (not (file-exists? lnkbase))) (create-directory lnkbase #t)) ;; update the toptest record with its location rundir, cache the path ;; This wass highly inefficient, one db write for every subtest, potentially ;; thousands of unnecessary updates, cache the fact it was set and don't set it ;; again. ;; Now create the link from the test path to the link tree, however ;; if the test is iterated it is necessary to create the parent path ;; to the iteration. use pathname-directory to trim the path by one ;; level (if (not not-iterated) ;; i.e. iterated (let ((iterated-parent (pathname-directory (conc lnkpath "/" item-path)))) (debug:print-info 2 "Creating iterated parent " iterated-parent) |
︙ | ︙ | |||
578 579 580 581 582 583 584 585 586 587 | (handle-exceptions exn (begin (debug:print 0 "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-symbolic-link toptest-path lnkpath))) ;; The toptest path has been created, the link to the test in the linktree has ;; been created. Now, if this is an iterated test the real test dir must be created (if (not not-iterated) ;; this is an iterated test | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 | (handle-exceptions exn (begin (debug:print 0 "ERROR: Failed to create symlink " lnkpath ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) (create-symbolic-link toptest-path lnkpath))) ;; NB - This was not working right - some top tests are not getting the path set!!! ;; ;; Do the setting of this record after the paths are created so that the shortdir can ;; be set to the real directory location. This is safer for future clean up if the link ;; tree is damaged or lost. ;; (if (not (hash-table-ref/default *toptest-paths* testname #f)) (let* ((testinfo (rmt:get-test-info-by-id run-id test-id)) ;; run-id testname item-path)) (curr-test-path (if testinfo ;; (filedb:get-path *fdb* ;; (db:get-path dbstruct ;; (rmt:sdb-qry 'getstr (db:test-get-rundir testinfo) ;; ) ;; ) #f))) (hash-table-set! *toptest-paths* testname curr-test-path) ;; NB// Was this for the test or for the parent in an iterated test? (rmt:general-call 'test-set-rundir-shortdir run-id lnkpath (if (file-exists? lnkpath) (resolve-pathname lnkpath) lnkpath) testname "") ;; (rmt:general-call 'test-set-rundir run-id lnkpath testname "") ;; toptest-path) (if (or (not curr-test-path) (not (directory-exists? toptest-path))) (begin (debug:print-info 2 "Creating " toptest-path " and link " lnkpath) (create-directory toptest-path #t) (hash-table-set! *toptest-paths* testname toptest-path))))) ;; The toptest path has been created, the link to the test in the linktree has ;; been created. Now, if this is an iterated test the real test dir must be created (if (not not-iterated) ;; this is an iterated test (begin ;; (let ((lnktarget (conc lnkpath "/" item-path))) (debug:print 2 "Setting up sub test run area") (debug:print 2 " - creating run area in " test-path) (handle-exceptions exn (begin (debug:print 0 "ERROR: Failed to create directory " test-path ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit 1)) |
︙ | ︙ | |||
603 604 605 606 607 608 609 | exn (begin (debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit)) (if (symbolic-link? lnktarget) (delete-file lnktarget)) (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) | | | | < < < < < < > > > > > | | 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 | exn (begin (debug:print 0 "ERROR: Failed to re-create link " lnktarget ((condition-property-accessor 'exn 'message) exn) ", exiting") (exit)) (if (symbolic-link? lnktarget) (delete-file lnktarget)) (if (not (file-exists? lnktarget)) (create-symbolic-link test-path lnktarget))))) (if (not (directory? test-path)) (create-directory test-path #t)) ;; this is a hack, I don't know why out of the blue this path does not exist sometimes (if (directory? test-path) (begin (let* ((ovrcmd (let ((cmd (config-lookup *configdat* "setup" "testcopycmd"))) (if cmd ;; substitute the TEST_SRC_PATH and TEST_TARG_PATH (string-substitute "TEST_TARG_PATH" test-path (string-substitute "TEST_SRC_PATH" test-src-path cmd #t) #t) #f))) (cmd (if ovrcmd ovrcmd (conc "rsync -av" (if (debug:debug-mode 1) "" "q") " " test-src-path "/ " test-path "/" " >> " test-path "/mt_launch.log 2>> " test-path "/mt_launch.log"))) (status (system cmd))) (if (not (eq? status 0)) (debug:print 2 "ERROR: problem with running \"" cmd "\""))) (list lnkpathf lnkpath )) (if (> remtries 0) (begin (debug:print 0 "ERROR: Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) ;; (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1))) (list #f #f))))) ;; 1. look though disks list for disk with most space ;; 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 |
︙ | ︙ | |||
684 685 686 687 688 689 690 | (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) ;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) | | | | > > > > > > | | | < | | | | | | | | > | | | | | | | | | > < | < | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 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 | (work-area #f) (toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all (diskpath #f) (cmdparms #f) (fullcmd #f) ;; (define a (with-output-to-string (lambda ()(write x)))) (mt-bindir-path #f) ;; (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) (testinfo (rmt:get-test-info-by-id run-id test-id)) (mt_target (string-intersperse (map cadr keyvals) "/")) (debug-param (append (if (args:get-arg "-debug") (list "-debug" (args:get-arg "-debug")) '()) (if (args:get-arg "-logging")(list "-logging") '())))) (setenv "MT_ITEMPATH" item-path) (if hosts (set! hosts (string-split hosts))) ;; set the megatest to be called on the remote host (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest")) (set! mt-bindir-path (pathname-directory remote-megatest)) (if launcher (set! launcher (string-split launcher))) ;; set up the run work area for this test (if (and (args:get-arg "-preclean") ;; user has requested to preclean for this run (not (member (db:test-get-rundir testinfo)(list "n/a" "/tmp/badname")))) ;; n/a is a placeholder and thus not a read dir (begin (debug:print-info 0 "attempting to preclean directory " (db:test-get-rundir testinfo) " for test " test-name "/" item-path) (runs:remove-test-directory #f testinfo #t))) ;; remove data only, do not perturb the record ;; prevent overlapping actions - set to LAUNCHED as early as possible ;; (tests:test-set-status! run-id test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED")) (rmt:roll-up-pass-fail-counts run-id test-name item-path "LAUNCHED") (set! diskpath (get-best-disk *configdat*)) (if diskpath (let ((dat (create-work-area run-id run-info keyvals test-id test-path diskpath test-name itemdat))) (set! work-area (car dat)) (set! toptest-work-area (cadr dat)) (debug:print-info 2 "Using work area " work-area)) (begin (set! work-area (conc test-path "/tmp_run")) (create-directory work-area #t) (debug:print 0 "WARNING: No disk work area specified - running in the test directory under tmp_run"))) (set! cmdparms (base64:base64-encode (z3:encode-buffer (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) (list 'transport (conc *transport-type*)) ;; (list 'serverinf *server-info*) (list 'toppath *toppath*) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) (list 'test-id test-id ) ;; (list 'item-path item-path ) (list 'itemdat itemdat ) (list 'megatest remote-megatest) (list 'ezsteps ezsteps) (list 'target mt_target) (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path)))))))) ;; clean out step records from previous run if they exist ;; (rmt:delete-test-step-records run-id test-id) (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir (cond ((and launcher hosts) ;; must be using ssh hostname (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms)))) (launcher (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms) debug-param))) ;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms)))) |
︙ | ︙ |
Modified lock-queue.scm from [0b444a0bb7] to [fb7e24faf1].
1 2 3 4 5 6 7 8 9 | ;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. | < < < < < > > > > > > > > > > > | > > | > | | | | | | | | | | | | | | | | | > > | > > | < | > > | | | | | > | > > | < | > > | > | | > | > | | > > | | > > | > > | > > > > > > > > | | | | > > > > | | | | | | > > > > > > | > > > | > | | | | | | 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 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 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 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 224 225 226 227 228 229 | ;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (use sqlite3 srfi-18) (import (prefix sqlite3 sqlite3:)) (declare (unit lock-queue)) (declare (uses common)) (declare (uses tasks)) ;;====================================================================== ;; attempt to prevent overlapping updates of rollup files by queueing ;; update requests in an sqlite db ;;====================================================================== ;;====================================================================== ;; db record, <vector db path-to-db> ;;====================================================================== (define (make-lock-queue:db-dat)(make-vector 3)) (define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0)) (define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1)) (define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val)) (define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val)) (define (lock-queue:open-db fname #!key (count 10)) (let* ((actualfname (conc fname ".lockdb")) (dbexists (file-exists? actualfname)) (db (sqlite3:open-database actualfname)) (handler (make-busy-timeout 136000))) (if dbexists (vector db actualfname) (begin (handle-exceptions exn (begin (thread-sleep! 10) (if (> count 0) (lock-queue:open-db fname count: (- count 1)) (vector db actualfname))) (sqlite3:with-transaction db (lambda () (sqlite3:execute db "CREATE TABLE IF NOT EXISTS queue ( id INTEGER PRIMARY KEY, test_id INTEGER, start_time INTEGER, state TEXT, CONSTRAINT queue_constraint UNIQUE (test_id));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS runlocks ( id INTEGER PRIMARY KEY, test_id INTEGER, run_lock TEXT, CONSTRAINT runlock_constraint UNIQUE (run_lock));")))))) (sqlite3:set-busy-handler! db handler) (vector db actualfname))) (define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10)) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) (handle-exceptions exn (if (> remtries 0) (begin (debug:print 0 "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 30) (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1))) (begin (debug:print 0 "ERROR: Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") #f)) (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;" newstate test-id))) (define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10)) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) (handle-exceptions exn (if (> remtries 0) (begin (debug:print 0 "WARNING: exception on lock-queue:any-younger. Trying again in 30 seconds.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 30) (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1))) (begin (debug:print 0 "ERROR: Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") #f)) (let ((res #f)) (sqlite3:for-each-row (lambda (tid) ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as (if (not (equal? tid test-id)) (set! res tid))) (lock-queue:db-dat-get-db dbdat) "SELECT test_id FROM queue WHERE start_time > ?;" mystart) res))) (define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f)) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal") (let* ((res #f) (db (lock-queue:db-dat-get-db dbdat)) (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';")) (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) (let ((result (handle-exceptions exn (begin (debug:print 0 "WARNING: failed to get queue lock. Will try again in a few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 10) (if (> count 0) (lock-queue:get-lock dbdat test-id count: (- count 1))) #f) (sqlite3:with-transaction db (lambda () (sqlite3:for-each-row (lambda (tid lockstate) (set! res (list tid lockstate))) lckqry) (if res (if (equal? (car res) test-id) #t ;; already have the lock #f) (begin (sqlite3:execute mklckqry test-id) ;; if no error handled then return #t for got the lock #t))))))) (sqlite3:finalize! lckqry) (sqlite3:finalize! mklckqry) result))) (define (lock-queue:release-lock fname test-id #!key (count 10)) (let* ((dbdat (lock-queue:open-db fname))) (handle-exceptions exn (begin (debug:print 0 "WARNING: Failed to release queue lock. Will try again in few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! (/ count 10)) (if (> count 0) (begin (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)) (lock-queue:release-lock fname test-id count: (- count 1))) (let ((journal (conc fname "-journal"))) ;; If we've tried ten times and failed there is a serious problem ;; try to remove the lock db and allow it to be recreated (handle-exceptions exn #f (if (file-exists? journal)(delete-file journal)) (if (file-exists? fname) (delete-file fname)) #f)))) (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id) (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))))) (define (lock-queue:steal-lock dbdat test-id #!key (count 10)) (debug:print-info 0 "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal") (handle-exceptions exn (begin (debug:print 0 "WARNING: Failed to steal queue lock. Will try again in few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! 10) (if (> count 0) (lock-queue:steal-lock dbdat test-id count: (- count 1)) #f)) (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';")) (lock-queue:get-lock dbdat test-it)) ;; returns #f if ok to skip the task ;; returns #t if ok to proceed with task ;; otherwise waits ;; (define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f)) (let* ((dbdat (lock-queue:open-db fname)) (mystart (current-seconds)) (db (lock-queue:db-dat-get-db dbdat))) (handle-exceptions exn (begin (debug:print 0 "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) (thread-sleep! 10) (if (> count 0) (begin (sqlite3:finalize! db) (lock-queue:wait-turn fname test-id count: (- count 1))) (begin (debug:print 0 "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") (print-call-chain (current-error-port)) #f))) (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") (sqlite3:execute db "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" test-id mystart) (thread-sleep! 1) ;; give other tests a chance to register (let ((result (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id))) (if younger-waiting (begin ;; no need for us to wait. mark in the lock queue db as skipping (lock-queue:set-state dbdat test-id "skipping") #f) ;; let the calling process know that nothing needs to be done (if (lock-queue:get-lock dbdat test-id) #t (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock (lock-queue:steal-lock dbdat test-id) (begin (thread-sleep! 1) (loop (lock-queue:any-younger? dbdat mystart test-id))))))))) (sqlite3:finalize! db) result)))) ;; (use trace) ;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state) |
Modified megatest-version.scm from [724ccf372e] to [9b8927108a].
|
| | | | | 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)) (define megatest-version 1.6006) |
Modified megatest.scm from [54431b021e] to [16af3583d8].
1 2 3 4 5 6 7 8 9 10 11 12 | ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") | | > > > > > > > > | 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 | ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; (include "common.scm") ;; (include "megatest-version.scm") (use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client directory-utils z3 srfi-18) ;; extras) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) ;; (use zmq) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses runs)) (declare (uses launch)) (declare (uses server)) (declare (uses client)) (declare (uses tests)) (declare (uses genexample)) (declare (uses daemon)) (declare (uses db)) ;; (declare (uses sdb)) ;; (declare (uses filedb)) (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses tasks)) ;; only used for debugging. (define *db* #f) ;; this is only for the repl, do not use in general!!!! (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") |
︙ | ︙ | |||
114 115 116 117 118 119 120 121 122 123 124 125 | -section sectionName -var varName : for config and runconfig lookup value for sectionName varName Misc -start-dir path : switch to this directory before running megatest -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db -update-meta : update the tests metadata for all tests -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname | > > < > > | 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 | -section sectionName -var varName : for config and runconfig lookup value for sectionName varName Misc -start-dir path : switch to this directory before running megatest -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db -import-megatest.db : migrate a database from v1.55 series to v1.60 series -sync-to-megatest.db : migrate data back to megatest.db -update-meta : update the tests metadata for all tests -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are overwritten by values set in config files. -server -|hostname : start the server (reduces contention on megatest.db), use - to automatically figure out hostname -daemonize : fork into background and disconnect from stdin/out -log logfile : send stdout and stderr to logfile -list-servers : list the servers -stop-server id : stop server specified by id (see output of -list-servers), use 0 to kill all -repl : start a repl (useful for extending megatest) -load file.scm : load and run file.scm -mark-incompletes : find and mark incomplete tests -ping run-id|host:port : ping server, exit with 0 if found Utilities -env2file fname : write the environment to fname.csh and fname.sh -refdb2dat refdb : convert refdb to sexp or to format specified by -dumpmode formats: perl, ruby, sqlite3 -o : output file for refdb2dat (defaults to stdout) |
︙ | ︙ | |||
192 193 194 195 196 197 198 | ":value" ":expected" ":tol" ":units" ;; misc "-start-dir" "-server" | < > > > | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | ":value" ":expected" ":tol" ":units" ;; misc "-start-dir" "-server" "-stop-server" "-port" "-extract-ods" "-pathmod" "-env2file" "-setvars" "-set-state-status" "-set-run-status" "-debug" ;; for *verbosity* > 2 "-gen-megatest-test" "-override-timeout" "-test-files" ;; -test-paths is for listing all "-load" ;; load and exectute a scheme file "-section" "-var" "-dumpmode" "-run-id" "-ping" "-refdb2dat" "-o" "-log" ) (list "-h" "-help" "--help" "-version" "-force" "-xterm" "-showkeys" "-show-keys" |
︙ | ︙ | |||
254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 | "-rebuild-db" "-cleanup-db" "-rollup" "-update-meta" "-gen-megatest-area" "-mark-incompletes" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) args:arg-hash 0)) (if (or (args:get-arg "-h") (args:get-arg "-help") (args:get-arg "--help")) (begin (print help) (exit))) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 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 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 | "-rebuild-db" "-cleanup-db" "-rollup" "-update-meta" "-gen-megatest-area" "-mark-incompletes" "-convert-to-norm" "-convert-to-old" "-import-megatest.db" "-sync-to-megatest.db" "-logging" "-v" ;; verbose 2, more than normal (normal is 1) "-q" ;; quiet 0, errors/warnings only ) args:arg-hash 0)) ;; The watchdog is to keep an eye on things like db sync etc. ;; (define *watchdog* (make-thread (lambda () (thread-sleep! 0.05) ;; delay for startup (let ((legacy-sync (configf:lookup *configdat* "setup" "megatest-db"))) (let loop () ;; sync for filesystem local db writes ;; (let ((start-time (current-seconds)) (servers-started (make-hash-table))) (for-each (lambda (run-id) (mutex-lock! *db-multi-sync-mutex*) (if (and legacy-sync (hash-table-ref/default *db-local-sync* run-id #f)) ;; (if (> (- start-time last-write) 5) ;; every five seconds (begin ;; let ((sync-time (- (current-seconds) start-time))) (db:multi-db-sync (list run-id) 'new2old) (if (common:low-noise-print 30 "sync new to old") (let ((sync-time (- (current-seconds) start-time))) (debug:print-info 0 "Sync of newdb to olddb for run-id " run-id " completed in " sync-time " seconds"))) ;; (if (> sync-time 10) ;; took more than ten seconds, start a server for this run ;; (begin ;; (debug:print-info 0 "Sync is taking a long time, start up a server to assist for run " run-id) ;; (server:kind-run run-id))))) (hash-table-delete! *db-local-sync* run-id))) (mutex-unlock! *db-multi-sync-mutex*)) (hash-table-keys *db-local-sync*))) ;; keep going unless time to exit ;; (if (not *time-to-exit*) (begin (thread-sleep! 1) ;; wait one second before syncing again (loop))))) "Watchdog thread"))) (thread-start! *watchdog*) (if (args:get-arg "-log") (let ((oup (open-output-file (args:get-arg "-log")))) (debug:print-info 0 "Sending log output to " (args:get-arg "-log")) (current-error-port oup) (current-output-port oup))) (if (or (args:get-arg "-h") (args:get-arg "-help") (args:get-arg "--help")) (begin (print help) (exit))) |
︙ | ︙ | |||
306 307 308 309 310 311 312 | (eq? pid-val 0)) (begin (printf "Sending signal/term to ~A\n" pid) (process-signal pid signal/term)))))) (process:children #f)) (original-exit exit-code))))) | < < < < < < > > | | | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 | (eq? pid-val 0)) (begin (printf "Sending signal/term to ~A\n" pid) (process-signal pid signal/term)))))) (process:children #f)) (original-exit exit-code))))) ;;====================================================================== ;; Misc setup stuff ;;====================================================================== (debug:setup) (if (args:get-arg "-logging")(set! *logging* #t)) (if (debug:debug-mode 3) ;; we are obviously debugging (set! open-run-close open-run-close-no-exception-handling)) (if (args:get-arg "-itempatt") (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) (hash-table-set! args:arg-hash "-testpatt" newval) (hash-table-delete! args:arg-hash "-itempatt"))) (on-exit std-exit-procedure) ;;====================================================================== ;; Misc general calls ;;====================================================================== (if (args:get-arg "-env2file") (begin (save-environment-as-files (args:get-arg "-env2file")) (set! *didsomething* #t))) (if (args:get-arg "-list-disks") (let ((toppath (launch:setup-for-run))) (print (string-intersperse (map (lambda (x) (string-intersperse x " => ")) (common:get-disks *configdat*)) "\n")) (set! *didsomething* #t))) (if (args:get-arg "-refdb2dat") (let* ((input-db (args:get-arg "-refdb2dat")) (out-file (args:get-arg "-o")) (out-fmt (or (args:get-arg "-dumpmode") "scheme")) |
︙ | ︙ | |||
407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 | (sqlite3:finalize! db))) (else (pp data)))))) (if out-file (close-output-port out-port)) (exit) ;; yes, bending the rules here - need to exit since this is a utility )) ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== (if (args:get-arg "-server") ;; Server? Start up here. ;; (let ((tl (launch:setup-for-run)) | > > > > > | | | > | > > | > < | > > < < < < < | < < < | > > | < < < | | < < < < < | < | > | | | | | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 | (sqlite3:finalize! db))) (else (pp data)))))) (if out-file (close-output-port out-port)) (exit) ;; yes, bending the rules here - need to exit since this is a utility )) (if (args:get-arg "-ping") (let* ((run-id (string->number (args:get-arg "-run-id"))) (host:port (args:get-arg "-ping"))) (server:ping run-id host:port))) ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== (if (args:get-arg "-server") ;; Server? Start up here. ;; (let ((tl (launch:setup-for-run)) (run-id (and (args:get-arg "-run-id") (string->number (args:get-arg "-run-id"))))) (if run-id (begin (server:launch run-id) (set! *didsomething* #t)) (debug:print 0 "ERROR: server requires run-id be specified with -run-id"))) ;; Not a server? This section will decide how to communicate ;; ;; Setup client for all expect listed here (if (null? (lset-intersection equal? (hash-table-keys args:arg-hash) '("-list-servers" "-stop-server" "-show-cmdinfo" "-list-runs"))) (if (launch:setup-for-run) (let ((run-id (and (args:get-arg "-run-id") (string->number (args:get-arg "-run-id"))))) ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) ;; if not list or kill then start a client (if appropriate) (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") (eq? (length (hash-table-keys args:arg-hash)) 0)) (debug:print-info 1 "Server connection not needed") (begin ;; (if run-id ;; (client:launch run-id) ;; (client:launch 0) ;; without run-id we'll start a server for "0" #t )))))) ;; MAY STILL NEED THIS ;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) (let ((tl (launch:setup-for-run))) (if tl (let* ((tdbdat (tasks:open-db)) (servers (tasks:get-all-servers (db:delay-if-busy tdbdat))) (fmtstr "~5a~12a~8a~20a~24a~10a~10a~10a~10a\n") (servers-to-kill '()) (killinfo (args:get-arg "-stop-server")) (khost-port (if killinfo (if (substring-index ":" killinfo)(string-split ":") #f) #f)) (sid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f))) (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "LastBeat" "State" "Transport") (format #t fmtstr "==" "=====" "===" "====" "=================" "======" "========" "=====" "=========") (for-each (lambda (server) (let* ((id (vector-ref server 0)) (pid (vector-ref server 1)) (hostname (vector-ref server 2)) (interface (vector-ref server 3)) (pullport (vector-ref server 4)) (pubport (vector-ref server 5)) (start-time (vector-ref server 6)) (priority (vector-ref server 7)) (state (vector-ref server 8)) (mt-ver (vector-ref server 9)) (last-update (vector-ref server 10)) (transport (vector-ref server 11)) (killed #f) (status (< last-update 20))) ;; (zmq-sockets (if status (server:client-connect hostname port) #f))) ;; no need to login as status of #t indicates we are connecting to correct ;; server (if (equal? state "dead") (if (> last-update (* 25 60 60)) ;; keep records around for slighly over a day. (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid action: 'delete)) (if (> last-update 20) ;; Mark as dead if not updated in last 20 seconds (tasks:server-deregister (db:delay-if-busy tdbdat) hostname pullport: pullport pid: pid))) (format #t fmtstr id mt-ver pid hostname (conc interface ":" pullport) pubport last-update (if status "alive" "dead") transport) (if (or (equal? id sid) (equal? sid 0)) ;; kill all/any (begin (debug:print-info 0 "Attempting to stop server with pid " pid) (tasks:kill-server status hostname pullport pid transport))))) |
︙ | ︙ | |||
526 527 528 529 530 531 532 | (for-each (lambda (x) ;; (print "[" x "]")) (print x)) targets) (set! *didsomething* #t))) (define (full-runconfigs-read) | | | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 | (for-each (lambda (x) ;; (print "[" x "]")) (print x)) targets) (set! *didsomething* #t))) (define (full-runconfigs-read) (let* ((keys (rmt:get-keys)) (target (common:args-get-target)) (key-vals (if target (keys:target->keyval keys target) #f)) (sections (if target (list "default" target) #f)) (data (begin (setenv "MT_RUN_AREA_HOME" *toppath*) (if key-vals (for-each (lambda (kt) |
︙ | ︙ | |||
580 581 582 583 584 585 586 | (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t) (pop-directory))) (if (args:get-arg "-show-cmdinfo") (if (getenv "MT_CMDINFO") | | | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 | (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t) (pop-directory))) (if (args:get-arg "-show-cmdinfo") (if (getenv "MT_CMDINFO") (let ((data (common:read-encoded-string (getenv "MT_CMDINFO")))) (if (equal? (args:get-arg "-dumpmode") "json") (json-write data) (pp data)) (set! *didsomething* #t)) (debug:print-info 0 "environment variable MT_CMDINFO is not set"))) ;;====================================================================== |
︙ | ︙ | |||
642 643 644 645 646 647 648 | (if (or (args:get-arg "-set-run-status") (args:get-arg "-get-run-status")) (general-run-call "-set-run-status" "set run status" (lambda (target runname keys keyvals) | | | | > > | | | | | | | | > > | | | | | | > | | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 | (if (or (args:get-arg "-set-run-status") (args:get-arg "-get-run-status")) (general-run-call "-set-run-status" "set run status" (lambda (target runname keys keyvals) (let* ((runsdat (rmt:get-runs-by-patt keys runname (common:args-get-target) #f #f)) (header (vector-ref runsdat 0)) (rows (vector-ref runsdat 1))) (if (null? rows) (begin (debug:print-info 0 "No matching run found.") (exit 1)) (let* ((row (car (vector-ref runsdat 1))) (run-id (db:get-value-by-header row header "id"))) (if (args:get-arg "-set-run-status") (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m")) (print (rmt:get-run-status run-id)) ))))))) ;;====================================================================== ;; Query runs ;;====================================================================== ;; NOTE: list-runs and list-db-targets operate on local db!!! ;; (if (or (args:get-arg "-list-runs") (args:get-arg "-list-db-targets")) (if (launch:setup-for-run) (let* ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (runpatt (args:get-arg "-list-runs")) (testpatt (if (args:get-arg "-testpatt") (args:get-arg "-testpatt") "%")) (keys (db:get-keys dbstruct)) ;; (runsdat (db:get-runs dbstruct runpatt #f #f '())) (runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target) #f #f)) ;; (cdb:remote-run db:get-runs #f runpatt #f #f '())) (runs (db:get-rows runsdat)) (header (db:get-header runsdat)) (db-targets (args:get-arg "-list-db-targets")) (seen (make-hash-table))) ;; Each run (for-each (lambda (run) (let ((targetstr (string-intersperse (map (lambda (x) (db:get-value-by-header run header x)) keys) "/"))) (if db-targets (if (not (hash-table-ref/default seen targetstr #f)) (begin (hash-table-set! seen targetstr #t) ;; (print "[" targetstr "]")))) (print targetstr)))) (if (not db-targets) (let* ((run-id (db:get-value-by-header run header "id")) (tests (db:get-tests-for-run dbstruct run-id testpatt '() '() #f #f #f 'testname 'asc #f))) (print "Run: " targetstr "/" (db:get-value-by-header run header "runname") " status: " (db:get-value-by-header run header "state") " run-id: " run-id ", number tests: " (length tests)) (for-each (lambda (test) (format #t " Test: ~25a State: ~15a Status: ~15a Runtime: ~5@as Time: ~22a Host: ~10a\n" (conc (db:test-get-testname test) (if (equal? (db:test-get-item-path test) "") "" (conc "(" (db:test-get-item-path test) ")"))) (db:test-get-state test) (db:test-get-status test) (db:test-get-run_duration test) (db:test-get-event_time test) (db:test-get-host test)) (if (not (or (equal? (db:test-get-status test) "PASS") (equal? (db:test-get-status test) "WARN") (equal? (db:test-get-state test) "NOT_STARTED"))) (begin (print " cpuload: " (db:test-get-cpuload test) "\n diskfree: " (db:test-get-diskfree test) "\n uname: " ;; (sdb:qry 'getstr (db:test-get-uname test) ;; ) "\n rundir: " ;; (sdb:qry 'getstr ;; (filedb:get-path *fdb* (db:test-get-rundir test) ;; ) ) ;; Each test ;; DO NOT remote run (let ((steps (db:get-steps-for-test dbstruct run-id (db:test-get-id test)))) (for-each (lambda (step) (format #t " Step: ~20a State: ~10a Status: ~10a Time ~22a\n" (tdb:step-get-stepname step) (tdb:step-get-state step) (tdb:step-get-status step) (tdb:step-get-event_time step))) steps))))) tests))))) runs) ;; (db:close-all dbstruct) (set! *didsomething* #t)))) ;;====================================================================== ;; full run ;;====================================================================== ;; get lock in db for full run for this directory ;; for all tests with deps |
︙ | ︙ | |||
787 788 789 790 791 792 793 794 795 796 797 798 799 800 | ;; - if cannot access db > allowed disconnect time then kill job (if (args:get-arg "-runtests") (general-run-call "-runtests" "run a test" (lambda (target runname keys keyvals) (runs:run-tests target runname (args:get-arg "-runtests") user args:arg-hash)))) ;;====================================================================== | > > > > > > > > > > > | 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 | ;; - if cannot access db > allowed disconnect time then kill job (if (args:get-arg "-runtests") (general-run-call "-runtests" "run a test" (lambda (target runname keys keyvals) ;; ;; May or may not implement it this way ... ;; ;; Insert this run into the tasks queue ;; (open-run-close tasks:add tasks:open-db ;; "runtests" ;; user ;; target ;; runname ;; (args:get-arg "-runtests") ;; #f)))) (runs:run-tests target runname (args:get-arg "-runtests") user args:arg-hash)))) ;;====================================================================== |
︙ | ︙ | |||
832 833 834 835 836 837 838 | ;; Get paths to tests ;;====================================================================== ;; Get test paths matching target, runname, and testpatt (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) ;; if we are in a test use the MT_CMDINFO data (if (getenv "MT_CMDINFO") (let* ((startingdir (current-directory)) | | < < < < < | | | | < < < < < | < | | > > < < | | | > > | 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 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 | ;; Get paths to tests ;;====================================================================== ;; Get test paths matching target, runname, and testpatt (if (or (args:get-arg "-test-files")(args:get-arg "-test-paths")) ;; if we are in a test use the MT_CMDINFO data (if (getenv "MT_CMDINFO") (let* ((startingdir (current-directory)) (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target")) (toppath (assoc/default 'toppath cmdinfo))) (change-directory toppath) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) (if (not (launch:setup-for-run)) (begin (debug:print 0 "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) (print path)) paths))) ;; else do a general-run-call (general-run-call "-test-files" "Get paths to test" (lambda (target runname keys keyvals) (let* ((db #f) ;; DO NOT run remote (paths (tests:test-get-paths-matching keys target (args:get-arg "-test-files")))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== ;; Archive tests ;;====================================================================== ;; Archive tests matching target, runname, and testpatt (if (args:get-arg "-archive") ;; if we are in a test use the MT_CMDINFO data (if (getenv "MT_CMDINFO") (let* ((startingdir (current-directory)) (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (state (args:get-arg ":state")) (status (args:get-arg ":status")) (target (args:get-arg "-target"))) (change-directory testpath) (if (not target) (begin (debug:print 0 "ERROR: -target is required.") (exit 1))) (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, giving up on -archive, exiting") (exit 1))) (let* ((keys (rmt:get-keys)) (paths (tests:test-get-paths-matching keys target))) (set! *didsomething* #t) (for-each (lambda (path) (print path)) paths)) ;; (if (sqlite3:database? db)(sqlite3:finalize! db)) ) ;; else do a general-run-call (general-run-call "-test-paths" "Get paths to tests" (lambda (target runname keys keyvals) (let* ((paths (tests:test-get-paths-matching keys target))) (for-each (lambda (path) (print path)) paths)))))) ;;====================================================================== ;; Extract a spreadsheet from the runs database ;;====================================================================== (if (args:get-arg "-extract-ods") (general-run-call "-extract-ods" "Make ods spreadsheet" (lambda (target runname keys keyvals) (let ((dbstruct (make-dbr:dbstruct path: *toppath* local: #t)) (outputfile (args:get-arg "-extract-ods")) (runspatt (or (args:get-arg "-runname")(args:get-arg ":runname"))) (pathmod (args:get-arg "-pathmod"))) ;; (keyvalalist (keys->alist keys "%"))) (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvals: " keyvals) (db:extract-ods-file dbstruct outputfile keyvals (if runspatt runspatt "%") pathmod) (db:close-all dbstruct) (set! *didsomething* #t))))) ;;====================================================================== ;; execute the test ;; - gets called on remote host ;; - receives info from the -execute param ;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file) ;; - gathers host info and |
︙ | ︙ | |||
966 967 968 969 970 971 972 | ;;====================================================================== (define (megatest:step step state status logfile msg) (if (not (getenv "MT_CMDINFO")) (begin (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") (exit 5)) | | < < < < < < | | 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 1057 1058 1059 1060 | ;;====================================================================== (define (megatest:step step state status logfile msg) (if (not (getenv "MT_CMDINFO")) (begin (debug:print 0 "ERROR: MT_CMDINFO env var not set, -step must be called *inside* a megatest invoked environment!") (exit 5)) (let* ((cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f)) (change-directory testpath) (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (and state status) (rmt:teststep-set-status! run-id test-id step state status msg logfile) (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 |
︙ | ︙ | |||
1018 1019 1020 1021 1022 1023 1024 | (args:get-arg "-runstep") (args:get-arg "-summarize-items")) (if (not (getenv "MT_CMDINFO")) (begin (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") (exit 5)) (let* ((startingdir (current-directory)) | | < < < < | | | | | 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 | (args:get-arg "-runstep") (args:get-arg "-summarize-items")) (if (not (getenv "MT_CMDINFO")) (begin (debug:print 0 "ERROR: MT_CMDINFO env var not set, commands -test-status, -runstep and -setlog must be called *inside* a megatest environment!") (exit 5)) (let* ((startingdir (current-directory)) (cmdinfo (common:read-encoded-string (getenv "MT_CMDINFO"))) (testpath (assoc/default 'testpath cmdinfo)) (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) (db #f) ;; (open-db)) (state (args:get-arg ":state")) (status (args:get-arg ":status"))) (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area)) (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 run-id test-id)) (if (args:get-arg "-setlog") (let ((logfname (args:get-arg "-setlog"))) (rmt:test-set-log! run-id test-id logfname))) (if (args:get-arg "-set-toplog") ;; DO NOT run remote (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog"))) (if (args:get-arg "-summarize-items") ;; DO NOT run remote (tests:summarize-items run-id test-id test-name #t)) ;; do force here (if (args:get-arg "-runstep") (if (null? remargs) (begin (debug:print 0 "ERROR: nothing specified to run!") (if db (sqlite3:finalize! db)) (exit 6)) (let* ((stepname (args:get-arg "-runstep")) |
︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 | ((tcsh csh ksh) ">&") ((zsh bash sh ash) "2>&1 >") (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test | < | | | < | | 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 | ((tcsh csh ksh) ">&") ((zsh bash sh ash) "2>&1 >") (else ">&"))) (fullcmd (conc "(" (string-intersperse (cons cmd params) " ") ") " redir " " logfile))) ;; mark the start of the test (rmt:teststep-set-status! run-id test-id stepname "start" "n/a" (args:get-arg "-m") logfile) ;; run the test step (debug:print-info 2 "Running \"" fullcmd "\" in directory \"" startingdir) (change-directory startingdir) (set! exitstat (system fullcmd)) (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! run-id test-id htmllogfile))) (let ((msg (args:get-arg "-m"))) (rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile)) ))) (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")) |
︙ | ︙ | |||
1124 1125 1126 1127 1128 1129 1130 | (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable")) res))) (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) | | | | | | 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 | (list ":value" ":tol" ":expected" ":first_err" ":first_warn" ":units" ":category" ":variable")) res))) (if (and (args:get-arg "-test-status") (or (not state) (not status))) (begin (debug:print 0 "ERROR: You must specify :state and :status with every call to -test-status\n" help) (if (sqlite3:database? db)(sqlite3:finalize! db)) (exit 6))) (let* ((msg (args:get-arg "-m")) (numoth (length (hash-table-keys otherdata)))) ;; Convert to rpc inside the tests:test-set-status! call, not here (tests:test-set-status! run-id test-id state newstatus msg otherdata work-area: work-area)))) (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t)))) ;;====================================================================== ;; Various helper commands can go below here ;;====================================================================== (if (or (args:get-arg "-showkeys") (args:get-arg "-show-keys")) (let ((db #f) (keys #f)) (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! keys (cdb:remote-run db:get-keys db)) (debug:print 1 "Keys: " (string-intersperse keys ", ")) (if (sqlite3:database? db)(sqlite3:finalize! db)) (set! *didsomething* #t))) (if (args:get-arg "-gui") (begin (debug:print 0 "Look at the dashboard for now") ;; (megatest-gui) (set! *didsomething* #t))) |
︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 | (if (args:get-arg "-cleanup-db") (begin (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local | | > > > > > > > > > | | 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 | (if (args:get-arg "-cleanup-db") (begin (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) ;; keep this one local ;; (open-run-close db:clean-up #f) (db:multi-db-sync #f ;; do all run-ids ;; 'new2old 'killservers 'dejunk ;; 'adj-testids ;; 'old2new 'new2old ) (set! *didsomething* #t))) (if (args:get-arg "-mark-incompletes") (begin (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") b (exit 1))) (open-run-close db:find-and-mark-incomplete #f) (set! *didsomething* #t))) ;;====================================================================== ;; Update the tests meta data from the testconfig files ;;====================================================================== |
︙ | ︙ | |||
1221 1222 1223 1224 1225 1226 1227 | ;;====================================================================== ;; Start a repl ;;====================================================================== (if (or (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup-for-run)) | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < | > | | 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 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 | ;;====================================================================== ;; Start a repl ;;====================================================================== (if (or (args:get-arg "-repl") (args:get-arg "-load")) (let* ((toppath (launch:setup-for-run)) (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))) (if dbstruct (begin (set! *db* dbstruct) (set! *client-non-blocking-mode* #t) (import readline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (gnu-history-install-file-manager (string-append (or (get-environment-variable "HOME") ".") "/.megatest_history")) (current-input-port (make-gnu-readline-port "megatest> ")) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))) (db:close-all dbstruct)) (exit)) (set! *didsomething* #t))) ;;====================================================================== ;; Wait on a run to complete ;;====================================================================== (if (and (args:get-arg "-run-wait") (not (args:get-arg "-runtests"))) ;; run-wait is built into runtests now (begin (if (not (launch:setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (operate-on 'run-wait) (set! *didsomething* #t))) ;; ;; ;; redo me ;; Not converted to use dbstruct yet ;; ;; ;; redo me ;; ;; ;; ;; redo me (if (args:get-arg "-convert-to-norm") ;; ;; ;; redo me (let* ((toppath (setup-for-run)) ;; ;; ;; redo me (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t)))) ;; ;; ;; redo me (for-each ;; ;; ;; redo me (lambda (field) ;; ;; ;; redo me (let ((dat '())) ;; ;; ;; redo me (debug:print-info 0 "Getting data for field " field) ;; ;; ;; redo me (sqlite3:for-each-row ;; ;; ;; redo me (lambda (id val) ;; ;; ;; redo me (set! dat (cons (list id val) dat))) ;; ;; ;; redo me (db:get-db db run-id) ;; ;; ;; redo me (conc "SELECT id," field " FROM tests;")) ;; ;; ;; redo me (debug:print-info 0 "found " (length dat) " items for field " field) ;; ;; ;; redo me (let ((qry (sqlite3:prepare db (conc "UPDATE tests SET " field "=? WHERE id=?;")))) ;; ;; ;; redo me (for-each ;; ;; ;; redo me (lambda (item) ;; ;; ;; redo me (let ((newval ;; (sdb:qry 'getid ;; ;; ;; redo me (cadr item))) ;; ) ;; ;; ;; redo me (if (not (equal? newval (cadr item))) ;; ;; ;; redo me (debug:print-info 0 "Converting " (cadr item) " to " newval " for test #" (car item))) ;; ;; ;; redo me (sqlite3:execute qry newval (car item)))) ;; ;; ;; redo me dat) ;; ;; ;; redo me (sqlite3:finalize! qry)))) ;; ;; ;; redo me (db:close-all dbstruct) ;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment")) ;; ;; ;; redo me (set! *didsomething* #t))) (if (args:get-arg "-import-megatest.db") (begin (db:multi-db-sync #f ;; do all run-ids 'killservers 'dejunk 'adj-testids 'old2new ;; 'new2old ) (set! *didsomething* #t))) (if (args:get-arg "-sync-to-megatest.db") (begin (db:multi-db-sync #f ;; do all run-ids 'new2old ) (set! *didsomething* #t))) ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if *runremote* (close-all-connections!)) (if (not *didsomething*) (debug:print 0 help)) (set! *time-to-exit* #t) (thread-join! *watchdog*) (if (not (eq? *globalexitstatus* 0)) (if (or (args:get-arg "-runtests")(args:get-arg "-runall")) (begin (debug:print 0 "NOTE: Subprocesses with non-zero exit code detected: " *globalexitstatus*) (exit 0)) (case *globalexitstatus* ((0)(exit 0)) ((1)(exit 1)) ((2)(exit 2)) (else (exit 3))))) |
Modified mt.scm from [bbcabbe252] to [15956fcc00].
︙ | ︙ | |||
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 | (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses runs)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; This is the Megatest API. All generally "useful" routines will be wrapped or extended ;; here. ;;====================================================================== ;; R U N S ;;====================================================================== ;; runs:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; | > > | | | | | < < < > | | > | | 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 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses runs)) (declare (uses rmt)) ;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") ;; This is the Megatest API. All generally "useful" routines will be wrapped or extended ;; here. ;;====================================================================== ;; R U N S ;;====================================================================== ;; runs:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; (define (mt:get-runs-by-patt keys runnamepatt targpatt) (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) (runslst (vector-ref runsdat 1)) (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit))) (debug:print-info 4 "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 "next-batch: " next-batch) (loop next-batch full-list new-offset limit)) (vector header full-list))))) ;;====================================================================== ;; T E S T S ;;====================================================================== (define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)) (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals)) (res '()) (offset 0) (limit 500)) (let* ((full-list (append res testsdat)) (have-more (eq? (length testsdat) limit))) (if have-more (let ((new-offset (+ offset limit))) (debug:print-info 4 "More than " limit " tests, have " (length full-list) " tests so far.") (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals) full-list new-offset limit)) full-list)))) (define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f) ) (let* ((key (list run-id waitons ref-item-path mode)) (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) (if last-time (< (current-seconds)(+ last-time 5)) #f)))) (if useres (let ((result (vector-ref res 1))) (debug:print 4 "Using lazy value res: " result) result) (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap))) ;; (let ((newres (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) newres)))) (define (mt:get-run-stats dbstruct run-id) ;; Get run stats from local access, move this ... but where? (db:get-run-stats dbstruct run-id)) (define (mt:discard-blocked-tests run-id failed-test tests test-records) (if (null? tests) tests (begin (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) (let loop ((testn (car tests)) |
︙ | ︙ | |||
126 127 128 129 130 131 132 | res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== | | | > | > | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 | res) (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== (define (mt:process-triggers run-id test-id newstate newstatus) (let* ((test-dat (rmt:get-test-info-by-id run-id test-id)) (test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb* (db:test-get-rundir test-dat)) ;; ) ;; ) (test-name (db:test-get-testname test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat)))) (if (and test-rundir ;; #f means no dir set yet (file-exists? test-rundir) (directory? test-rundir)) (begin (push-directory test-rundir) (set! tconfig (mt:lazy-read-test-config test-name)) (pop-directory) (for-each (lambda (trigger) (let ((cmd (configf:lookup tconfig "triggers" trigger)) |
︙ | ︙ | |||
158 159 160 161 162 163 164 | (conc state "/") (conc "/" status))))))) ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== | > | | < | | < < < | < < | | | | | | | | | | | < < < < < < < < | 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 195 196 197 198 | (conc state "/") (conc "/" status))))))) ;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== ;; speed up for common cases with a little logic (define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (if (not (and run-id test-id)) (begin (debug:print 0 "ERROR: bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) (print-call-chain (current-error-port)) #f) (begin (cond ((and newstate newstatus newcomment) (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) ((and newstate newstatus) (rmt:general-call 'state-status run-id newstate newstatus test-id)) (else (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) (mt:process-triggers run-id test-id newstate newstatus) #t))) (define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) (let ((test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))) (mt:test-set-state-status-by-id test-id new-state new-status new-comment))) (define (mt:lazy-read-test-config test-name) (let ((tconf (hash-table-ref/default *testconfigs* test-name #f))) (if tconf tconf (let ((test-dirs (tests:get-tests-search-path *configdat*))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) |
︙ | ︙ |
Modified newdashboard.scm from [9e84c96b6c] to [24924c0cda].
1 2 3 4 5 6 7 8 9 10 11 | ;;====================================================================== ;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | ;;====================================================================== ;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use format numbers) (require-library iup) (import (prefix iup iup:)) (use canvas-draw) (use sqlite3 srfi-1 posix regex regex-case srfi-69) (import (prefix sqlite3 sqlite3:)) |
︙ | ︙ | |||
70 71 72 73 74 75 76 | (exit))) (if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) | | | | | | > > > > > > > > | 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 | (exit))) (if (not (launch:setup-for-run)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) ;; (if (args:get-arg "-host") ;; (begin ;; (set! *runremote* (string-split (args:get-arg "-host" ":"))) ;; (client:launch)) ;; (client:launch)) (define *dbdir* (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (define *dbstruct-local* (make-dbr:dbstruct path: *dbdir* local: #t)) (define *db-file-path* (db:dbfile-path 0)) ;; HACK ALERT: this is a hack, please fix. (define *read-only* (not (file-read-access? *db-file-path*))) (debug:setup) (define *tim* (iup:timer)) (define *ord* #f) (iup:attribute-set! *tim* "TIME" 300) |
︙ | ︙ | |||
265 266 267 268 269 270 271 | (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) ""))) (system (conc "cd " rundir ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) | | | > > > | | | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 | (if (directory-exists? rundir) (let ((shell (if (get-environment-variable "SHELL") (conc "-e " (get-environment-variable "SHELL")) ""))) (system (conc "cd " rundir ";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&"))) (message-window (conc "Directory " rundir " not found"))))) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -12")) (command-launch-button (iup:button "Execute!" ;; #:expand "HORIZONTAL" #:size "50x" #:action (lambda (x) (let ((cmd (iup:attribute command-text-box "VALUE"))) (system (conc cmd " &")))))) (run-test (lambda (x) (iup:attribute-set! command-text-box "VALUE" (conc "xterm -geometry 180x20 -e \"megatest -target " keystring " :runname " runname " -runtests " (conc testname "/" (if (equal? item-path "") "%" item-path)) |
︙ | ︙ | |||
314 315 316 317 318 319 320 | #:expand "YES" #:numcol 1 #:numlin 5 #:numcol-visible 1 #:numlin-visible 5)) (steps-matrix (iup:matrix #:expand "YES" | | | | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 | #:expand "YES" #:numcol 1 #:numlin 5 #:numcol-visible 1 #:numlin-visible 5)) (steps-matrix (iup:matrix #:expand "YES" #:numcol 6 #:numlin 50 #:numcol-visible 6 #:numlin-visible 8)) (data-matrix (iup:matrix #:expand "YES" #:numcol 8 #:numlin 50 #:numcol-visible 8 #:numlin-visible 8)) |
︙ | ︙ | |||
345 346 347 348 349 350 351 352 | ;; (iup:attribute-set! mat "WIDTH1" "120") ;; (iup:attribute-set! mat "WIDTH0" "100")) (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix)) ;; Steps matrix (iup:attribute-set! steps-matrix "0:1" "Step Name") (iup:attribute-set! steps-matrix "0:2" "Start") (iup:attribute-set! steps-matrix "0:3" "End") | > | > | | > | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 | ;; (iup:attribute-set! mat "WIDTH1" "120") ;; (iup:attribute-set! mat "WIDTH0" "100")) (list run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix)) ;; Steps matrix (iup:attribute-set! steps-matrix "0:1" "Step Name") (iup:attribute-set! steps-matrix "0:2" "Start") (iup:attribute-set! steps-matrix "WIDTH2" "40") (iup:attribute-set! steps-matrix "0:3" "End") (iup:attribute-set! steps-matrix "WIDTH3" "40") (iup:attribute-set! steps-matrix "0:4" "Status") (iup:attribute-set! steps-matrix "WIDTH4" "40") (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "WIDTH5" "40") (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") ;; (iup:attribute-set! steps-matrix "WIDTH1" "120") ;; (iup:attribute-set! steps-matrix "WIDTH0" "100") ;; Data matrix |
︙ | ︙ | |||
384 385 386 387 388 389 390 | (iup:attribute-set! mat "REDRAW" "ALL"))) (list (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" )) (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment")) (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration")) (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description")))) | > > | | > | | > | | | | | | | | > | | < | > > > > | | | | | | | | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 | (iup:attribute-set! mat "REDRAW" "ALL"))) (list (list run-info-matrix '("Run Id" "Target" "Runname" "Run Start Time" )) (list test-info-matrix '("Test Id" "Testname" "Itempath" "State" "Status" "Test Start Time" "Comment")) (list test-run-matrix '("Hostname" "Host info" "Disk Free" "CPU Load" "Run Duration")) (list meta-dat-matrix '("Author" "Owner" "Last Reviewed" "Tags" "Description")))) (iup:split #:orientation "HORIZONTAL" (iup:vbox (iup:hbox (iup:vbox run-info-matrix test-info-matrix) ;; test-info-matrix) (iup:vbox test-run-matrix meta-dat-matrix)) (iup:vbox (iup:vbox (iup:hbox (iup:button "View Log" #:action viewlog #:size "60x" ) ;; #:size "30x" (iup:button "Start Xterm" #:action xterm #:size "60x" )) ;; #:size "30x" (iup:hbox (iup:button "Run Test" #:action run-test #:size "60x" ) ;; #:size "30x" (iup:button "Clean Test" #:action remove-test #:size "60x" ))) ;; #:size "30x" (iup:hbox ;; hiup:split ;; hbox ;; #:orientation "HORIZONTAL" ;; #:value 300 command-text-box command-launch-button))) (iup:vbox (let ((tabs (iup:tabs steps-matrix data-matrix))) (iup:attribute-set! tabs "TABTITLE0" "Test Steps") (iup:attribute-set! tabs "TABTITLE1" "Test Data") tabs))))) ;; Test browser (define (tests window-id) (iup:split (let* ((tb (iup:treebox #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (test-id (tree-path->test-id (cdr run-path)))) (if test-id |
︙ | ︙ | |||
436 437 438 439 440 441 442 443 | ;; The function to update the fields in the test view panel (define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix) ;; get test-id ;; then get test record (if testdat (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f)) (test-data (hash-table-ref/default testdat test-id #f)) (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) | > > | | > > | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 | ;; The function to update the fields in the test view panel (define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix) ;; get test-id ;; then get test record (if testdat (let* ((test-id (hash-table-ref/default (dboard:data-get-curr-test-ids *data*) window-id #f)) (test-data (hash-table-ref/default testdat test-id #f)) (run-id (db:test-get-run_id test-data)) (targ/runname (hash-table-ref/default (dboard:data-get-run-keys *data*) run-id '())) (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) (steps-dat (dcommon:get-compressed-steps *dbstruct-local* run-id test-id))) (if test-data (begin ;; (for-each (lambda (data) (let ((mat (car data)) (vals (cadr data)) |
︙ | ︙ | |||
484 485 486 487 488 489 490 491 492 493 | (if test-id (list (db:test-get-host test-data) (db:test-get-uname test-data) (db:test-get-diskfree test-data) (db:test-get-cpuload test-data) (seconds->hr-min-sec (db:test-get-run_duration test-data))) (make-list 5 ""))) ;;(list meta-dat-matrix ;; (if test-id ;; (list ( | > > < | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 | (if test-id (list (db:test-get-host test-data) (db:test-get-uname test-data) (db:test-get-diskfree test-data) (db:test-get-cpuload test-data) (seconds->hr-min-sec (db:test-get-run_duration test-data))) (make-list 5 ""))) )) (dcommon:populate-steps steps-dat steps-matrix)))))) ;;(list meta-dat-matrix ;; (if test-id ;; (list ( ;; db:test-get-id ;; db:test-get-run_id ;; db:test-get-testname ;; db:test-get-state ;; db:test-get-status |
︙ | ︙ | |||
550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 | ;;====================================================================== ;; Main Panel (define (main-panel window-id) (iup:dialog #:title "Megatest Control Panel" #:menu (dcommon:main-menu) (let ((tabtop (iup:tabs (runs window-id) (tests window-id) (runcontrol window-id) (mtest window-id) (rconfig window-id) ))) (iup:attribute-set! tabtop "TABTITLE0" "Runs") (iup:attribute-set! tabtop "TABTITLE1" "Tests") (iup:attribute-set! tabtop "TABTITLE2" "Run Control") (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) | > | | | > | | 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 | ;;====================================================================== ;; Main Panel (define (main-panel window-id) (iup:dialog #:title "Megatest Control Panel" #:menu (dcommon:main-menu) #:shrink "YES" (let ((tabtop (iup:tabs (runs window-id) (tests window-id) (runcontrol window-id) (mtest window-id) (rconfig window-id) ))) (iup:attribute-set! tabtop "TABTITLE0" "Runs") (iup:attribute-set! tabtop "TABTITLE1" "Tests") (iup:attribute-set! tabtop "TABTITLE2" "Run Control") (iup:attribute-set! tabtop "TABTITLE3" "megatest.config") (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) (define (newdashboard dbstruct) (let* ((data (make-hash-table)) (keys (db:get-keys dbstruct)) (runname "%") (testpatt "%") (keypatts (map (lambda (k)(list k "%")) keys)) (states '()) (statuses '()) (nextmintime (current-milliseconds)) (my-window-id *current-window-id*)) (set! *current-window-id* (+ 1 *current-window-id*)) (dboard:data-set-runs! *data* data) ;; make this data available to the rest of the application (iup:show (main-panel my-window-id)) ;; Yes, running iup:show will pop up a new panel ;; (iup:show (main-panel my-window-id)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) ;; Want to dedicate no more than 50% of the time to this so skip if ;; 2x delta time has not passed since last query (if (< nextmintime (current-milliseconds)) (let* ((starttime (current-milliseconds)) (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id)) (endtime (current-milliseconds))) (set! nextmintime (+ endtime (* 2 (- endtime starttime)))) (debug:print 11 "CHANGE(S): " (car changes) "...")) (debug:print-info 11 "Server overloaded")))))) (dboard:data-set-updaters! *data* (make-hash-table)) (newdashboard *dbstruct-local*) (iup:main-loop) |
Added oldsrc/fs-transport.scm version [d187681c70].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (import (prefix sqlite3 sqlite3:)) (use spiffy uri-common intarweb http-client spiffy-request-vars) (tcp-buffer-size 2048) (declare (unit fs-transport)) (declare (uses common)) (declare (uses db)) (declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (include "common_records.scm") (include "db_records.scm") ;;====================================================================== ;; F S T R A N S P O R T S E R V E R ;;====================================================================== ;; There is no "server" per se but a convience routine to make it non ;; necessary to be reopening the db over and over again. ;; (define (fs:process-queue-item packet) (if (not *megatest-db*) ;; we will require that (setup-for-run) has already been called (set! *megatest-db* (open-db))) (debug:print-info 11 "fs:process-queue-item called with packet=" packet) (db:process-queue-item *megatest-db* packet)) |
Added oldsrc/zmq-transport.scm version [1f9025d277].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 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 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 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 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 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | ;;====================================================================== ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (require-extension (srfi 18) extras tcp s11n) (use sqlite3 srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest) (import (prefix sqlite3 sqlite3:)) (use zmq) (declare (unit zmq-transport)) (declare (uses common)) (declare (uses db)) (declare (uses tests)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses server)) (include "common_records.scm") (include "db_records.scm") ;; Transition to pub --> sub with pull <-- push ;; ;; 1. client sends request to server via push to the pull port ;; 2. server puts request in queue or processes immediately as appropriate ;; 3. server puts responses from completed requests into pub port ;; ;; TODO ;; ;; Done Tested ;; [x] [ ] 1. Add columns pullport pubport to servers table ;; [x] [ ] 2. Add rm of monitor.db if older than 11/12/2012 ;; [x] [ ] 3. Add create of pullport and pubport with finding of available ports ;; [x] [ ] 4. Add client compose of request ;; [x] [ ] - name of client: testname/itempath-test_id-hostname ;; [x] [ ] - name of request: callname, params ;; [x] [ ] - request key: f(clientname, callname, params) ;; [x] [ ] 5. Add processing of subscription hits ;; [x] [ ] - done when get key ;; [x] [ ] - return results ;; [x] [ ] 6. Add timeout processing ;; [x] [ ] - after 60 seconds ;; [ ] [ ] i. check server alive, connect to new if necessary ;; [ ] [ ] ii. resend request ;; [ ] [ ] 7. Turn self ping back on (define (zmq-transport:make-server-url hostport) (if (not hostport) #f (conc "tcp://" (car hostport) ":" (cadr hostport)))) (define *server-loop-heart-beat* (current-seconds)) (define *heartbeat-mutex* (make-mutex)) ;;====================================================================== ;; S E R V E R ;;====================================================================== (define-inline (zmqsock:get-pub dat)(vector-ref dat 0)) (define-inline (zmqsock:get-pull dat)(vector-ref dat 1)) (define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0)) (define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0)) (define (zmq-transport:run hostn) (debug:print 2 "Attempting to start the server ...") (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting") (exit)))) (let* ((db (open-db)) ;; here we *do not* want to be opening and closing the db (zmq-sdat1 #f) (zmq-sdat2 #f) (pull-socket #f) (pub-socket #f) (p1 #f) (p2 #f) (zmq-sockets-dat #f) (iface (if (string=? "-" hostn) "*" ;; (get-host-name) hostn)) (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") #f))) (if ipstr ipstr hostname))) (last-run 0)) (set! zmq-sockets-dat (zmq-transport:setup-ports ipaddrstr (if (args:get-arg "-port") (string->number (args:get-arg "-port")) (+ 5000 (random 1001))))) (set! zmq-sdat1 (car zmq-sockets-dat)) (set! pull-socket (cadr zmq-sdat1)) ;; (iface s port) (set! p1 (caddr zmq-sdat1)) (set! zmq-sdat2 (cadr zmq-sockets-dat)) (set! pub-socket (cadr zmq-sdat2)) (set! p2 (caddr zmq-sdat2)) (set! *cache-on* #t) (set! *runremote* (vector pull-socket pub-socket)) ;; overloading the use of *runremote* BUG!? ;; what to do when we quit ;; ;; (on-exit (lambda () ;; (if (and *toppath* *server-info*) ;; (open-run-close tasks:server-deregister-self tasks:open-db (car *server-info*)) ;; (let loop () ;; (let ((queue-len 0)) ;; (thread-sleep! (random 5)) ;; (mutex-lock! *incoming-mutex*) ;; (set! queue-len (length *incoming-data*)) ;; (mutex-unlock! *incoming-mutex*) ;; (if (> queue-len 0) ;; (begin ;; (debug:print-info 0 "Queue not flushed, waiting ...") ;; (loop)))))))) ;; The heavy lifting ;; ;; make-vector-record cdb packet client-sig qtype immediate query-sig params qtime ;; (debug:print-info 11 "Server setup complete, start listening for messages") (let loop ((queue-lst '())) (let* ((rawmsg (receive-message* pull-socket)) (packet (db:string->obj rawmsg)) (qtype (cdb:packet-get-qtype packet))) (debug:print-info 12 "server=> received packet=" packet) (if (not (member qtype '(sync ping))) (begin (mutex-lock! *heartbeat-mutex*) (set! *last-db-access* (current-seconds)) (mutex-unlock! *heartbeat-mutex*))) (if #t ;; (cdb:packet-get-immediate packet) ;; process immediately or put in queue (begin (db:process-queue-item db packet) ;; (open-run-close db:process-queue #f pub-socket (cons packet queue-lst)) (loop '())) (loop (cons packet queue-lst))))))) ;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; (define (zmq-transport:keep-running) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (let* ((server-info (let loop () (let ((sdat #f)) (mutex-lock! *heartbeat-mutex*) (set! sdat *server-info*) (mutex-unlock! *heartbeat-mutex*) (if sdat sdat (begin (debug:print 12 "WARNING: server not started yet, waiting few seconds before trying again") (sleep 4) (loop)))))) (iface (cadr server-info)) (pullport (caddr server-info)) (pubport (cadddr server-info)) ;; id interface pullport pubport) ;; (zmq-sockets (zmq-transport:client-connect iface pullport pubport)) (last-access 0)) (debug:print-info 11 "heartbeat started for zmq server on " iface " " pullport " " pubport) (let loop ((count 0)) (thread-sleep! 4) ;; no need to do this very often ;; NB// sync currently does NOT return queue-length ;; GET REAL QUEUE LENGTH FROM THE VARIABLE (let ((queue-len 0)) ;; FOR NOW DO NOT DO THIS (cdb:client-call zmq-sockets 'sync #t 1))) ;; (print "Server running, count is " count) (if (< count 1) ;; 3x3 = 9 secs aprox (loop (+ count 1))) ;; NOTE: Get rid of this mechanism! It really is not needed... (open-run-close tasks:server-update-heartbeat tasks:open-db (car server-info)) ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) (if (> (+ last-access ;; (* 50 60 60) ;; 48 hrs ;; 60 ;; one minute ;; (* 60 60) ;; one hour (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. ) (current-seconds)) (begin (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (loop 0)) (begin (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) (open-run-close tasks:server-deregister-self tasks:open-db (get-host-name)) (thread-sleep! 1) (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Server shutdown complete. Exiting") (exit))))))) (define (zmq-transport:find-free-port-and-open iface s port stype #!key (trynum 50)) (let ((s (if s s (make-socket stype))) (p (if (number? port) port 5555)) (old-handler (current-exception-handler))) (handle-exceptions exn (begin (debug:print 0 "Failed to bind to port " p ", trying next port") (debug:print 0 " EXCEPTION: " ((condition-property-accessor 'exn 'message) exn)) ;; (old-handler) ;; (print-call-chain) (if (> trynum 0) (zmq-transport:find-free-port-and-open iface s (+ p 1) trynum: (- trynum 1)) (debug:print-info 0 "Tried ports up to " p " but all were in use. Please try a different port range by starting the server with parameter \" -port N\" where N is the starting port number to use")) (exit)) ;; To exit or not? That is the question. (let ((zmq-url (conc "tcp://" iface ":" p))) (debug:print 2 "Trying to start server on " zmq-url) (bind-socket s zmq-url) (list iface s port))))) (define (zmq-transport:setup-ports ipaddrstr startport) (let* ((s1 (zmq-transport:find-free-port-and-open ipaddrstr #f startport 'pull)) (p1 (caddr s1)) (s2 (zmq-transport:find-free-port-and-open ipaddrstr #f (+ 1 (if p1 p1 (+ startport 1))) 'pub)) (p2 (caddr s2))) (set! *runremote* #f) (debug:print 0 "Server started on " ipaddrstr " ports " p1 " and " p2) (mutex-lock! *heartbeat-mutex*) (set! *server-info* (open-run-close tasks:server-register tasks:open-db (current-process-id) ipaddrstr p1 0 'live 'zmq pubport: p2)) (debug:print-info 11 "*server-info* set to " *server-info*) (mutex-unlock! *heartbeat-mutex*) (list s1 s2))) (define (zmq-transport:mk-signature) (message-digest-string (md5-primitive) (with-output-to-string (lambda () (write (list (current-directory) (argv))))))) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;;====================================================================== ;; C L I E N T S ;;====================================================================== ;; (define (zmq-transport:client-socket-connect iface port #!key (context #f)(type 'req)(subscriptions '())) (debug:print-info 3 "client-connect " iface ":" port ", type=" type ", subscriptions=" subscriptions) (let ((connect-ok #f) (zmq-socket (if context (make-socket type context) (make-socket type))) (conurl (zmq-transport:make-server-url (list iface port)))) (if (socket? zmq-socket) (begin ;; first apply subscriptions (for-each (lambda (subscription) (debug:print 2 "Subscribing to " subscription) (socket-option-set! zmq-socket 'subscribe subscription)) subscriptions) (connect-socket zmq-socket conurl) zmq-socket) (begin (debug:print 0 "ERROR: Failed to open socket to " conurl) #f)))) (define (zmq-transport:client-connect iface pullport pubport) (let* ((push-socket (zmq-transport:client-socket-connect iface pullport type: 'push)) (sub-socket (zmq-transport:client-socket-connect iface pubport type: 'sub subscriptions: (list (client:get-signature) "all"))) (zmq-sockets (vector push-socket sub-socket)) (login-res #f)) (debug:print-info 11 "zmq-transport:client-connect started. Next is login") (set! login-res (client:login serverdat zmq-sockets)) (if (and (not (null? login-res)) (car login-res)) (begin (debug:print-info 2 "Logged in and connected to " iface ":" pullport "/" pubport ".") (set! *runremote* zmq-sockets) zmq-sockets) (begin (debug:print-info 2 "Failed to login or connect to " conurl) (set! *runremote* #f) #f)))) ;; run zmq-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. ;; (define (zmq-transport:keep-running) ;; if none running or if > 20 seconds since ;; server last used then start shutdown ;; This thread waits for the server to come alive (let* ((server-info (let loop () (let ((sdat #f)) (mutex-lock! *heartbeat-mutex*) (set! sdat *runremote*) (mutex-unlock! *heartbeat-mutex*) (if sdat sdat (begin (sleep 4) (loop)))))) (iface (car server-info)) (port (cadr server-info)) (last-access 0) (tdb (tasks:open-db)) (spid (tasks:server-get-server-id tdb #f iface port #f))) (print "Keep-running got server pid " spid ", using iface " iface " and port " port) (let loop ((count 0)) (thread-sleep! 4) ;; no need to do this very often ;; NB// sync currently does NOT return queue-length (let () ;; (queue-len (cdb:client-call server-info 'sync #t 1))) ;; (print "Server running, count is " count) (if (< count 1) ;; 3x3 = 9 secs aprox (loop (+ count 1))) ;; NOTE: Get rid of this mechanism! It really is not needed... (tasks:server-update-heartbeat tdb spid) ;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access (mutex-lock! *heartbeat-mutex*) (set! last-access *last-db-access*) (mutex-unlock! *heartbeat-mutex*) (if (> (+ last-access ;; (* 50 60 60) ;; 48 hrs ;; 60 ;; one minute ;; (* 60 60) ;; one hour (* 45 60) ;; 45 minutes, until the db deletion bug is fixed. ) (current-seconds)) (begin (debug:print-info 2 "Server continuing, seconds since last db access: " (- (current-seconds) last-access)) (loop 0)) (begin (debug:print-info 0 "Starting to shutdown the server.") ;; need to delete only *my* server entry (future use) (set! *time-to-exit* #t) (tasks:server-deregister-self tdb (get-host-name)) (thread-sleep! 1) (debug:print-info 0 "Max cached queries was " *max-cache-size*) (debug:print-info 0 "Server shutdown complete. Exiting") (exit))))))) ;; all routes though here end in exit ... (define (zmq-transport:launch) (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: cannot find megatest.config, exiting") (exit)))) (debug:print-info 2 "Starting zmq server") (if *toppath* (let* (;; (th1 (make-thread (lambda () ;; (let ((server-info #f)) ;; ;; wait for the server to be online and available ;; (let loop () ;; (debug:print-info 2 "Waiting for the server to come online before starting heartbeat") ;; (thread-sleep! 2) ;; (mutex-lock! *heartbeat-mutex*) ;; (set! server-info *server-info* ) ;; (mutex-unlock! *heartbeat-mutex*) ;; (if (not server-info)(loop))) ;; (debug:print 2 "Server alive, starting self-ping") ;; (zmq-transport:self-ping server-info) ;; )) ;; "Self ping")) (th2 (make-thread (lambda () (zmq-transport:run (if (args:get-arg "-server") (args:get-arg "-server") "-"))) "Server run")) ;; (th3 (make-thread (lambda ()(zmq-transport:keep-running)) "Keep running")) ) (set! *client-non-blocking-mode* #t) ;; (thread-start! th1) (thread-start! th2) ;; (thread-start! th3) (set! *didsomething* #t) ;; (thread-join! th3) (thread-join! th2) ) (debug:print 0 "ERROR: Failed to setup for megatest"))) (define (zmq-transport:client-signal-handler signum) (handle-exceptions exn (debug:print " ... exiting ...") (let ((th1 (make-thread (lambda () (if (not *received-response*) (receive-message* *runremote*))) ;; flush out last call if applicable "eat response")) (th2 (make-thread (lambda () (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") (thread-sleep! 3) ;; give the flush three seconds to do it's stuff (debug:print 0 " Done.") (exit 4)) "exit on ^C timer"))) (thread-start! th2) (thread-start! th1) (thread-join! th2)))) (define (zmq-transport:client-launch) (set-signal-handler! signal/int zmq-transport:client-signal-handler) (if (zmq-transport:client-setup) (debug:print-info 2 "connected as client") (begin (debug:print 0 "ERROR: Failed to connect as client") (exit)))) ;;====================================================================== ;; Defunct functions ;;====================================================================== ;; ping a server and return number of clients or #f (if no response) ;; NOT IN USE! (define (zmq-transport:ping host port #!key (secs 10)(return-socket #f)) (cdb:use-non-blocking-mode (lambda () (let* ((res #f) (th1 (make-thread (lambda () (let* ((zmq-context (make-context 1)) (zmq-socket (zmq-transport:client-connect host port context: zmq-context))) (if zmq-socket (if (zmq-transport:client-login zmq-socket) (let ((numclients (cdb:num-clients zmq-socket))) (if (not return-socket) (begin (zmq-transport:client-logout zmq-socket) (close-socket zmq-socket))) (set! res (list #t numclients (if return-socket zmq-socket #f)))) (begin ;; (close-socket zmq-socket) (set! res (list #f "CAN'T LOGIN" #f)))) (set! res (list #f "CAN'T CONNECT" #f))))) "Ping: th1")) (th2 (make-thread (lambda () (let loop ((count 1)) (debug:print-info 1 "Ping " count " server on " host " at port " port) (thread-sleep! 2) (if (< count (/ secs 2)) (loop (+ count 1)))) ;; (thread-terminate! th1) (set! res (list #f "TIMED OUT" #f))) "Ping: th2"))) (thread-start! th2) (thread-start! th1) (handle-exceptions exn (set! res (list #f "TIMED OUT" #f)) (thread-join! th1 secs)) res)))) ;; (define (zmq-transport:self-ping server-info) ;; ;; server-info: server-id interface pullport pubport ;; (let ((iface (list-ref server-info 1)) ;; (pullport (list-ref server-info 2)) ;; (pubport (list-ref server-info 3))) ;; (zmq-transport:client-connect iface pullport pubport) ;; (let loop () ;; (thread-sleep! 2) ;; (cdb:client-call *runremote* 'ping #t) ;; (debug:print 4 "zmq-transport:self-ping - I'm alive on " iface ":" pullport "/" pubport "!") ;; (mutex-lock! *heartbeat-mutex*) ;; (set! *server-loop-heart-beat* (current-seconds)) ;; (mutex-unlock! *heartbeat-mutex*) ;; (loop)))) (define (zmq-transport:reply pubsock target query-sig success/fail result) (debug:print-info 11 "zmq-transport:reply target=" target ", result=" result) (send-message pubsock target send-more: #t) (send-message pubsock (db:obj->string (vector success/fail query-sig result)))) |
Added portlogger.scm version [c19f5a6299].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 | ;; Copyright 2006-2014, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) (use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) (import (prefix sqlite3 sqlite3:)) (declare (unit portlogger)) (declare (uses db)) ;; lsof -i (define (portlogger:open-db fname) (let* ((avail (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away (exists (file-exists? fname)) (db (if avail (sqlite3:open-database fname) (begin (system (conc "rm -f " fname)) (sqlite3:open-database fname)))) (handler (make-busy-timeout 136000)) (canwrite (file-write-access? fname))) ;; (db-init (lambda () ;; (sqlite3:execute ;; db ;; "CREATE TABLE IF NOT EXISTS ports ( ;; port INTEGER PRIMARY KEY, ;; state TEXT DEFAULT 'not-used', ;; fail_count INTEGER DEFAULT 0, ;; update_time TIMESTAMP DEFAULT (strftime('%s','now')) );")))) (sqlite3:set-busy-handler! db handler) (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") ;; (if (not exists) ;; needed with IF NOT EXISTS? (sqlite3:execute db "CREATE TABLE IF NOT EXISTS ports ( port INTEGER PRIMARY KEY, state TEXT DEFAULT 'not-used', fail_count INTEGER DEFAULT 0, update_time TIMESTAMP DEFAULT (strftime('%s','now')) );") db)) (define (portlogger:open-run-close proc . params) (let* ((fname (conc "/tmp/." (current-user-name) "-portlogger.db")) (avail (tasks:wait-on-journal fname 10))) ;; wait up to about 10 seconds for the journal to go away (handle-exceptions exn (begin ;; (release-dot-lock fname) (debug:print 0 "ERROR: portlogger:open-run-close failed. " proc " " params) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 "exn=" (condition->list exn)) (if (file-exists? fname)(delete-file fname)) ;; brutally get rid of it (print-call-chain (current-error-port))) (let* (;; (lock (obtain-dot-lock fname 2 9 10)) (db (portlogger:open-db fname)) (res (apply proc db params))) (sqlite3:finalize! db) ;; (release-dot-lock fname) res)))) ;; (fold-row PROC INIT DATABASE SQL . PARAMETERS) (define (portlogger:take-port db portnum) (let* ((qry1 (sqlite3:prepare db "INSERT INTO ports (port,state) VALUES (?,?);")) (qry2 (sqlite3:prepare db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;")) (qry3 (sqlite3:prepare db "SELECT state FROM ports WHERE port=?;")) (res (sqlite3:with-transaction db (lambda () ;; (fold-row (lambda (var curr) (or var curr)) #f db "SELECT var FROM foo WHERE id=100;") (let* ((curr #f) (res #f)) (set! curr (sqlite3:fold-row (lambda (var curr) (or curr var curr)) "not-tried" qry3 portnum)) ;; (print "curr=" curr) (set! res (case (string->symbol curr) ((released) (sqlite3:execute qry2 "taken" portnum) 'taken) ((not-tried) (sqlite3:execute qry1 portnum "taken") 'taken) ((taken) 'already-taken) ((failed) 'failed) (else 'error))) ;; (print "res=" res) res))))) (sqlite3:finalize! qry1) (sqlite3:finalize! qry2) (sqlite3:finalize! qry3) res)) (define (portlogger:get-prev-used-port db) (handle-exceptions exn (begin (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 "exn=" (condition->list exn)) (print-call-chain (current-error-port)) (debug:print 0 "Continuing anyway.") #f) (sqlite3:fold-row (lambda (var curr) (or curr var curr)) #f db "SELECT (port) FROM ports WHERE state='released' LIMIT 1;"))) (define (portlogger:find-port db) (let* ((lowport (let ((val (configf:lookup *configdat* "server" "lowport"))) (if (and val (string->number val)) (string->number val) 32768))) (portnum (or (portlogger:get-prev-used-port db) (+ lowport ;; top of registered ports is 49152 but lets use ports in the registered range (random (- 64000 lowport)))))) (handle-exceptions exn (begin (debug:print 0 "EXCEPTION: portlogger database probably overloaded or unreadable. If you see this message again remove /tmp/.$USER-portlogger.db") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 "exn=" (condition->list exn)) (print-call-chain (current-error-port)) (debug:print 0 "Continuing anyway.")) (portlogger:take-port db portnum)) portnum)) ;; set port to "released", "failed" etc. ;; (define (portlogger:set-port db portnum value) (sqlite3:execute db "UPDATE ports SET state=?,update_time=strftime('%s','now') WHERE port=?;" value portnum)) ;; set port to failed (attempted to take but got error) ;; (define (portlogger:set-failed db portnum) (sqlite3:execute db "UPDATE ports SET state='failed',fail_count=fail_count+1,update_time=strftime('%s','now') WHERE port=?;" portnum)) ;;====================================================================== ;; MAIN ;;====================================================================== (define (portlogger:main . args) (let* ((dbfname (conc "/tmp/." (current-user-name) "-portlogger.db")) (db (portlogger:open-db dbfname)) (numargs (length args)) (result (handle-exceptions exn (begin (debug:print 0 "EXCEPTION: portlogger database at " dbfname " probably overloaded or unreadable. Try removing it.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port))) (cond ((> numargs 1) ;; most commands (case (string->symbol (car args)) ;; commands with two or more params ((take)(portlogger:take-port db (string->number (cadr args)))) ((set) (portlogger:set-port db (string->number (cadr args)) (caddr args)) (caddr args)) ((failed)(portlogger:set-failed db (string->number (cadr args))) 'failed))))))) (sqlite3:finalize! db) result)) ;; (print (apply portlogger:main (cdr (argv)))) |
Modified process.scm from [88799f98f8] to [781c177a90].
︙ | ︙ | |||
49 50 51 52 53 54 55 56 57 58 59 60 61 62 | (define (cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) (process cmd params)))) (let loop ((curr (read-line fh)) (result '())) (if (not (eof-object? curr)) | > > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | (define (cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions exn (begin (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) #f) (let-values (((fh fho pid) (if (null? params) (process cmd) (process cmd params)))) (let loop ((curr (read-line fh)) (result '())) (if (not (eof-object? curr)) |
︙ | ︙ | |||
122 123 124 125 126 127 128 | (let loop ((inl (read-line)) (res '())) (if (eof-object? inl) (reverse res) (let ((pid (string->number inl))) (if proc (proc pid)) (loop (read-line) (cons pid res)))))))) | | > > > > > > > > > | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 | (let loop ((inl (read-line)) (res '())) (if (eof-object? inl) (reverse res) (let ((pid (string->number inl))) (if proc (proc pid)) (loop (read-line) (cons pid res)))))))) (define (process:alive? pid) (handle-exceptions exn ;; possibly pid is a process not a child, look in /proc to see if it is running still (file-exists? (conc "/proc/" pid)) (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) (and (number? rpid) (equal? rpid pid))))) |
Added rmt.scm version [0582204ff9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 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 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 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 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 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 | ;;====================================================================== ;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use json format) (declare (unit rmt)) (declare (uses api)) (declare (uses tdb)) (declare (uses http-transport)) ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; ;; ;; For debugging add the following to ~/.megatestrc ;; ;; (require-library trace) ;; (import trace) ;; (trace ;; rmt:send-receive ;; api:execute-requests ;; ) ;;====================================================================== ;; S U P P O R T F U N C T I O N S ;;====================================================================== ;; #t means - please start a server! ;; (define (rmt:write-frequency-over-limit? cmd run-id) (and (not (member cmd api:read-only-queries)) (let* ((tmprec (hash-table-ref/default *write-frequency* run-id #f)) (record (if tmprec tmprec (let ((v (vector (current-seconds) 0))) (hash-table-set! *write-frequency* run-id v) v))) (count (+ 1 (vector-ref record 1))) (start (vector-ref record 0)) (queries-per-second (/ (* count 1.0) (max (- (current-seconds) start) 1)))) (vector-set! record 1 count) (if (and (> count 10) (> queries-per-second 10)) (begin (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) #t) #f)))) (define (rmt:get-connection-info run-id) (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) (if cinfo cinfo ;; NB// can cache the answer for server running for 10 seconds ... ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) (client:setup run-id) #f)))) ;; cmd is a symbol ;; vars is a json string encoding the parameters for the call ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 0)) ;; clean out old connections (mutex-lock! *db-multi-sync-mutex*) (let ((expire-time (- (current-seconds) 60))) (for-each (lambda (run-id) (let ((connection (hash-table-ref/default *runremote* run-id #f))) (if (and connection (< (http-transport:server-dat-get-last-access connection) expire-time)) (begin (debug:print-info 0 "Discarding connection to server for run-id " run-id ", too long between accesses") (hash-table-delete! *runremote* run-id))))) (hash-table-keys *runremote*))) (mutex-unlock! *db-multi-sync-mutex*) (let* ((run-id (if rid rid 0)) (connection-info (rmt:get-connection-info run-id)) (jparams (db:obj->string params))) (if connection-info ;; use the server if have connection info (let* ((dat (http-transport:client-api-send-receive run-id connection-info cmd jparams)) (res (if (and dat (vector? dat)) (vector-ref dat 1) #f)) (success (if (and dat (vector? dat)) (vector-ref dat 0) #f))) (http-transport:server-dat-update-last-access connection-info) (if success (db:string->obj res) ;; (if (< attemptnum 100) ;; (begin ;; (hash-table-delete! *runremote* run-id) ;; (thread-sleep! 0.5) ;; (rmt:send-receive cmd rid params attempnum: (+ attemptnum 1))) ;; (begin ;; (print-call-chain (current-error-port)) ;; (debug:print 0 "ERROR: too many attempts to communicate have failed. Giving up. Kill your mtest processes and start over") ;; (exit 1))))) (begin ;; let ((new-connection-info (client:setup run-id))) (debug:print 0 "WARNING: Communication failed, trying call to http-transport:client-api-send-receive again.") (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection ;; no longer killing the server in http-transport:client-api-send-receive ;; may kill it here but what are the criteria? ;; start with three calls then kill server (if (eq? attemptnum 3)(tasks:kill-server-run-id run-id)) (thread-sleep! 2) (rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1))))) (if (and (< attemptnum 10) (tasks:need-server run-id)) (begin (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) (rmt:send-receive cmd rid params (+ attemptnum 1))) (rmt:open-qry-close-locally cmd run-id params))))) (define (rmt:update-db-stats run-id rawcmd params duration) (mutex-lock! *db-stats-mutex*) (handle-exceptions exn (begin (debug:print 0 "WARNING: stats collection failed in update-db-stats") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) #f) ;; if this fails we don't care, it is just stats (let* ((cmd (conc "run-id=" run-id " " (if (eq? rawcmd 'general-call) (car params) rawcmd))) (stat-vec (hash-table-ref/default *db-stats* cmd #f))) (if (not stat-vec) (let ((newvec (vector 0 0))) (hash-table-set! *db-stats* cmd newvec) (set! stat-vec newvec))) (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))) (mutex-unlock! *db-stats-mutex*)) (define (rmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" (debug:print 18 "DB Stats\n========") (debug:print 18 (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) (debug:print 18 (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) (sort (hash-table-keys *db-stats*) (lambda (a b) (> (vector-ref (hash-table-ref *db-stats* a) 0) (vector-ref (hash-table-ref *db-stats* b) 0))))))) (define (rmt:get-max-query-average run-id) (mutex-lock! *db-stats-mutex*) (let* ((runkey (conc "run-id=" run-id " ")) (cmds (filter (lambda (x) (substring-index runkey x)) (hash-table-keys *db-stats*))) (res (if (null? cmds) (cons 'none 0) (let loop ((cmd (car cmds)) (tal (cdr cmds)) (max-cmd (car cmds)) (res 0)) (let* ((cmd-dat (hash-table-ref *db-stats* cmd)) (tot (vector-ref cmd-dat 0)) (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction (currmax (max res curravg)) (newmax-cmd (if (> curravg res) cmd max-cmd))) (if (null? tal) (if (> tot 10) (cons newmax-cmd currmax) (cons 'none 0)) (loop (car tal)(cdr tal) newmax-cmd currmax))))))) (mutex-unlock! *db-stats-mutex*) res)) (define (rmt:open-qry-close-locally cmd run-id params) (let* ((dbstruct-local (if *dbstruct-db* *dbstruct-db* (let* ((dbdir (conc (configf:lookup *configdat* "setup" "linktree") "/.db")) (db (make-dbr:dbstruct path: dbdir local: #t))) (set! *dbstruct-db* db) db))) (db-file-path (db:dbfile-path 0))) ;; (read-only (not (file-read-access? db-file-path))) (let* ((start (current-milliseconds)) (res (api:execute-requests dbstruct-local (symbol->string cmd) params)) (duration (- (current-milliseconds) start))) (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write (if (not (member cmd api:read-only-queries)) (let ((start-time (current-seconds))) (mutex-lock! *db-multi-sync-mutex*) ;; (if (not (hash-table-ref/default *db-local-sync* run-id #f)) ;; just set it every time. Is a write more expensive than a read and does it matter? (hash-table-set! *db-local-sync* (or run-id 0) start-time) ;; the oldest "write" (mutex-unlock! *db-multi-sync-mutex*))) res))) (define (rmt:send-receive-no-auto-client-setup connection-info cmd run-id params) (let* ((run-id (if run-id run-id 0)) (jparams (db:obj->string params)) ;; (rmt:dat->json-str params)) (dat (http-transport:client-api-send-receive run-id connection-info cmd jparams))) (if (and dat (vector-ref dat 0)) (db:string->obj (vector-ref dat 1)) (begin (debug:print 0 "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) dat)))) ;; Wrap json library for strings (why the ports crap in the first place?) (define (rmt:dat->json-str dat) (with-output-to-string (lambda () (json-write dat)))) (define (rmt:json-str->dat json-str) (with-input-from-string json-str (lambda () (json-read)))) ;;====================================================================== ;; ;; A C T U A L A P I C A L L S ;; ;;====================================================================== ;;====================================================================== ;; S E R V E R ;;====================================================================== (define (rmt:kill-server run-id) (rmt:send-receive 'kill-server run-id (list run-id))) (define (rmt:start-server run-id) (rmt:send-receive 'start-server 0 (list run-id))) ;;====================================================================== ;; M I S C ;;====================================================================== (define (rmt:login run-id) (rmt:send-receive 'login run-id (list *toppath* megatest-version run-id *my-client-signature*))) ;; This login does no retries under the hood - it acts a bit like a ping. ;; (define (rmt:login-no-auto-client-setup connection-info run-id) (rmt:send-receive-no-auto-client-setup connection-info 'login run-id (list *toppath* megatest-version run-id *my-client-signature*))) ;; hand off a call to one of the db:queries statements ;; added run-id to make looking up the correct db possible ;; (define (rmt:general-call stmtname run-id . params) (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params))) (define (rmt:sync-inmem->db run-id) (rmt:send-receive 'sync-inmem->db run-id '())) (define (rmt:sdb-qry qry val run-id) ;; add caching if qry is 'getid or 'getstr (rmt:send-receive 'sdb-qry run-id (list qry val))) ;; NOT COMPLETED (define (rmt:runtests user run-id testpatt params) (rmt:send-receive 'runtests run-id testpatt)) ;;====================================================================== ;; K E Y S ;;====================================================================== ;; These require run-id because the values come from the run! ;; (define (rmt:get-key-val-pairs run-id) (rmt:send-receive 'get-key-val-pairs run-id (list run-id))) (define (rmt:get-keys) (rmt:send-receive 'get-keys #f '())) ;;====================================================================== ;; T E S T S ;;====================================================================== (define (rmt:get-test-id run-id testname item-path) (rmt:send-receive 'get-test-id run-id (list run-id testname item-path))) (define (rmt:get-test-info-by-id run-id test-id) (if (and (number? run-id)(number? test-id)) (rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id)) (begin (debug:print 0 "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id) (print-call-chain (current-error-port)) #f))) (define (rmt:test-get-rundir-from-test-id run-id test-id) (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id))) (define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f)) (let* ((test-path (if (string? work-area) work-area (rmt:test-get-rundir-from-test-id run-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) ;; WARNING: This currently bypasses the transaction wrapped writes system (define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment))) (define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus) (rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus))) (define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals) (if (number? run-id) (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)) (begin (debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id) (print-call-chain (current-error-port)) '()))) ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) (let ((multi-run-mutex (make-mutex)) (run-id-list (if run-ids run-ids (rmt:get-all-run-ids))) (result '())) (if (null? run-id-list) '() (for-each (lambda (th) (thread-join! th)) ;; I assume that joining completed threads just moves on (let loop ((hed (car run-id-list)) (tal (cdr run-id-list)) (threads '())) (let* ((newthread (make-thread (lambda () (let ((res (rmt:send-receive 'get-tests-for-run-mindata hed (list hed testpatt states status not-in)))) (if (list? res) (begin (mutex-lock! multi-run-mutex) (set! result (append result res)) (mutex-unlock! multi-run-mutex)) (debug:print 0 "ERROR: get-tests-for-run-mindata failed for run-id " hed ", testpatt " testpatt ", states " states ", status " status ", not-in " not-in)))) (conc "multi-run-thread for run-id " hed))) (newthreads (cons newthread threads))) (thread-start! newthread) (thread-sleep! 0.5) ;; give that thread some time to start (if (null? tal) newthreads (loop (car tal)(cdr tal) newthreads)))))) result)) ;; ;; IDEA: Threadify these - they spend a lot of time waiting ... ;; ;; ;; (define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) ;; (let ((run-id-list (if run-ids ;; run-ids ;; (rmt:get-all-run-ids)))) ;; (apply append (map (lambda (run-id) ;; (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-ids testpatt states status not-in))) ;; run-id-list)))) (define (rmt:delete-test-records run-id test-id) (rmt:send-receive 'delete-test-records run-id (list run-id test-id))) ;; This is not needed as test steps are deleted on test delete call ;; ;; (define (rmt:delete-test-step-records run-id test-id) ;; (rmt:send-receive 'delete-test-step-records run-id (list run-id test-id))) (define (rmt:test-set-status-state run-id test-id status state msg) (rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg))) (define (rmt:test-toplevel-num-items run-id test-name) (rmt:send-receive 'test-toplevel-num-items run-id (list run-id test-name))) ;; (define (rmt:get-previous-test-run-record run-id test-name item-path) ;; (rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path))) (define (rmt:get-matching-previous-test-run-records run-id test-name item-path) (rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path))) (define (rmt:test-get-logfile-info run-id test-name) (rmt:send-receive 'test-get-logfile-info run-id (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 run-id (list run-id test-name))) (define (rmt:get-testinfo-state-status run-id test-id) (rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id))) (define (rmt:test-set-log! run-id test-id logf) (if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id))) (define (rmt:test-set-top-process-pid run-id test-id pid) (rmt:send-receive 'test-set-top-process-pid run-id (list run-id test-id pid))) (define (rmt:test-get-top-process-pid run-id test-id) (rmt:send-receive 'test-get-top-process-pid run-id (list run-id test-id))) (define (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt) (rmt:send-receive 'get-run-ids-matching-target #f (list keynames target res runname testpatt statepatt statuspatt))) ;; NOTE: This will open and access ALL run databases. ;; (define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname) (let ((run-ids (rmt:get-run-ids-matching-target keynames target res runname testpatt statepatt statuspatt))) (apply append (map (lambda (run-id) (rmt:send-receive 'test-get-paths-matching-keynames-target-new run-id (list run-id keynames target res testpatt statepatt statuspatt runname))) run-ids)))) (define (rmt:get-run-ids-matching keynames target res) (rmt:send-receive #f 'get-run-ids-matching (list keynames target res))) (define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))) (rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode))) (define (rmt:get-count-tests-running-for-run-id run-id) (rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id))) ;; Statistical queries (define (rmt:get-count-tests-running run-id) (rmt:send-receive 'get-count-tests-running run-id (list run-id))) (define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup) (rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup))) (define (rmt:roll-up-pass-fail-counts run-id test-name item-path status) (rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status))) (define (rmt:update-pass-fail-counts run-id test-name) (rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name))) ;;====================================================================== ;; R U N S ;;====================================================================== (define (rmt:get-run-info run-id) (rmt:send-receive 'get-run-info run-id (list run-id))) ;; Use the special run-id == #f scenario here since there is no run yet (define (rmt:register-run keyvals runname state status user) (rmt:send-receive 'register-run #f (list keyvals runname state status user))) (define (rmt:get-run-name-from-id run-id) (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) (define (rmt:delete-run run-id) (rmt:send-receive 'delete-run run-id (list run-id))) (define (rmt:delete-old-deleted-test-records) (rmt:send-receive 'delete-old-deleted-test-records #f '())) (define (rmt:get-runs runpatt count offset keypatts) (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) (define (rmt:get-runs runpatt count offset keypatts) (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts))) (define (rmt:get-all-run-ids) (rmt:send-receive 'get-all-run-ids #f '())) (define (rmt:get-prev-run-ids run-id) (rmt:send-receive 'get-prev-run-ids #f (list run-id))) (define (rmt:lock/unlock-run run-id lock unlock user) (rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user))) ;; set/get status (define (rmt:get-run-status run-id) (rmt:send-receive 'get-run-status #f (list run-id))) (define (rmt:set-run-status run-id run-status #!key (msg #f)) (rmt:send-receive 'set-run-status #f (list run-id run-status msg))) (define (rmt:update-run-event_time run-id) (rmt:send-receive 'update-run-event_time #f (list run-id))) (define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit) (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit))) (define (rmt:find-and-mark-incomplete run-id ovr-deadtime) (rmt:send-receive 'find-and-mark-incomplete run-id (list run-id ovr-deadtime))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S ;;====================================================================== ;; Need to move this to multi-run section and make associated changes (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f)) (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) (rmt:find-and-mark-incomplete run-id ovr-deadtime)) run-ids))) ;; get the previous record for when this test was run where all keys match but runname ;; returns #f if no such test found, returns a single test record if found ;; ;; Run this at the client end since we have to connect to multiple run-id dbs ;; (define (rmt:get-previous-test-run-record run-id test-name item-path) (let* ((keyvals (rmt:get-key-val-pairs run-id)) (keys (rmt:get-keys)) (selstr (string-intersperse keys ",")) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (if (not keyvals) #f (let ((prev-run-ids (rmt:get-prev-run-ids 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 (rmt:get-tests-for-run 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)))))))))) ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Getting steps is more complicated. ;; ;; If given work area ;; 1. Find the testdat.db file ;; 2. Open the testdat.db file and do the query ;; If not given the work area ;; 1. Do a remote call to get the test path ;; 2. Continue as above ;; (define (rmt:get-steps-for-test run-id test-id) (rmt:send-receive 'get-steps-data run-id (list test-id))) (define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile) (let* ((state (items:check-valid-items "state" state-in)) (status (items:check-valid-items "status" status-in))) (if (or (not state)(not status)) (debug:print 3 "WARNING: Invalid " (if status "status" "state") " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config")) (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile)))) (define (rmt:get-steps-for-test run-id test-id) (rmt:send-receive 'get-steps-for-test run-id (list test-id))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) (if tdb (tdb:read-test-data tdb test-id categorypatt) '()))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) (rmt:send-receive 'testmeta-get-record #f (list testname))) (define (rmt:testmeta-update-field test-name fld val) (rmt:send-receive 'testmeta-update-field #f (list test-name fld val))) (define (rmt:test-data-rollup run-id test-id status) (rmt:send-receive 'test-data-rollup run-id (list run-id test-id status))) (define (rmt:csv->test-data run-id test-id csvdata) (rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata))) |
Added rmtdb.scm version [afdb905959].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | ;;====================================================================== ;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== |
Modified runconfig.scm from [f1fb75b972] to [d97360c67a].
︙ | ︙ | |||
26 27 28 29 30 31 32 | (sections (list "default" thekey))) (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code (debug:print 4 "Using key=\"" thekey "\"") (if change-env (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed. (lambda (keyval) | | | | 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 | (sections (list "default" thekey))) (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code (debug:print 4 "Using key=\"" thekey "\"") (if change-env (for-each ;; NB// This can be simplified with new content of keyvals having all that is needed. (lambda (keyval) (safe-setenv (car keyval)(cadr keyval))) keyvals)) (for-each (lambda (section) (let ((section-dat (hash-table-ref/default confdat section #f))) (if section-dat (for-each (lambda (envvar) (let ((val (cadr (assoc envvar section-dat)))) (hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1)) (if (and (string? envvar) (string? val) change-env) (safe-setenv envvar val)) (hash-table-set! finaldat envvar val))) (map car section-dat))))) sections) (if already-seen (begin (debug:print 2 "Key settings found in runconfig.config:") (for-each (lambda (fullkey) |
︙ | ︙ |
Modified runs.scm from [75aee75df2] to [396462afab].
︙ | ︙ | |||
17 18 19 20 21 22 23 24 25 26 27 28 29 30 | (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") | > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) (declare (uses server)) (declare (uses mt)) ;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") |
︙ | ︙ | |||
54 55 56 57 58 59 60 | (toppath *toppath*) (envdat keyvals) ;; initial values start with keyvals (runconfig #f) (serverdat (if (args:get-arg "-server") *runremote* #f)) ;; to be used later (transport (or (args:get-arg "-transport") 'http)) | < < < < < > | | | < < | < > > | > | > | | | | | | | 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 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 | (toppath *toppath*) (envdat keyvals) ;; initial values start with keyvals (runconfig #f) (serverdat (if (args:get-arg "-server") *runremote* #f)) ;; to be used later (transport (or (args:get-arg "-transport") 'http)) (run-id #f)) ;; Set all the environment vars we know so far, start with keys (for-each (lambda (keyval) (setenv (car keyval)(cadr keyval))) keyvals) ;; Set up various and sundry known vars here (setenv "MT_RUN_AREA_HOME" toppath) (setenv "MT_RUNNAME" runname) (setenv "MT_TARGET" target) (setenv "MT_TESTSUITENAME" (common:get-testsuite-name)) (set! envdat (append envdat (list (list "MT_RUN_AREA_HOME" toppath) (list "MT_RUNNAME" runname) (list "MT_TARGET" target)))) ;; Now can read the runconfigs file ;; (set! runconfig (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target))) (if (not (hash-table-ref/default runconfig (args:get-arg "-reqtarg") #f)) (begin (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf) (if db (sqlite3:finalize! db)) (exit 1))) ;; Now have runconfigs data loaded, set environment vars (for-each (lambda (section) (for-each (lambda (varval) (set! envdat (append envdat (list varval))) (safe-setenv (car varval)(cadr varval))) (configf:get-section runconfig section))) (list "default" target)) (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id))) (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)) (let* ((target (or (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) (link-tree (configf:lookup *configdat* "setup" "linktree"))) ;; get the info from the db and put it in the cache (if link-tree (setenv "MT_LINKTREE" link-tree) (debug:print 0 "ERROR: linktree not set, should be set in megatest.config in [setup] section.")) (if (not vals) (let ((ht (make-hash-table))) (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (for-each (lambda (key) (hash-table-set! vals (car key) (cadr key))) keyvals))) ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) (debug:print 2 "setenv " key " " val) (safe-setenv key val))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname (setenv "MT_RUNNAME" runname) (debug:print 0 "ERROR: no value for runname for id " run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*))) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) ;; Every time can-run-more-tests is called increment the delay ;; ;; NOTE: We run this server-side!! Do not use this global except in the runs:can-run-more-tests routine ;; (define *last-num-running-tests* 0) (define *runs:can-run-more-tests-count* 0) (define (runs:shrink-can-run-more-tests-count) (set! *runs:can-run-more-tests-count* 0)) ;; (/ *runs:can-run-more-tests-count* 2))) ;; Temporary globals. Move these into the logic or into common ;; (define *seen-cant-run-tests* (make-hash-table)) ;; use to track tests that we suspect cannot be run (define (runs:inc-cant-run-tests testname) (hash-table-set! *seen-cant-run-tests* testname (+ (hash-table-ref/default *seen-cant-run-tests* testname 0) 1))) (define (runs:can-keep-running? testname n) (< (hash-table-ref/default *seen-cant-run-tests* testname 0) n)) (define *runs:denoise* (make-hash-table)) ;; key => last-time-ran (define (runs:lownoise key waitval) (let ((lasttime (hash-table-ref/default *runs:denoise* key 0)) (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) (define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;;(thread-sleep! (cond ;; ((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while ;; (else 0))) (let* ((num-running (rmt:get-count-tests-running run-id)) (num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)) (job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup))) (if (string? jobg-count) (string->number jobg-count) jobg-count)))) (if (> (+ num-running num-running-in-jobgroup) 0) (set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1))) (if (not (eq? *last-num-running-tests* num-running)) |
︙ | ︙ | |||
195 196 197 198 199 200 201 202 203 204 205 206 207 | (>= num-running-in-jobgroup job-group-limit)) (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; (define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; test-names | > < | | > > > | > > > > | | > > > > > | 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 | (>= num-running-in-jobgroup job-group-limit)) (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; (define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; test-names (let* ((keys (keys:config-get-fields *configdat*)) (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; (tests:filter-test-names all-test-names test-patts)) (required-tests #f) ;;(lset-intersection equal? (string-split test-patts ",") test-names))) ;; test-names)) ;; Added test-names as initial for required-tests but that failed to work (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) (tdbdat (tasks:open-db))) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (set-signal-handler! signal/int (lambda (signum) (signal-mask! signum) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((tdbdat (tasks:open-db))) (tasks:set-state-given-param-key (db:delay-if-busy tdbdat) task-key "killed")) (print "Killed by signal " signum ". Exiting") (exit))) ;; register this run in monitor.db (tasks:add (db:delay-if-busy tdbdat) "run-tests" user target runname test-patts task-key) ;; params) (tasks:set-state-given-param-key (db:delay-if-busy tdbdat) task-key "running") (runs:set-megatest-env-vars run-id inkeys: keys inrunname: runname) ;; these may be needed by the launching process (if (file-exists? runconfigf) (setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target) (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) ;; Now generate all the tests lists (set! all-tests-registry (tests:get-all)) |
︙ | ︙ | |||
241 242 243 244 245 246 247 248 249 250 251 | (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) (begin ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. | > > > > | | > > > > > | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 | (debug:print-info 0 "all tests: " (string-intersperse (sort all-test-names string<) " ")) (debug:print-info 0 "test names: " (string-intersperse (sort test-names string<) " ")) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified (if (eq? *passnum* 0) (begin ;; Is this still necessary? I think not. Unreachable tests are marked as such and ;; should not cause problems here. ;; ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. ;; ;; (rmt:general-call 'delete-tests-in-state run-id "NOT_STARTED") ;; Now convert FAIL and anything in allow-auto-rerun to NOT_STARTED ;; (for-each (lambda (state) (rmt:set-tests-state-status run-id test-names state #f "NOT_STARTED" state)) (string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") ""))))) ;; Ensure all tests are registered in the test_meta table (runs:update-all-test_meta #f) ;; now add non-directly referenced dependencies (i.e. waiton) ;;====================================================================== ;; refactoring this block into tests:get-full-data |
︙ | ︙ | |||
346 347 348 349 350 351 352 | (if (not (null? required-tests)) (debug:print-info 1 "Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) | | > | > > > > > > > > > > > > > > > > | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 | (if (not (null? required-tests)) (debug:print-info 1 "Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) (let* ((keep-going #t) (th1 (make-thread (lambda () (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)) "runs:run-tests-queue")) (th2 (make-thread (lambda () ;; (rmt:find-and-mark-incomplete-all-runs))))) CAN'T INTERRUPT IT ... (let ((run-ids (rmt:get-all-run-ids))) (for-each (lambda (run-id) (if keep-going (rmt:find-and-mark-incomplete run-id #f))) ;; ovr-deadtime))) run-ids))) "runs: mark-incompletes"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) (set! keep-going #f) (thread-join! th2) ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD (if (> run-count 0) (begin (if (not (hash-table-ref/default flags "-preclean" #f)) (hash-table-set! flags "-preclean" #t)) (if (not (hash-table-ref/default flags "-rerun" #f)) (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS")) (runs:run-tests target runname test-patts user flags run-count: (- run-count 1))))) (debug:print-info 0 "No tests to run"))) (debug:print-info 4 "All done by here") (tasks:set-state-given-param-key (db:delay-if-busy tdbdat) task-key "done") ;; (sqlite3:finalize! tasks-db) )) ;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable. ;; ;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns ;; If reg is full (i.e. length >= n |
︙ | ︙ | |||
404 405 406 407 408 409 410 | '() reg))) (define runs:nothing-left-in-queue-count 0) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap) (let* ((loop-list (list hed tal reg reruns)) | > | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 | '() reg))) (define runs:nothing-left-in-queue-count 0) (define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap) (let* ((loop-list (list hed tal reg reruns)) (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap)) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (runnables (runs:calc-runnable prereqs-not-met))) (debug:print-info 4 "START OF INNER COND #2 " "\n can-run-more: " can-run-more "\n testname: " hed |
︙ | ︙ | |||
462 463 464 465 466 467 468 | (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (if (null? items-list) | | | | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 | (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) (runs:set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (if (null? items-list) (let ((test-id (rmt:get-test-id run-id test-name ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "ZERO_ITEMS" "Failed to run due to failed prerequisites")))) (tests:testqueue-set-items! test-record items-list) (list hed tal reg reruns)) (begin (debug:print 0 "ERROR: The proc from reading the items table did not yield a list - please report this") (exit 1)))))) ((and (null? fails) |
︙ | ︙ | |||
500 501 502 503 504 505 506 | (if (and give-up (not (and (null? tal)(null? reg)))) (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue") | | | | > > | | | > | | | | 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 | (if (and give-up (not (and (null? tal)(null? reg)))) (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to discarded prerequisites"))) (if (and (null? trimmed-tal) (null? trimmed-reg)) #f (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull) (runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull) (runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull) reruns))) (list (car newtal)(append (cdr newtal) reg) '() reruns)))) ((and (null? fails) (null? prereq-fails) (null? non-completed)) (if (runs:can-keep-running? hed 20) (begin (runs:inc-cant-run-tests hed) (debug:print-info 1 "no fails in prerequisites for " hed " but also none running, keeping " hed " for now. Try count: " (hash-table-ref/default *seen-cant-run-tests* hed 0)) ;; getting here likely means the system is way overloaded, kill a full minute before continuing (thread-sleep! 60) ;; num-retries code was here ;; we use this opportunity to move contents of reg to tal (list (car newtal)(append (cdr newtal) reg) '() reruns)) ;; an issue with prereqs not yet met? (begin (debug:print-info 1 "no fails in prerequisites for " hed " but nothing seen running in a while, dropping test " hed " from the run queue") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "TIMED_OUT" "Nothing seen running in a while."))) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) reruns)))) ((and (or (not (null? fails)) (not (null? prereq-fails))) (member 'normal testmode)) (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") ", removing it from to-do list") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (if (not (null? prereq-fails)) (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_DISCARDED" "Failed to run due to prior failed prerequisites") (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))) (if (or (not (null? reg))(not (null? tal))) (begin (hash-table-set! test-registry hed 'CANNOTRUN) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) (runs:queue-next-reg tal reg reglen regfull) (cons hed reruns))) |
︙ | ︙ | |||
582 583 584 585 586 587 588 | ((string? t) t) (else (conc t)))) inlst))) (define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap) | | > | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 | ((string? t) t) (else (conc t)))) inlst))) (define (runs:process-expanded-tests hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmap) (let* ((run-limits-info (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap)) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (loop-list (list hed tal reg reruns)) ;; configure the load runner (numcpus (common:get-num-cpus)) (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3"))) (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60")))) |
︙ | ︙ | |||
631 632 633 634 635 636 637 | reruns) #f)) ;; Register tests ;; ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) | | | > > | | < > | | < < | > | | < | < < < | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 | reruns) #f)) ;; Register tests ;; ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f)) (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" ) ;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs (let register-loop ((numtries 15)) (rmt:general-call 'register-test run-id run-id test-name item-path) (thread-sleep! 0.5) (if (rmt:get-test-id run-id test-name item-path) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'done) (if (> numtries 0) (register-loop (- numtries 1)) (debug:print 0 "ERROR: failed to register test " (runs:make-full-test-name test-name item-path))))) (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done)) (begin (rmt:general-call 'register-test run-id run-id test-name "") (if (rmt:get-test-id run-id test-name "") (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done)))) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) (if (and (null? tal)(null? reg)) (list hed tal (append reg (list hed)) reruns) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) ;; NB// Here we are building reg as we register tests ;; if regfull we must pop the front item off reg |
︙ | ︙ | |||
734 735 736 737 738 739 740 | (list (car newtal)(cdr newtal) reg reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (if (or (not (null? reg))(not (null? tal))) (if (vector? hed) (begin (debug:print 1 "WARNING: Dropping test " test-name "/" item-path " from the launch list as it has prerequistes that are FAIL") | | | | 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 | (list (car newtal)(cdr newtal) reg reruns)) ;; the waiton is FAIL so no point in trying to run hed ever again (if (or (not (null? reg))(not (null? tal))) (if (vector? hed) (begin (debug:print 1 "WARNING: Dropping test " test-name "/" item-path " from the launch list as it has prerequistes that are FAIL") (let ((test-id (rmt:get-test-id run-id hed ""))) (if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites"))) (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) ;; (thread-sleep! *global-delta*) ;; This next is for the items (mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f) (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed) (list (runs:queue-next-hed tal reg reglen regfull) (runs:queue-next-tal tal reg reglen regfull) |
︙ | ︙ | |||
839 840 841 842 843 844 845 | ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue ;; ;; (cdb:remote-run db:find-and-mark-incomplete #f) | | | > | 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 | ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue ;; ;; (cdb:remote-run db:find-and-mark-incomplete #f) (let ((run-info (rmt:get-run-info run-id)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) (registry-mutex (make-mutex)) (num-retries 0) (max-retries (config-lookup *configdat* "setup" "maxretries")) (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) (if (and mcj (string->number mcj)) (string->number mcj) 1))) ;; length of the register queue ahead (reglen (if (number? reglen-in) reglen-in 1)) (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle (last-time-some-running (current-seconds)) (tdbdat (tasks:open-db))) ;; Initialize the test-registery hash with tests that already have a record ;; convert state to symbol and use that as the hash value (for-each (lambda (trec) (let ((id (db:test-get-id trec)) (tn (db:test-get-testname trec)) (ip (db:test-get-item-path trec)) |
︙ | ︙ | |||
874 875 876 877 878 879 880 881 882 883 | (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes (if (> (current-seconds)(+ last-time-incomplete 900)) (begin (set! last-time-incomplete (current-seconds)) | > > | > | > > > > > | | | 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 | (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes ;; moving this to a parallel thread and just run it once. ;; (if (> (current-seconds)(+ last-time-incomplete 900)) (begin (set! last-time-incomplete (current-seconds)) ;; (rmt:find-and-mark-incomplete-all-runs) )) ;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns) (let* ((test-record (hash-table-ref test-records hed)) (test-name (tests:testqueue-get-testname test-record)) (tconfig (tests:testqueue-get-testconfig test-record)) (jobgroup (config-lookup tconfig "test_meta" "jobgroup")) (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) (if m (map string->symbol (string-split m)) '(normal)))) (itemmap (configf:lookup tconfig "requirements" "itemmap")) (waitons (tests:testqueue-get-waitons test-record)) (priority (tests:testqueue-get-priority test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) (tfullname (runs:make-full-test-name test-name item-path)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) (num-running (rmt:get-count-tests-running-for-run-id run-id))) ;; every couple minutes verify the server is there for this run (if (and (common:low-noise-print 60 "try start server" run-id) (tasks:need-server run-id)) (tasks:start-and-wait-for-server tdbdat run-id 10)) (if (> num-running 0) (set! last-time-some-running (current-seconds))) (if (> (current-seconds)(+ last-time-some-running 240)) (hash-table-set! *max-tries-hash* tfullname (+ (hash-table-ref/default *max-tries-hash* tfullname 0) 1))) ;; (debug:print 0 "max-tries-hash: " (hash-table->alist *max-tries-hash*)) ;; Ensure all top level tests get registered. This way they show up as "NOT_STARTED" on the dashboard ;; and it is clear they *should* have run but did not. (if (not (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f)) (begin (rmt:general-call 'register-test run-id run-id test-name "") (hash-table-set! test-registry (runs:make-full-test-name test-name "") 'done))) ;; Fast skip of tests that are already "COMPLETED" - NO! Cannot do that as the items may not have been expanded yet :( ;; (if (member (hash-table-ref/default test-registry tfullname #f) '(DONOTRUN removed)) ;; *common:cant-run-states-sym*) ;; '(COMPLETED KILLED WAIVED UNKNOWN INCOMPLETE)) (begin |
︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 | #f (loop (car tal)(cdr tal) reg reruns))) ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) | | | 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 | #f (loop (car tal)(cdr tal) reg reruns))) ;; if items is a proc then need to run items:get-items-from-config, get the list and loop ;; - but only do that if resources exist to kick off the job ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) (let ((can-run-more (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records itemmap))) (if loop-list (apply loop loop-list))) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns)))) |
︙ | ︙ | |||
1058 1059 1060 1061 1062 1063 1064 | ((not (null? reg)) ;; could we get here with leftovers? (debug:print-info 0 "Have leftovers!") (loop (car reg)(cdr reg) '() reruns)) (else (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) ))) ;; now *if* -run-wait we wait for all tests to be done | < < < < < | | | | > | 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 | ((not (null? reg)) ;; could we get here with leftovers? (debug:print-info 0 "Have leftovers!") (loop (car reg)(cdr reg) '() reruns)) (else (debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns)) ))) ;; now *if* -run-wait we wait for all tests to be done ;; Now wait for any RUNNING tests to complete (if in run-wait mode) (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id)) (prev-num-running 0)) ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running) (if (and (or (args:get-arg "-run-wait") (equal? (configf:lookup *configdat* "setup" "run-wait") "yes")) (> num-running 0)) (begin ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes ;; (debug:print 0 "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0)) (if (> (current-seconds)(+ last-time-incomplete 900)) (begin (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name)) (set! last-time-incomplete (current-seconds)) (rmt:find-and-mark-incomplete run-id #f))) (if (not (eq? num-running prev-num-running)) (debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds))))) (thread-sleep! 5) ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running)))) ;; LET* ((test-record ;; we get here on "drop through". All done! (debug:print-info 1 "All tests launched"))) (define (runs:calc-fails prereqs-not-met) (filter (lambda (test) (and (vector? test) ;; not (string? test)) |
︙ | ︙ | |||
1181 1182 1183 1184 1185 1186 1187 | (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) | | | | | | | | 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 | (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) (begin (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (test-id (rmt:get-test-id run-id test-name item-path)) (testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f))) (if (not testdat) (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) (rmt:general-call 'register-test run-id run-id test-name item-path) (set! test-id (rmt:get-test-id run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") (set! testdat (rmt:get-test-info-by-id run-id test-id)) (if (not testdat) (begin (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") (thread-sleep! 1) (loop))))) (if (not testdat) ;; should NOT happen (debug:print 0 "ERROR: failed to get test record for test-id " test-id)) |
︙ | ︙ | |||
1271 1272 1273 1274 1275 1276 1277 | (let ((skip-test #f) (skip-check (configf:get-section test-conf "skip"))) (cond ;; Have to check for skip conditions. This one skips if there are same-named tests ;; currently running ((and skip-check (configf:lookup test-conf "skip" "prevrunning")) | > | | > | | | | | | > | | | 1314 1315 1316 1317 1318 1319 1320 1321 1322 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 | (let ((skip-test #f) (skip-check (configf:get-section test-conf "skip"))) (cond ;; Have to check for skip conditions. This one skips if there are same-named tests ;; currently running ((and skip-check (configf:lookup test-conf "skip" "prevrunning")) ;; run-ids = #f means *all* runs (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) (if (not (null? running-tests)) ;; have to skip (set! skip-test "Skipping due to previous tests running")))) ((and skip-check (configf:lookup test-conf "skip" "fileexists")) (if (file-exists? (configf:lookup test-conf "skip" "fileexists")) (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))) (if skip-test (begin (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) (debug:print-info 1 "SKIPPING Test " full-test-name " due to " skip-test)) (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") (set! *globalexitstatus* 1) ;; (process-signal (current-process-id) signal/kill)))))))) ((KILLED) (debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) ;; KILLED)) ((LAUNCHED REMOTEHOSTSTART RUNNING) (debug:print 2 "NOTE: " test-name " is already running")) ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; (or incomplete-timeout ;; 6000)) ;; i.e. no update for more than 6000 seconds ;; (begin ;; (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) ;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) ;; (debug:print 2 "NOTE: " test-name " is already running"))) (else (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) (case (string->symbol (test:get-state testdat)) ((COMPLETED INCOMPLETE) (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) (else (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)))))))) |
︙ | ︙ | |||
1356 1357 1358 1359 1360 1361 1362 | ;; 'set-state-status ;; ;; NB// should pass in keys? ;; (define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(remove-data-only #f)) (common:clear-caches) ;; clear all caches (let* ((db #f) | > | | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 | ;; 'set-state-status ;; ;; NB// should pass in keys? ;; (define (runs:operate-on action target runnamepatt testpatt #!key (state #f)(status #f)(new-state-status #f)(remove-data-only #f)) (common:clear-caches) ;; clear all caches (let* ((db #f) (tdbdat (tasks:open-db)) (keys (rmt:get-keys)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) (header (vector-ref rundat 0)) (runs (vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))) (debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) |
︙ | ︙ | |||
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 | testpatt states statuses not-in: #f sort-by: (case action ((remove-runs) 'rundir) (else 'event_time)))))) (let* ((run-id (db:get-value-by-header run header "id")) (run-state (db:get-value-by-header run header "state")) (tests (if (not (equal? run-state "locked")) (proc-get-tests run-id) '())) (lasttpath "/does/not/exist/I/hope")) (debug:print-info 4 "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action ((remove-runs) (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) (else (debug:print-info 0 "action not recognised " action))) | > > > > > > > | > > | | > > > | | 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 | testpatt states statuses not-in: #f sort-by: (case action ((remove-runs) 'rundir) (else 'event_time)))))) (let* ((run-id (db:get-value-by-header run header "id")) (run-state (db:get-value-by-header run header "state")) (run-name (db:get-value-by-header run header "runname")) (tests (if (not (equal? run-state "locked")) (proc-get-tests run-id) '())) (lasttpath "/does/not/exist/I/hope")) (debug:print-info 4 "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action ((remove-runs) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here (if (equal? testpatt "%") (tasks:kill-runner (db:delay-if-busy tdbdat) target run-name) (debug:print 0 "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 1 "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((print-run) (debug:print 1 "Printing info for run " runkey ", run=" run ", tests=" tests ", header=" header) action) ((run-wait) (debug:print 1 "Waiting for run " runkey ", run=" runnamepatt " to complete")) (else (debug:print-info 0 "action not recognised " action))) (let ((sorted-tests (sort tests (lambda (a b)(let ((dira ;; (rmt:sdb-qry 'getstr (db:test-get-rundir a)) ;; ) ;; (filedb:get-path *fdb* (db:test-get-rundir a))) (dirb ;; (rmt:sdb-qry 'getstr (db:test-get-rundir b))) ;; ) ;; ((filedb:get-path *fdb* (db:test-get-rundir b)))) (if (and (string? dira)(string? dirb)) (> (string-length dira)(string-length dirb)) #f))))) (toplevel-retries (make-hash-table)) ;; try three times to loop through and remove top level tests (test-retry-time (make-hash-table)) (allow-run-time 10)) ;; seconds to allow for killing tests before just brutally killing 'em (let loop ((test (car sorted-tests)) (tal (cdr sorted-tests))) (let* ((test-id (db:test-get-id test)) (new-test-dat (rmt:get-test-info-by-id run-id test-id))) (if (not new-test-dat) (begin (debug:print 0 "ERROR: We have a test-id of " test-id " but no record was found. NOTE: No locking of records is done between processes, do not simultaneously remove the same run from two processes!") (if (not (null? tal)) (loop (car tal)(cdr tal)))) (let* ((item-path (db:test-get-item-path new-test-dat)) (test-name (db:test-get-testname new-test-dat)) (run-dir ;;(filedb:get-path *fdb* ;; (rmt:sdb-qry 'getid (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree (test-state (db:test-get-state new-test-dat)) (test-fulln (db:test-get-fullname new-test-dat)) (uname (db:test-get-uname new-test-dat)) (toplevel-with-children (and (db:test-get-is-toplevel test) (> (rmt:test-toplevel-num-items run-id test-name) 0)))) (case action ((remove-runs) ;; if the test is a toplevel-with-children issue an error and do not remove (if toplevel-with-children (begin (debug:print 0 "WARNING: skipping removal of " test-fulln " with run-id " run-id " as it has sub tests") (hash-table-set! toplevel-retries test-fulln (+ (hash-table-ref/default toplevel-retries test-fulln 0) 1)) |
︙ | ︙ | |||
1451 1452 1453 1454 1455 1456 1457 | (hash-table-set! test-retry-time test-fulln (current-seconds)))) (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give ;; up and blow it away. (begin (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") | | | | | < < | | | > > | | > | 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 | (hash-table-set! test-retry-time test-fulln (current-seconds)))) (if (> (- (current-seconds)(hash-table-ref test-retry-time test-fulln)) allow-run-time) ;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first ;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give ;; up and blow it away. (begin (debug:print 0 "WARNING: could not gracefully remove test " test-fulln ", tried to kill it to no avail. Forcing state to FAILEDKILL and continuing") (mt:test-set-state-status-by-id run-id (db:test-get-id test) "FAILEDKILL" "n/a" #f) (thread-sleep! 1)) (begin (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) (thread-sleep! 1))) ;; NOTE: This is suboptimal as the testdata will be used later and the state/status may have changed ... (if (null? tal) (loop new-test-dat tal) (loop (car tal)(append tal (list new-test-dat))))) (begin (runs:remove-test-directory db new-test-dat remove-data-only) (if (not (null? tal)) (loop (car tal)(cdr tal)))))))) ((set-state-status) (debug:print-info 2 "new state " (car state-status) ", new status " (cadr state-status)) (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ((run-wait) (debug:print-info 2 "still waiting, " (length tests) " tests still running") (thread-sleep! 10) (let ((new-tests (proc-get-tests run-id))) (if (null? new-tests) (debug:print-info 1 "Run completed according to zero tests matching provided criteria.") (loop (car new-tests)(cdr new-tests)))))))) ))))) ;; remove the run if zero tests remain (if (eq? action 'remove-runs) (let ((remtests (mt:get-tests-for-run (db:get-value-by-header run header "id") #f '("DELETED") '("n/a") not-in: #t))) (if (null? remtests) ;; no more tests remaining (let* ((dparts (string-split lasttpath "/")) (runpath (conc "/" (string-intersperse (take dparts (- (length dparts) 1)) "/")))) (debug:print 1 "Removing run: " runkey " " (db:get-value-by-header run header "runname") " and related record") (rmt:delete-run run-id) (rmt:delete-old-deleted-test-records) ;; (cdb:remote-run db:set-var db "DELETED_TESTS" (current-seconds)) ;; need to figure out the path to the run dir and remove it if empty ;; (if (null? (glob (conc runpath "/*"))) ;; (begin ;; (debug:print 1 "Removing run dir " runpath) ;; (system (conc "rmdir -p " runpath)))) ))))) )) runs) ;; (sqlite3:finalize! (db:delay-if-busy tdbdat)) ) #t) (define (runs:remove-test-directory db test remove-data-only) (let* ((run-dir (db:test-get-rundir test)) ;; run dir is from the link tree (real-dir (if (file-exists? run-dir) (resolve-pathname run-dir) #f))) (if remove-data-only (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "CLEANING" "LOCKED" #f) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "REMOVING" "LOCKED" #f)) (debug:print-info 1 "Attempting to remove " (if real-dir (conc " dir " real-dir " and ") "") " link " run-dir) (if (and real-dir (> (string-length real-dir) 5) (file-exists? real-dir)) ;; bad heuristic but should prevent /tmp /home etc. (begin ;; let* ((realpath (resolve-pathname run-dir))) (debug:print-info 1 "Recursively removing " real-dir) (if (file-exists? real-dir) |
︙ | ︙ | |||
1534 1535 1536 1537 1538 1539 1540 | (if (directory? run-dir) (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") (handle-exceptions exn (debug:print 0 "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") (delete-directory run-dir))) | | > | > | | 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 | (if (directory? run-dir) (if (> (directory-fold (lambda (f x)(+ 1 x)) 0 run-dir) 0) (debug:print 0 "WARNING: refusing to remove " run-dir " as it is not empty") (handle-exceptions exn (debug:print 0 "ERROR: Failed to remove directory " run-dir ((condition-property-accessor 'exn 'message) exn) ", attempting to continue") (delete-directory run-dir))) (if (and run-dir (not (member run-dir (list "n/a" "/tmp/badname")))) (debug:print 0 "WARNING: not removing " run-dir " as it either doesn't exist or is not a symlink") (debug:print 0 "NOTE: the run dir for this test is undefined. Test may have already been deleted.")) )) ;; Only delete the records *after* removing the directory. If things fail we have a record (if remove-data-only (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "NOT_STARTED" "n/a" #f) (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))) ;;====================================================================== ;; Routines for manipulating runs ;;====================================================================== ;; Since many calls to a run require pretty much the same setup ;; this wrapper is used to reduce the replication of code |
︙ | ︙ | |||
1608 1609 1610 1611 1612 1613 1614 | (for-each (lambda (run) (let ((run-id (db:get-value-by-header run header "id"))) (if (or lock (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) | | | | | < > > > | | | | | 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 | (for-each (lambda (run) (let ((run-id (db:get-value-by-header run header "id"))) (if (or lock (and unlock (begin (print "Do you really wish to unlock run " run-id "?\n y/n: ") (equal? "y" (read-line))))) (rmt:lock/unlock-run run-id lock unlock user) (debug:print-info 0 "Skipping lock/unlock on " run-id)))) runs))) ;;====================================================================== ;; Rollup runs ;;====================================================================== ;; Update the test_meta table for this test (define (runs:update-test_meta test-name test-conf) (let ((currrecord (rmt:testmeta-get-record test-name))) (if (not currrecord) (begin (set! currrecord (make-vector 11 #f)) (rmt:testmeta-add-record test-name))) (for-each (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) (if (and val (not (equal? (vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) ;; Update test_meta for all tests (define (runs:update-all-test_meta db) (let ((test-names (tests:get-all))) ;; (tests:get-valid-tests))) (for-each (lambda (test-name) (let* ((test-conf (mt:lazy-read-test-config test-name))) (if test-conf (runs:update-test_meta test-name test-conf)))) (hash-table-keys test-names)))) ;; This could probably be refactored into one complex query ... ;; NOT PORTED - DO NOT USE YET ;; (define (runs:rollup-run keys runname user keyvals) (debug:print 4 "runs:rollup-run, keys: " keys " -runname " runname " user: " user) (let* ((db #f) ;; register run operates on the main db (new-run-id (rmt:register-run keyvals runname "new" "n/a" user)) (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) (rmt:update-run-event_time new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path))) (hash-table-set! curr-tests-hash full-name testdat))) curr-tests) ;; NOPE: Non-optimal approach. Try this instead. ;; 1. tests are received in a list, most recent first ;; 2. replace the rollup test with the new *always* (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path)) (prev-test-dat (hash-table-ref/default curr-tests-hash full-name #f)) (test-steps (rmt:get-steps-for-test (db:test-get-id testdat))) (new-test-record #f)) ;; replace these with insert ... select (apply sqlite3:execute db (conc "INSERT OR REPLACE INTO tests (run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment) " "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?);") new-run-id (cddr (vector->list testdat))) |
︙ | ︙ |
Modified sdb.scm from [3abf0b5c48] to [b5405355dd].
︙ | ︙ | |||
18 19 20 21 22 23 24 | (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit sdb)) ;; | | < < < < < | | | | | < < | | 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 | (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit sdb)) ;; (define (sdb:open fname) (let* ((dbpath (pathname-directory fname)) (dbexists (let ((fe (file-exists? fname))) (if fe fe (begin (create-directory dbpath #t) #f)))) (sdb (sqlite3:open-database fname)) (handler (make-busy-timeout 136000))) (sqlite3:set-busy-handler! sdb handler) (if (not dbexists) (sdb:initialize sdb)) (sqlite3:execute sdb "PRAGMA synchronous = 1;") sdb)) (define (sdb:initialize sdb) (sqlite3:execute sdb "CREATE TABLE IF NOT EXISTS strs (id INTEGER PRIMARY KEY, str TEXT, CONSTRAINT str UNIQUE (str));") (sqlite3:execute sdb "CREATE INDEX IF NOT EXISTS strindx ON strs (str);")) ;; (define sumup (let ((a 0))(lambda (x)(set! a (+ x a)) a))) (define (sdb:register-string sdb str) (sqlite3:execute sdb "INSERT OR IGNORE INTO strs (str) VALUES (?);" str)) (define (sdb:string->id sdb str-cache str) |
︙ | ︙ | |||
75 76 77 78 79 80 81 | (lambda (istr) (set! str istr) (hash-table-set! id-cache id str)) sdb "SELECT str FROM strs WHERE id=?;" id)) str)) | > > | < | > > > > > | > > > > | > > | 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 | (lambda (istr) (set! str istr) (hash-table-set! id-cache id str)) sdb "SELECT str FROM strs WHERE id=?;" id)) str)) ;; Numbers get passed though in both directions ;; (define (make-sdb:qry fname) (let ((sdb #f) (scache (make-hash-table)) (icache (make-hash-table))) (lambda (cmd var) (case cmd ((setup) (set! sdb (if (not sdb) (sdb:open (if var var fname))))) ((setdb) (set! sdb var)) ((getdb) sdb) ((finalize) (if sdb (begin (sqlite3:finalize! sdb) (set! sdb #f)))) ((getid) (let ((id (if (or (number? var) (string->number var)) var (sdb:string->id sdb scache var)))) (if id id (begin (sdb:register-string sdb var) (sdb:string->id sdb scache var))))) ((getstr) (if (or (number? var) (string->number var)) (sdb:id->string sdb icache var) var)) ((passid) var) ((passstr) var) (else #f))))) |
Modified server.scm from [c908dcbcbb] to [f2b9d5f3d9].
1 2 3 4 5 6 7 8 9 10 11 12 | ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) | | > | 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 | ;; Copyright 2006-2012, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils) ;; (use zmq) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses synchash)) (declare (uses http-transport)) (declare (uses launch)) ;; (declare (uses zmq-transport)) (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") (define (server:make-server-url hostport) |
︙ | ︙ | |||
40 41 42 43 44 45 46 | ;; S E R V E R ;;====================================================================== ;; Call this to start the actual server ;; ;; all routes though here end in exit ... | > > > | < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > | > > > | > > | > | > > > > > > > > > > > > > > > > > > > > > > | | > > > | > > > > > > > > | < | > | | | | | | | | | < | | < < | < | | > > | > > > > | > > > > > > | 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 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 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 193 194 195 196 197 198 199 200 | ;; S E R V E R ;;====================================================================== ;; Call this to start the actual server ;; ;; all routes though here end in exit ... ;; ;; start_server ;; (define (server:launch run-id) (http-transport:launch run-id)) ;;====================================================================== ;; Q U E U E M A N A G E M E N T ;;====================================================================== ;; We don't want to flush the queue if it was just flushed (define *server:last-write-flush* (current-milliseconds)) ;;====================================================================== ;; S E R V E R U T I L I T I E S ;;====================================================================== ;; Generate a unique signature for this server (define (server:mk-signature) (message-digest-string (md5-primitive) (with-output-to-string (lambda () (write (list (current-directory) (argv))))))) ;; When using zmq this would send the message back (two step process) ;; with spiffy or rpc this simply returns the return data to be returned ;; (define (server:reply return-addr query-sig success/fail result) (db:obj->string (vector success/fail query-sig result))) ;; Given a run id start a server process ### NOTE ### > file 2>&1 ;; if the run-id is zero and the target-host is set ;; try running on that host ;; (define (server:run run-id) (let* ((curr-host (get-host-name)) (curr-ip (server:get-best-guess-address curr-host)) (target-host (configf:lookup *configdat* "server" "homehost" )) (testsuite (common:get-testsuite-name)) (logfile (conc *toppath* "/logs/" run-id ".log")) (cmdln (conc (common:get-megatest-exe) " -server " (or target-host "-") " -run-id " run-id (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes") (conc " -daemonize -log " logfile) "") " -debug 4 testsuite:" testsuite))) ;; (conc " >> " logfile " 2>&1 &"))))) (debug:print 0 "INFO: Starting server (" cmdln ") as none running ...") (push-directory *toppath*) (if (not (directory-exists? "logs"))(create-directory "logs")) ;; host.domain.tld match host? (if (and target-host ;; look at target host, is it host.domain.tld or ip address and does it ;; match current ip or hostname (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host)) (not (equal? curr-ip target-host))) (begin (debug:print-info 0 "Starting server on " target-host ", logfile is " logfile) (setenv "TARGETHOST" target-host))) (setenv "TARGETHOST_LOGF" logfile) (system (conc "nbfake " cmdln)) (unsetenv "TARGETHOST_LOGF") (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST")) ;; (system cmdln) (pop-directory))) ;; kind start up of servers, wait 40 seconds before allowing another server for a given ;; run-id to be launched (define (server:kind-run run-id) (let ((last-run-time (hash-table-ref/default *server-kind-run* run-id #f))) (if (or (not last-run-time) (> (- (current-seconds) last-run-time) 30)) (begin (server:run run-id) (hash-table-set! *server-kind-run* run-id (current-seconds)))))) ;; The generic run a server command. Dispatches the call to server 0 if run-id != 0 ;; (define (server:try-running run-id) (if (eq? run-id 0) (server:run run-id) (rmt:start-server run-id))) (define (server:check-if-running run-id) (let ((tdbdat (tasks:open-db))) (let loop ((server (tasks:get-server (db:delay-if-busy tdbdat) run-id)) (trycount 0)) (if server ;; note: client:start will set *runremote*. this needs to be changed ;; also, client:start will login to the server, also need to change that. ;; ;; client:start returns #t if login was successful. ;; (let ((res (server:ping-server run-id (tasks:hostinfo-get-interface server) (tasks:hostinfo-get-port server)))) ;; if the server didn't respond we must remove the record (if res #t (begin (debug:print-info 0 "server at " server " not responding, removing record") (tasks:server-force-clean-running-records-for-run-id (db:delay-if-busy tdbdat) run-id " server:check-if-running") res))) #f)))) ;; called in megatest.scm, host-port is string hostname:port ;; (define (server:ping run-id host:port) (let ((tdbdat (tasks:open-db))) (let* ((host-port (let ((slst (string-split host:port ":"))) (if (eq? (length slst) 2) (list (car slst)(string->number (cadr slst))) #f))) (toppath (launch:setup-for-run)) (server-db-dat (if (not host-port)(tasks:get-server (db:delay-if-busy tdbdat) run-id) #f))) (if (not run-id) (begin (debug:print 0 "ERROR: must specify run-id when doing ping, -run-id n") (print "ERROR: No run-id") (exit 1)) (if (and (not host-port) (not server-db-dat)) (begin (print "ERROR: bad host:port") (exit 1)) (let* ((iface (if host-port (car host-port) (tasks:hostinfo-get-interface server-db-dat))) (port (if host-port (cadr host-port)(tasks:hostinfo-get-port server-db-dat))) (server-dat (http-transport:client-connect iface port)) (login-res (rmt:login-no-auto-client-setup server-dat run-id))) (if (and (list? login-res) (car login-res)) (begin (print "LOGIN_OK") (exit 0)) (begin (print "LOGIN_FAILED") (exit 1))))))))) ;; run ping in separate process, safest way in some cases ;; (define (server:ping-server run-id iface port) (with-input-from-pipe (conc (common:get-megatest-exe) " -run-id " run-id " -ping " (conc iface ":" port)) (lambda () (let loop ((inl (read-line)) (res "NOREPLY")) (if (eof-object? inl) (case (string->symbol res) ((NOREPLY) #f) ((LOGIN_OK) #t) (else #f)) (loop (read-line) inl)))))) |
Modified synchash.scm from [68c033427e] to [9881f5a738].
︙ | ︙ | |||
10 11 12 13 14 15 16 | ;;====================================================================== ;;====================================================================== ;; A hash of hashes that can be kept in sync by sending minial deltas ;;====================================================================== (use format) | | > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | ;;====================================================================== ;;====================================================================== ;; A hash of hashes that can be kept in sync by sending minial deltas ;;====================================================================== (use format) (use srfi-1 srfi-69 sqlite3) (import (prefix sqlite3 sqlite3:)) (declare (unit synchash)) (declare (uses db)) (declare (uses server)) (include "db_records.scm") (define (synchash:make) |
︙ | ︙ | |||
60 61 62 63 64 65 66 | ;; (cdb:remote-run db:get-keys #f) ;; (cdb:remote-run db:get-num-runs #f "%") ;; (cdb:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts) ;; ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; (define (synchash:client-get proc synckey keynum synchash . params) | | > | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | ;; (cdb:remote-run db:get-keys #f) ;; (cdb:remote-run db:get-num-runs #f "%") ;; (cdb:remote-run db:get-runs #f runnamepatt numruns *start-run-offset* keypatts) ;; ;; keynum => the field to use as the unique key (usually 0 but can be other field) ;; (define (synchash:client-get proc synckey keynum synchash . params) (let* ((data ;; (apply cdb:remote-run synchash:server-get #f proc synckey keynum params)) (apply synchash:server-get #f proc synckey keynum params)) (newdat (car data)) (removs (cadr data)) (myhash (hash-table-ref/default synchash synckey #f))) (if (not myhash) (begin (set! myhash (make-hash-table)) (hash-table-set! synchash synckey myhash))) |
︙ | ︙ | |||
85 86 87 88 89 90 91 | removs) ;; WHICH ONE!? ;; data)) ;; return the changed and deleted list (list newdat removs))) ;; synchash)) (define *synchashes* (make-hash-table)) | | > | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | removs) ;; WHICH ONE!? ;; data)) ;; return the changed and deleted list (list newdat removs))) ;; synchash)) (define *synchashes* (make-hash-table)) (define (synchash:server-get indb proc synckey keynum . params) ;; (debug:print-info 2 "synckey: " synckey ", keynum: " keynum ", params: " params) (let* ((db (if indb indb (db:open-megatest-db))) (synchash (hash-table-ref/default *synchashes* synckey #f)) (newdat (apply (case proc ((db:get-runs) db:get-runs) ((db:get-tests-for-runs-mindata) db:get-tests-for-runs-mindata) ((db:get-test-info-by-ids) db:get-test-info-by-ids) (else (print "ERROR: sync for hash " proc " not setup! Edits needed in synchash.scm") print)) |
︙ | ︙ | |||
112 113 114 115 116 117 118 119 120 121 122 123 124 | ;; (debug:print-info 2 "header: " header ", data: " data) (cons (list "header" header) ;; add the header keyed by the word "header" (map make-indexed data)))) ;; add each element keyed by the keynum'th val (else ;; (debug:print-info 2 "Non-get runs call") (map make-indexed newdat)))) ;; (debug:print-info 2 "postdat: " postdat) (if (not synchash) (begin (set! synchash (make-hash-table)) (hash-table-set! *synchashes* synckey synchash))) (synchash:get-delta postdat synchash))) | > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | ;; (debug:print-info 2 "header: " header ", data: " data) (cons (list "header" header) ;; add the header keyed by the word "header" (map make-indexed data)))) ;; add each element keyed by the keynum'th val (else ;; (debug:print-info 2 "Non-get runs call") (map make-indexed newdat)))) ;; (debug:print-info 2 "postdat: " postdat) ;; (if (not indb)(sqlite3:finalize! db)) (if (not synchash) (begin (set! synchash (make-hash-table)) (hash-table-set! *synchashes* synckey synchash))) (synchash:get-delta postdat synchash))) |
Modified tasks.scm from [d7fb3bbbc7] to [af4bc3dbb1].
︙ | ︙ | |||
17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | (declare (uses common)) (include "task_records.scm") ;;====================================================================== ;; Tasks db ;;====================================================================== ;; If file exists AND ;; file readable ;; ==> open it ;; If file exists AND ;; file NOT readable ;; ==> open in-mem version ;; If file NOT exists ;; ==> open in-mem version ;; | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > | > > | | | > | | | | | | | | | | | | | | | < | | > | | | | > > | | < | > > > > > > > | > > | | > | > > > > | | | < < < | < < > > > > > > > > > | | > > > > > > > | > > > | > > | | > > > | > | > | > > > > > > > | > > | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > | > > | > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | < | < < < < < < < | < | < < < < < < | < | < < < | < < > | < < < < | < < < < < < | < | < < < | < < < < < < < < | < < | < < < < | < | < | < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < | | < < | < < < > | < < < < < > | < < < < < < < | < < < < < < < < < < < < < | | | > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 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 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 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 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 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 | (declare (uses common)) (include "task_records.scm") ;;====================================================================== ;; Tasks db ;;====================================================================== ;; wait up to aprox n seconds for a journal to go away ;; (define (tasks:wait-on-journal path n #!key (remove #f)(waiting-msg #f)) (if (not (string? path)) (debug:print 0 "ERROR: Called tasks:wait-on-journal with path=" path " (not a string)") (let ((fullpath (conc path "-journal"))) (handle-exceptions exn (begin (print-call-chain (current-error-port)) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 " exn=" (condition->list exn)) (debug:print 0 "tasks:wait-on-journal failed. Continuing on, you can ignore this call-chain") #t) ;; if stuff goes wrong just allow it to move on (let loop ((journal-exists (file-exists? fullpath)) (count n)) ;; wait ten times ... (if journal-exists (begin (if (and waiting-msg (eq? (modulo n 30) 0)) (debug:print 0 waiting-msg)) (if (> count 0) (begin (thread-sleep! 1) (loop (file-exists? fullpath) (- count 1))) (begin (if remove (system (conc "rm -rf " fullpath))) #f))) #t)))))) (define (tasks:get-task-db-path) (let* ((linktree (configf:lookup *configdat* "setup" "linktree")) (dbpath (conc linktree "/.db"))) dbpath)) ;; If file exists AND ;; file readable ;; ==> open it ;; If file exists AND ;; file NOT readable ;; ==> open in-mem version ;; If file NOT exists ;; ==> open in-mem version ;; (define (tasks:open-db #!key (numretries 4)) (if *task-db* *task-db* (handle-exceptions exn (if (> numretries 0) (begin (print-call-chain (current-error-port)) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 " exn=" (condition->list exn)) (thread-sleep! 1) (tasks:open-db numretries (- numretries 1))) (begin (print-call-chain (current-error-port)) (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 " exn=" (condition->list exn)))) (let* ((dbpath (tasks:get-task-db-path)) (dbfile (conc dbpath "/monitor.db")) (avail (tasks:wait-on-journal dbpath 10)) ;; wait up to about 10 seconds for the journal to go away (exists (file-exists? dbpath)) (write-access (file-write-access? dbpath)) (mdb (cond ;; what the hek is *toppath* doing here? ((and (string? *toppath*)(file-write-access? *toppath*)) (sqlite3:open-database dbfile)) ((file-read-access? dbpath) (sqlite3:open-database dbfile)) (else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath)) (handler (make-busy-timeout 36000))) (if (and exists (not write-access)) (set! *db-write-access* write-access)) ;; only unset so other db's also can use this control (sqlite3:set-busy-handler! mdb handler) (db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;")) ;; (if (or (and (not exists) ;; (file-write-access? *toppath*)) ;; (not (file-read-access? dbpath))) ;; (begin (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY, action TEXT DEFAULT '', owner TEXT, state TEXT DEFAULT 'new', target TEXT DEFAULT '', name TEXT DEFAULT '', testpatt TEXT DEFAULT '', keylock TEXT, params TEXT, creation_time TIMESTAMP, execution_time TIMESTAMP);") (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIMARY KEY, pid INTEGER, start_time TIMESTAMP, last_update TIMESTAMP, hostname TEXT, username TEXT, CONSTRAINT monitors_constraint UNIQUE (pid,hostname));") (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS servers (id INTEGER PRIMARY KEY, pid INTEGER, interface TEXT, hostname TEXT, port INTEGER, pubport INTEGER, start_time TIMESTAMP, priority INTEGER, state TEXT, mt_version TEXT, heartbeat TIMESTAMP, transport TEXT, run_id INTEGER);") ;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));") (sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY, server_id INTEGER, pid INTEGER, hostname TEXT, cmdline TEXT, login_time TIMESTAMP, logout_time TIMESTAMP DEFAULT -1, CONSTRAINT clients_constraint UNIQUE (pid,hostname));") ;)) (sqlite3:execute mdb "DELETE FROM tasks_queue WHERE state='done' AND creation_time < ?;" (- (current-seconds)(* 24 60 60))) ;; remove older than 24 hrs (set! *task-db* (cons mdb dbpath)) *task-db*)))) ;;====================================================================== ;; Server and client management ;;====================================================================== ;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname (define (tasks:hostinfo-get-id vec) (vector-ref vec 0)) (define (tasks:hostinfo-get-interface vec) (vector-ref vec 1)) (define (tasks:hostinfo-get-port vec) (vector-ref vec 2)) (define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3)) (define (tasks:hostinfo-get-transport vec) (vector-ref vec 4)) (define (tasks:hostinfo-get-pid vec) (vector-ref vec 5)) (define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6)) (define (tasks:server-lock-slot mdb run-id) (tasks:server-clean-out-old-records-for-run-id mdb run-id " tasks:server-lock-slot") (if (< (tasks:num-in-available-state mdb run-id) 4) (begin (tasks:server-set-available mdb run-id) ;; (thread-sleep! 2) ;; Try removing this. It may not be needed. (tasks:server-am-i-the-server? mdb run-id)) #f)) ;; register that this server may come online (first to register goes though with the process) (define (tasks:server-set-available mdb run-id) (sqlite3:execute mdb "INSERT INTO servers (pid,hostname,port,pubport,start_time, priority,state,mt_version,heartbeat, interface,transport,run_id) VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?,-1,?, ?, ?);" (current-process-id) ;; pid (get-host-name) ;; hostname -1 ;; port -1 ;; pubport (random 1000) ;; priority (used a tiebreaker on get-available) "available" ;; state (common:version-signature) ;; mt_version -1 ;; interface "http" ;; transport run-id )) (define (tasks:num-in-available-state mdb run-id) (let ((res 0)) (sqlite3:for-each-row (lambda (num-in-queue) (set! res num-in-queue)) mdb "SELECT count(id) FROM servers WHERE run_id=? AND state = 'available' AND (strftime('%s','now') - start_time) < 30 ;" run-id) res)) (define (tasks:num-servers-non-zero-running mdb) (let ((res 0)) (sqlite3:for-each-row (lambda (num-running) (set! res num-running)) mdb "SELECT count(id) FROM servers WHERE run_id != 0 AND state = 'running';") res)) (define (tasks:server-clean-out-old-records-for-run-id mdb run-id tag) (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state in ('available','dbprep','shutting-down') AND (strftime('%s','now') - start_time) > 50 AND run_id=?;" (conc "defunct" tag) run-id)) (define (tasks:server-force-clean-running-records-for-run-id mdb run-id tag) (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=?;" (conc "defunct" tag) run-id)) (define (tasks:server-force-clean-run-record mdb run-id iface port tag) (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE state = 'running' AND run_id=? AND interface=? AND port=?;" (conc "defunct" tag) run-id iface port)) (define (tasks:server-delete-records-for-this-pid mdb tag) (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE hostname=? AND pid=?;" (conc "defunct" tag) (get-host-name) (current-process-id))) (define (tasks:server-delete-record mdb server-id tag) (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" (conc "defunct" tag) server-id) ;; use this opportuntity to clean out records over one month old or over 10 minutes old with port = -1 (i.e. a never used placeholder) (sqlite3:execute mdb "DELETE FROM servers WHERE state not in ('running','shutting-down','dbprep') AND (strftime('%s','now') - start_time) > 2628000;") (sqlite3:execute mdb "DELETE FROM servers WHERE state like 'defunct%' AND port=-1 AND (strftime('%s','now') - start_time) > 600;") ) (define (tasks:server-set-state! mdb server-id state) (sqlite3:execute mdb "UPDATE servers SET state=?,heartbeat=strftime('%s','now') WHERE id=?;" state server-id)) (define (tasks:server-set-interface-port mdb server-id interface port) (sqlite3:execute mdb "UPDATE servers SET interface=?,port=?,heartbeat=strftime('%s','now') WHERE id=?;" interface port server-id)) ;; Get random port not used in long time ;; (define (tasks:server-get-next-port mdb) (let* ((lownum 30000) (highnum 64000) (used-ports '()) (get-rand-port (lambda () (+ lownum (random (- highnum lownum))))) (port-param (if (and (args:get-arg "-port") (string->number (args:get-arg "-port"))) (string->number (args:get-arg "-port")) #f)) ;; (config-port (if (and (config-lookup *configdat* "server" "port") ;; (string->number (config-lookup *configdat* "server" "port"))) ;; (string->number (config-lookup *configdat* "server" "port")) ;; #f)) ) (sqlite3:for-each-row (lambda (port) (set! used-ports (cons port used-ports))) mdb "SELECT port FROM servers;") (cond ((and port-param res) (if (> res port-param) res port-param)) (port-param port-param) ;; ((and config-port res) (if (> res config-port) res config-port)) ;; (config-port config-port) (else (let loop ((port (get-rand-port)) (remtries 100)) (if (member port used-ports) (if (> remtries 0) (loop (get-rand-port)(- remtries 1)) (get-rand-port)) port)))))) (define (tasks:server-am-i-the-server? mdb run-id) (let* ((all (tasks:server-get-servers-vying-for-run-id mdb run-id)) (first (if (null? all) (begin (debug:print 0 "ERROR: no servers listed, should be at least one by now.") (sqlite3:finalize! mdb) (exit 1)) (car (db:get-rows all)))) (header (db:get-header all)) (id (db:get-value-by-header first header "id")) (hostname (db:get-value-by-header first header "hostname")) (pid (db:get-value-by-header first header "pid")) (priority (db:get-value-by-header first header "priority"))) (debug:print 0 "INFO: am-i-the-server got record " first) ;; for now a basic check. add tiebreaking by priority later (if (and (equal? hostname (get-host-name)) (equal? pid (current-process-id))) id #f))) ;; Use: (db:get-value-by-header (car (db:get-rows dat)) (db:get-header dat) "fieldname") ;; to extract info from the structure returned ;; (define (tasks:server-get-servers-vying-for-run-id mdb run-id) (let* ((header (list "id" "hostname" "pid" "interface" "port" "pubport" "state" "run_id" "priority" "start_time")) (selstr (string-intersperse header ",")) (res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (apply vector a b) res))) mdb (conc "SELECT " selstr " FROM servers WHERE run_id=? AND state in ('available','running','dbprep') ORDER BY start_time DESC;") run-id) (vector header res))) (define (tasks:get-server mdb run-id #!key (retries 10)) (let ((res #f) (best #f)) (handle-exceptions exn (begin (print-call-chain (current-error-port)) (debug:print 0 "WARNING: tasks:get-server db access error.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 " for run " run-id) (print-call-chain (current-error-port)) (if (> retries 0) (begin (debug:print 0 " trying call to tasks:get-server again in 10 seconds") (thread-sleep! 10) (tasks:get-server mdb run-id retries: (- retries 0))) (debug:print 0 "10 tries of tasks:get-server all crashed and burned. Giving up and returning \"no server found\""))) (sqlite3:for-each-row (lambda (id interface port pubport transport pid hostname) (set! res (vector id interface port pubport transport pid hostname))) mdb ;; removed: ;; strftime('%s','now')-heartbeat < 10 AND mt_version = ? "SELECT id,interface,port,pubport,transport,pid,hostname FROM servers WHERE run_id=? AND state='running' ORDER BY start_time DESC LIMIT 1;" run-id) ;; (common:version-signature) run-id) res))) (define (tasks:server-running-or-starting? mdb run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) mdb ;; NEEDS dbprep ADDED "SELECT id FROM servers WHERE run_id=? AND (state = 'running' OR (state = 'dbprep' AND (strftime('%s','now') - start_time) < 60));" run-id) res)) (define (tasks:server-running? mdb run-id) (let ((res #f)) (sqlite3:for-each-row (lambda (id) (set! res id)) mdb ;; NEEDS dbprep ADDED "SELECT id FROM servers WHERE run_id=? AND state = 'running';" run-id) res)) (define (tasks:need-server run-id) (let ((forced (configf:lookup *configdat* "server" "required")) (maxqry (cdr (rmt:get-max-query-average run-id))) (threshold (string->number (or (configf:lookup *configdat* "server" "server-query-threshold") "10")))) (cond (forced (if (common:low-noise-print 60 run-id "server required is set") (debug:print-info 0 "Server required is set, starting server.")) #t) ((> maxqry threshold) (if (common:low-noise-print 60 run-id "Max query time execeeded") (debug:print-info 0 "Max avg query time of " maxqry "ms exceeds limit of " threshold "ms, starting server.")) #t) (else #f)))) ;; try to start a server and wait for it to be available ;; (define (tasks:start-and-wait-for-server tdbdat run-id delay-max-tries) ;; ensure a server is running for this run (let loop ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id)) (delay-time 0)) (if (and (not server-dat) (< delay-time delay-max-tries)) (begin (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id) (debug:print 0 "Try starting server for run-id " run-id)) (server:kind-run run-id) (thread-sleep! (min delay-time 5)) (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1)))))) (define (tasks:get-all-servers mdb) (let ((res '())) (sqlite3:for-each-row (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 (set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) res))) mdb "SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport,run_id FROM servers WHERE state NOT LIKE 'defunct%' ORDER BY start_time DESC;") res)) ;; no elegance here ... ;; (define (tasks:kill-server hostname pid) (debug:print-info 0 "Attempting to kill server process " pid " on host " hostname) (setenv "TARGETHOST" hostname) (setenv "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) (unsetenv "TARGETHOST_LOGF") (unsetenv "TARGETHOST")) ;; look up a server by run-id and send it a kill, also delete the record for that server ;; (define (tasks:kill-server-run-id run-id #!key (tag "default")) (let* ((tdbdat (tasks:open-db)) (sdat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) (if sdat (let ((hostname (vector-ref sdat 6)) (pid (vector-ref sdat 5)) (server-id (vector-ref sdat 0))) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed") (debug:print-info 0 "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid) (tasks:kill-server hostname pid) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) ) (debug:print-info 0 "No server found for run-id " run-id ", nothing to kill")) ;; (sqlite3:finalize! tdb) )) ;;====================================================================== ;; Tasks and Task monitors ;;====================================================================== ;;====================================================================== |
︙ | ︙ | |||
345 346 347 348 349 350 351 | (set! res count)) mdb "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" (car (user-information (current-user-id)))) res)) ;; register a task | | | | | < | 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 | (set! res count)) mdb "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;" (car (user-information (current-user-id)))) res)) ;; register a task (define (tasks:add mdb action owner target runname testpatt params) (sqlite3:execute mdb "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time) VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);" action owner target runname testpatt (if params params ""))) (define (keys:key-vals-hash->target keys key-params) (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) ""))) (if (> (length keys) 1) (for-each (lambda (key) (set! tmp (conc tmp "/" (hash-table-ref/default key-params (vector-ref key 0) "")))) |
︙ | ︙ | |||
437 438 439 440 441 442 443 | (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")) | | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 | (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 (configf:lookup *configdat* "setup" "linktree") "/.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) |
︙ | ︙ | |||
535 536 537 538 539 540 541 542 543 544 545 546 547 548 | (current-process-id) (get-host-name))) (define (tasks:set-state mdb task-id state) (sqlite3:execute mdb "UPDATE tasks_queue SET state=? WHERE id=?;" state task-id)) ;;====================================================================== ;; The routines to process tasks ;;====================================================================== ;; NOTE: It might be good to add one more layer of checking to ensure ;; that no task gets run in parallel. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 | (current-process-id) (get-host-name))) (define (tasks:set-state mdb task-id state) (sqlite3:execute mdb "UPDATE tasks_queue SET state=? WHERE id=?;" state task-id)) ;;====================================================================== ;; Access using task key (stored in params; (hash-table->alist flags) hostname pid ;;====================================================================== (define (tasks:param-key->id mdb task-params) (handle-exceptions exn #f (sqlite3:first-result mdb "SELECT id FROM tasks_queue WHERE params LIKE ?;" task-params))) (define (tasks:set-state-given-param-key mdb param-key new-state) (sqlite3:execute mdb "UPDATE tasks_queue SET state=? WHERE params LIKE ?;" new-state param-key)) (define (tasks:get-records-given-param-key mdb param-key state-patt action-patt test-patt) (handle-exceptions exn '() (sqlite3:first-row mdb "SELECT id,action,owner,state,target,name,testpatt,keylock,params WHERE params LIKE ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" param-key state-patt action-patt test-patt))) ;;====================================================================== ;; Rogue items, no place to put these yet ;;====================================================================== (define (tasks:find-task-queue-records mdb target run-name test-patt state-patt action-patt) ;; (handle-exceptions ;; exn ;; '() ;; (sqlite3:first-row (let ((res '())) (sqlite3:for-each-row (lambda (a . b) (set! res (cons (cons a b) res))) mdb "SELECT id,action,owner,state,target,name,testpatt,keylock,params FROM tasks_queue WHERE target = ? AND name = ? AND state LIKE ? AND action LIKE ? AND testpatt LIKE ?;" target run-name state-patt action-patt test-patt) res)) ;; ) (define (tasks:kill-runner mdb target run-name) (let ((records (tasks:find-task-queue-records mdb target run-name "%" "running" "run-tests")) (hostpid-rx (regexp "\\s+(\\w+)\\s+(\\d+)$"))) ;; host pid is at end of param string (if (null? records) (debug:print 0 "No run launching processes found for " target " / " run-name) (debug:print 0 "Found " (length records) " run(s) to kill.")) (for-each (lambda (record) (let* ((param-key (list-ref record 8)) (match-dat (string-search hostpid-rx param-key))) (if match-dat (let ((hostname (cadr match-dat)) (pid (string->number (caddr match-dat)))) (debug:print 0 "Sending SIGINT to process " pid " on host " hostname) (if (equal? (get-host-name) hostname) (if (process:alive? pid) (begin (handle-exceptions exn (begin (debug:print 0 "Kill of process " pid " on host " hostname " failed.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) #t) (process-signal pid signal/int) (thread-sleep! 5) (if (process:alive? pid) (process-signal pid signal/kill))))) ;; (call-with-environment-variables (let ((old-targethost (getenv "TARGETHOST"))) (setenv "TARGETHOST" hostname) (setenv "TARGETHOST_LOGF" "server-kills.log") (system (conc "nbfake kill " pid)) (if old-targethost (setenv "TARGETHOST" old-targethost)) (unsetenv "TARGETHOST") (unsetenv "TARGETHOST_LOGF")))) (debug:print 0 "ERROR: no record or improper record for " target "/" run-name " in tasks_queue in monitor.db")))) records))) ;;====================================================================== ;; The routines to process tasks ;;====================================================================== ;; NOTE: It might be good to add one more layer of checking to ensure ;; that no task gets run in parallel. |
︙ | ︙ |
Added tdb.scm version [575d5c7ba8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 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 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 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 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 372 | ;;====================================================================== ;; Copyright 2006-2013, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== (require-extension (srfi 18) extras tcp) (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit tdb)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses client)) (declare (uses mt)) (declare (uses db)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") (include "run_records.scm") ;;====================================================================== ;; ;; T E S T D A T A B A S E S ;; ;;====================================================================== ;;====================================================================== ;; T E S T S P E C I F I C D B ;;====================================================================== ;; Create the sqlite db for the individual test(s) (define (open-test-db work-area) (debug:print-info 11 "open-test-db " work-area) (if (and work-area (directory? work-area) (file-read-access? work-area)) (let* ((dbpath (conc work-area "/testdat.db")) (tdb-writeable (file-write-access? dbpath)) (dbexists (file-exists? dbpath)) (handler (make-busy-timeout (if (args:get-arg "-override-timeout") (string->number (args:get-arg "-override-timeout")) 136000)))) (handle-exceptions exn (begin (print-call-chain (current-error-port)) (debug:print 2 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test" ((condition-property-accessor 'exn 'message) exn)) (set! db (sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access (set! dbexists #f)) ;; must force re-creation of tables, more tom-foolery (set! db (sqlite3:open-database dbpath))) (if *db-write-access* (sqlite3:set-busy-handler! db handler)) (if (not dbexists) (begin (db:set-sync db) ;; (sqlite3:execute db "PRAGMA synchronous = FULL;") (debug:print-info 11 "Initialized test database " dbpath) (tdb:testdb-initialize db))) ;; (sqlite3:execute db "PRAGMA synchronous = 0;") (debug:print-info 11 "open-test-db END (sucessful)" work-area) ;; now let's test that everything is correct (handle-exceptions exn (begin (print-call-chain (current-error-port)) (debug:print 0 "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test or remove the file " dbpath ".\n " ((condition-property-accessor 'exn 'message) exn)) #f) ;; Is there a cheaper single line operation that will check for existance of a table ;; and raise an exception ? (sqlite3:execute db "SELECT id FROM test_data LIMIT 1;")) db) (let ((baddb (sqlite3:open-database ":memory:"))) (debug:print-info 11 "open-test-db END (unsucessful)" work-area) ;; provide an in-mem db (this is dangerous!) (tdb:testdb-initialize baddb) baddb))) ;; find and open the testdat.db file for an existing test (define (tdb:open-test-db-by-test-id test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area (rmt:test-get-rundir-from-test-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test (define (tdb:open-test-db-by-test-id-local dbstruct run-id test-id #!key (work-area #f)) (let* ((test-path (if work-area work-area (db:test-get-rundir-from-test-id dbstruct run-id test-id)))) (debug:print 3 "TEST PATH: " test-path) (open-test-db test-path))) ;; find and open the testdat.db file for an existing test (define (tdb:open-run-close-db-by-test-id-local dbstruct run-id test-id work-area proc . params) (let* ((test-path (if work-area work-area (db:test-get-rundir-from-test-id dbstruct run-id test-id))) (tdb (open-test-db test-path))) (apply proc tdb params))) (define (tdb:testdb-initialize db) (debug:print 11 "db:testdb-initialize START") (sqlite3:with-transaction db (lambda () (for-each (lambda (sqlcmd) (sqlite3:execute db sqlcmd)) (list "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);" "CREATE TABLE IF NOT EXISTS test_data ( id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, tol REAL, units TEXT, comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));" "CREATE TABLE IF NOT EXISTS test_steps ( id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));" ;; test_meta can be used for handing commands to the test ;; e.g. KILLREQ ;; the ackstate is set to 1 once the command has been completed "CREATE TABLE IF NOT EXISTS test_meta ( id INTEGER PRIMARY KEY, var TEXT, val TEXT, ackstate INTEGER DEFAULT 0, CONSTRAINT metadat_constraint UNIQUE (var));")))) (debug:print 11 "db:testdb-initialize END")) (define (tdb:read-test-data tdb test-id categorypatt) (let ((res '())) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) tdb "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (sqlite3:finalize! tdb) (reverse res))) ;;====================================================================== ;; T E S T D A T A ;;====================================================================== ;; ;; get a list of test_data records matching categorypatt ;; (define (tdb:read-test-data test-id categorypatt #!key (work-area #f)) ;; (let ((tdb (tdb:open-test-db-by-test-id test-id work-area: work-area))) ;; (if (sqlite3:database? tdb) ;; (let ((res '())) ;; (sqlite3:for-each-row ;; (lambda (id test_id category variable value expected tol units comment status type) ;; (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) ;; tdb ;; "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) ;; (sqlite3:finalize! tdb) ;; (reverse res)) ;; '()))) ;; NOTE: Run this local with #f for db !!! (define (tdb:load-test-data run-id test-id) (let loop ((lin (read-line))) (if (not (eof-object? lin)) (begin (debug:print 4 lin) (rmt:csv->test-data run-id test-id lin) (loop (read-line))))) ;; roll up the current results. ;; FIXME: Add the status too (rmt:test-data-rollup run-id test-id #f)) (define (tdb:get-prev-tol-for-test tdb test-id category variable) ;; Finish me? (values #f #f #f)) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (tdb:step-get-time-as-string vec) (seconds->time-string (tdb:step-get-event_time vec))) ;; get a pretty table to summarize steps ;; (define (tdb:get-steps-table steps);; 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)) ;; Move this to steps.scm ;; ;; get a pretty table to summarize steps ;; (define (tdb:get-steps-table-list steps) ;; 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 (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)) ;; ;; Move to steps.scm ;; (define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table (map (lambda (x) ;; take advantage of the \n on time->string (vector (vector-ref x 0) (let ((s (vector-ref x 1))) (if (number? s)(seconds->time-string s) s)) (let ((s (vector-ref x 2))) (if (number? s)(seconds->time-string s) s)) (vector-ref x 3) ;; status (vector-ref x 4) (vector-ref x 5))) ;; time delta (sort (hash-table-values comprsteps) (lambda (a b) (let ((time-a (vector-ref a 1)) (time-b (vector-ref b 1))) (if (and (number? time-a)(number? time-b)) (if (< time-a time-b) #t (if (eq? time-a time-b) (string<? (conc (vector-ref a 2)) (conc (vector-ref b 2))) #f)) (string<? (conc time-a)(conc time-b)))))))) ;; (define (tdb:remote-update-testdat-meta-info run-id test-id work-area cpuload diskfree minutes) (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) (if (sqlite3:database? tdb) (begin (sqlite3:execute tdb "INSERT INTO test_rundat (update_time,cpuload,diskfree,run_duration) VALUES (strftime('%s','now'),?,?,?);" cpuload diskfree minutes) (sqlite3:finalize! tdb)) (debug:print 2 "Can't update testdat.db for test " test-id " read-only or non-existant")))) |
Modified tests.scm from [cf71f12de1] to [2a580a2e0e].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") | > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) (declare (unit tests)) (declare (uses lock-queue)) (declare (uses db)) (declare (uses tdb)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) ;; (declare (uses sdb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "test_records.scm") |
︙ | ︙ | |||
124 125 126 127 128 129 130 | (qry (conc "(" test-qry " AND " item-qry ")"))) ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt) (if (null? tal) (string-intersperse (append (reverse res)(list qry)) " OR ") (loop (car tal)(cdr tal)(cons qry res))))))) #f)) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | > | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | (qry (conc "(" test-qry " AND " item-qry ")"))) ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt) (if (null? tal) (string-intersperse (append (reverse res)(list qry)) " OR ") (loop (car tal)(cdr tal)(cons qry res))))))) #f)) ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) (testconfig (tests:get-testconfig (db:test-get-testname testdat) test-registry #f)) (test-rundir ;; (sdb:qry 'passstr (db:test-get-rundir testdat)) ;; ) (prev-rundir ;; (sdb:qry 'passstr (db:test-get-rundir prev-testdat)) ;; ) (waivers (configf:section-vars testconfig "waivers")) (waiver-rx (regexp "^(\\S+)\\s+(.*)$")) (diff-rule "diff %file1% %file2%") (logpro-rule "diff %file1% %file2% | logpro %waivername%.logpro %waivername%.html")) (if (not (file-exists? test-rundir)) (begin (debug:print 0 "ERROR: test run directory is gone, cannot propagate waiver") |
︙ | ︙ | |||
275 276 277 278 279 280 281 | (if (null? tal) #t (loop (car tal)(cdr tal))) #f)))))) (pop-directory) result))))) | | | | | < < | | < | | | 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 223 | (if (null? tal) #t (loop (car tal)(cdr tal))) #f)))))) (pop-directory) result))))) (define (tests:test-force-state-status! run-id test-id state status) (rmt:test-set-status-state run-id test-id status state #f) (mt:process-triggers run-id test-id state status)) ;; Do not rpc this one, do the underlying calls!!! (define (tests:test-set-status! run-id test-id state status comment dat #!key (work-area #f)) (let* ((real-status status) (otherdat (if dat dat (make-hash-table))) (testdat (rmt:get-test-info-by-id run-id test-id)) (test-name (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) ;; before proceeding we must find out if the previous test (where all keys matched except runname) ;; was WAIVED if this test is FAIL ;; NOTES: ;; 1. Is the call to test:get-previous-run-record remotified? ;; 2. Add test for testconfig waiver propagation control here ;; (prev-test (if (equal? status "FAIL") (rmt:get-previous-test-run-record run-id test-name item-path) #f)) (waived (if prev-test (if prev-test ;; true if we found a previous test in this run series (let ((prev-status (db:test-get-status prev-test)) (prev-state (db:test-get-state prev-test)) (prev-comment (db:test-get-comment prev-test))) (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment) |
︙ | ︙ | |||
322 323 324 325 326 327 328 | (set! real-status "WAIVED")) (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) (begin | | | | | 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 | (set! real-status "WAIVED")) (debug:print 4 "real-status " real-status ", waived " waived ", status " status) ;; update the primary record IF state AND status are defined (if (and state status) (begin (rmt:test-set-status-state run-id test-id real-status state (if waived waived comment)) (mt:process-triggers run-id test-id state real-status))) ;; if status is "AUTO" then call rollup (note, this one modifies data in test ;; run area, it does remote calls under the hood. (if (and test-id state status (equal? status "AUTO")) (rmt:test-data-rollup run-id test-id status)) ;; add metadata (need to do this way to avoid SQL injection issues) ;; :first_err ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f))) ;; (if val ;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path))) |
︙ | ︙ | |||
362 363 364 365 366 367 368 | variable "," value "," expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) | | | | < < | | | | | | < | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 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 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 | variable "," value "," expected "," tol "," units "," dcomment ",," ;; extra comma for status type ))) ;; This was run remote, don't think that makes sense. Perhaps not, but that is the easiest path for the moment. (rmt:csv->test-data run-id test-id dat)))) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) (rmt:roll-up-pass-fail-counts run-id test-name item-path status)) (if (or (and (string? comment) (string-match (regexp "\\S+") comment)) waived) (let ((cmt (if waived waived comment))) (rmt:general-call 'set-test-comment run-id cmt test-id))))) (define (tests:test-set-toplog! run-id test-name logf) (rmt:general-call 'tests:test-set-toplog run-id logf run-id test-name)) (define (tests:summarize-items run-id test-id test-name force) ;; if not force then only update the record if one of these is true: ;; 1. logf is "log/final.log ;; 2. logf is same as outputfilename (let* ((outputfilename (conc "megatest-rollup-" test-name ".html")) (orig-dir (current-directory)) (logf-info (rmt:test-get-logfile-info run-id test-name)) (logf (if logf-info (cadr logf-info) #f)) (path (if logf-info (car logf-info) #f))) ;; This query finds the path and changes the directory to it for the test (if (and (string? path) (directory? path)) ;; can get #f here under some wierd conditions. why, unknown ... (begin (debug:print 4 "Found path: " path) (change-directory path)) ;; (set! outputfilename (conc path "/" outputfilename))) (debug:print 0 "ERROR: summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path)) (debug:print 4 "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force) (if (or (equal? logf "logs/final.log") (equal? logf outputfilename) force) (begin (if (not (lock-queue:wait-turn outputfilename test-id)) (print "Not updating " outputfilename " as another test item has signed up for the job") (begin (print "Obtained lock for " outputfilename) (let ((oup (open-output-file outputfilename)) (counts (make-hash-table)) (statecounts (make-hash-table)) (outtxt "") (tot 0) (testdat (rmt:test-get-records-for-index-file run-id test-name))) (with-output-to-port oup (lambda () (set! outtxt (conc outtxt "<html><title>Summary: " test-name "</title><body><h2>Summary for " test-name "</h2>")) (for-each (lambda (testrecord) |
︙ | ︙ | |||
439 440 441 442 443 444 445 | "<td>" state "</td>" "<td><font color=" (common:get-color-from-status status) ">" status "</font></td>" "<td>" (if (equal? comment "") " " comment) "</td>" "</tr>")))) | > | > > > > | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 | "<td>" state "</td>" "<td><font color=" (common:get-color-from-status status) ">" status "</font></td>" "<td>" (if (equal? comment "") " " comment) "</td>" "</tr>")))) (if (list? testdat) testdat (begin (print "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name) '()))) (print "<table><tr><td valign=\"top\">") ;; Print out stats for status (set! tot 0) (print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>State stats</h2></td></tr>") (for-each (lambda (state) (set! tot (+ tot (hash-table-ref statecounts state))) (print "<tr><td>" state "</td><td>" (hash-table-ref statecounts state) "</td></tr>")) |
︙ | ︙ | |||
464 465 466 467 468 469 470 | (hash-table-keys counts)) (print "<tr><td>Total</td><td>" tot "</td></tr></table>") (print "</td></td></tr></table>") (print "<table cellspacing=\"0\" border=\"1\">" "<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>" outtxt "</table></body></html>") | | > | > > > > > > > > > > > > > > > > > > > > > > > | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 | (hash-table-keys counts)) (print "<tr><td>Total</td><td>" tot "</td></tr></table>") (print "</td></td></tr></table>") (print "<table cellspacing=\"0\" border=\"1\">" "<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>" outtxt "</table></body></html>") ;; (release-dot-lock outputfilename) )) (close-output-port oup) (lock-queue:release-lock outputfilename test-id) (change-directory orig-dir) ;; NB// tests:test-set-toplog! is remote internal... (tests:test-set-toplog! run-id test-name outputfilename) ))))))) ;; MUST BE CALLED local! ;; (define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '())) ;; BUG: Move the values derived from args to parameters and push to megatest.scm (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) (paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname))) (if fnamepatt (apply append (map (lambda (p) (if (directory-exists? p) (glob (conc p "/" fnamepatt)) '())) paths-from-db)) paths-from-db))) ;;====================================================================== ;; Gather data from test/task specifications ;;====================================================================== ;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '())) ;; (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*"))))) ;; (set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests)) |
︙ | ︙ | |||
552 553 554 555 556 557 558 | (lambda (testkeyname) (let* ((test-record (hash-table-ref testrecordshash testkeyname)) (test-name (tests:testqueue-get-testname test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) | | | | | | 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 | (lambda (testkeyname) (let* ((test-record (hash-table-ref testrecordshash testkeyname)) (test-name (tests:testqueue-get-testname test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) (test-id (rmt:get-test-id run-id test-name item-path)) (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if tdat (begin ;; Look at the test state and status (if (or (and (member (db:test-get-status tdat) '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) (equal? (db:test-get-state tdat) "COMPLETED")) (member (db:test-get-state tdat) '("INCOMPLETE" "KILLED"))) (set! keep-test #f)) ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test (let* ((parent-test-id (rmt:get-test-id run-id waiton "")) (wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") (member (db:test-get-status wtdat) '("FAIL"))) (member (db:test-get-status wtdat) '("KILLED")) (member (db:test-get-state wtdat) '("INCOMPETE"))) ;; (if (or (member (db:test-get-status wtdat) ;; '("FAIL" "KILLED")) ;; (member (db:test-get-state wtdat) |
︙ | ︙ | |||
676 677 678 679 680 681 682 | ;;====================================================================== ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here | | | | < < | | | > < > | < < < < < < < < < < < < < < < | | | | < | | < > > > | < < < < < < < < < < < < < < < < < < < < < < < < < | 614 615 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 | ;;====================================================================== ;; test steps ;;====================================================================== ;; teststep-set-status! used to be here (define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat) (let* ((testdat (rmt:get-test-info-by-id run-id test-id))) (and testdat (equal? (test:get-state testdat) "KILLREQ")))) (define (test:tdb-get-rundat-count tdb) (if tdb (let ((res 0)) (sqlite3:for-each-row (lambda (count) (set! res count)) tdb "SELECT count(id) FROM test_rundat;") res)) 0) (define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname) (rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id) (if minutes (rmt:general-call 'update-run-duration run-id minutes test-id)) (if (and uname hostname) (rmt:general-call 'update-uname-host run-id uname hostname test-id))) ;; This one is for running with no db access (i.e. via rmt: internally) (define (tests:set-full-meta-info db test-id run-id minutes work-area remtries) ;; (define (tests:set-full-meta-info test-id run-id minutes work-area) ;; (let ((remtries 10)) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (uname (get-uname "-srvpio")) (hostname (get-host-name))) (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname))) ;; (define (tests:set-partial-meta-info test-id run-id minutes work-area) (define (tests:set-partial-meta-info test-id run-id minutes work-area remtries) (let* ((cpuload (get-cpu-load)) (diskfree (get-df (current-directory))) (remtries 10)) (handle-exceptions exn (if (> remtries 0) (begin (print-call-chain (current-error-port)) (debug:print-info 0 "WARNING: failed to set meta info. Will try " remtries " more times") (set! remtries (- remtries 1)) (thread-sleep! 10) (tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1))) (let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn))) (debug:print 0 "ERROR: tried for over a minute to update meta info and failed. Giving up") (debug:print 0 "EXCEPTION: database probably overloaded or unreadable.") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (print "exn=" (condition->list exn)) (debug:print 0 " status: " ((condition-property-accessor 'sqlite3 'status) exn)) (print-call-chain (current-error-port)))) (tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes) ))) ;;====================================================================== ;; A R C H I V I N G ;;====================================================================== (define (test:archive db test-id) #f) (define (test:archive-tests db keynames target) #f) |
Modified tests/Makefile from [392c30bd69] to [502a984b43].
1 2 3 | # # run some tests | | | | | | | | | | | > | > > > | < < < < < | 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 | # # 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 := "-" RUNID := 1 SERVER = DEBUG = 1 LOGGING = ROWS = 20 OS = $(shell grep ID /etc/*-release|cut -d= -f2) FS = $(shell df -T .|tail -1|awk '{print $$2}') VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5) # The NEWTARGET causes some tests to fail. Do not use until this is fixed. NEWTARGET = "$(OS)/$(FS)/$(VER)" TARGET = "ubuntu/nfs/none" all : unit test1 test2 test3 test4 test5 test6 test7 test8 test9 unit : ./rununittest.sh basicserver $(DEBUG) server : cd ..;make -j;make install cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID) stopserver : cd ..;make -j && make install cd fullrun;$(MEGATEST) -stop-server 0 repl : cd ..;make -j && make install cd fullrun;$(MEGATEST) -repl test0 : cleanprep cd simplerun ; $(MEGATEST) -server - -debug $(DEBUG) test1 : cleanprep test2 : fullprep cd fullrun;$(MEGATEST) -preclean -runtests ez_pass,runfirst/a/% -reqtarg ubuntu/nfs/none :runname $(RUNNAME) -debug $(DEBUG) $(LOGGING) cd fullrun;megatest -preclean -runtests % -target ubuntu/nfs/none :runname $(RUNNAME)_01 -testpatt %/,%/ai -debug $(DEBUG) cd fullrun;megatest -preclean -runtests %/,%/ai -target ubuntu/nfs/none :runname $(RUNAME)_02 -debug $(DEBUG) cd fullrun;megatest -preclean -runtests runfirst/%,%/ai -target ubuntu/nfs/none :runname $(RUNNAME)_02 -debug $(DEBUG) cd fullrun;megatest -runtests %/,%/winter -target ubuntu/nfs/none :runname $(RUNNAME)_03 -debug $(DEBUG) |
︙ | ︙ | |||
74 75 76 77 78 79 80 | test5 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & cd fullrun;sleep 5;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & cd fullrun;sleep 8;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & # cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & | | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | test5 : cleanprep @echo "WARNING: No longer running fullprep, test converage may be lessened" cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_aa -debug $(DEBUG) $(LOGGING) > aa.log 2> aa.log & cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ab -debug $(DEBUG) $(LOGGING) > ab.log 2> ab.log & cd fullrun;sleep 5;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & cd fullrun;sleep 8;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & # cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_ae -debug $(DEBUG) $(LOGGING) > ae.log 2> ae.log & # cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & # MUST ADD THIS BACK IN ASAP!!!! # cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE test6: fullprep cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 |
︙ | ︙ | |||
115 116 117 118 119 120 121 | # 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;$(DASHBOARD)& | | | | | | | | | | | | | | | 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 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 193 194 195 | # 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;$(DASHBOARD)& cd mintest;$(MEGATEST) -preclean -runtests e -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9b : @echo Run simple mintest d with one waiton c cd mintest;$(MEGATEST) -preclean -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) -preclean -runtests a -target $(VER) :runname `date +%H.%M.%S` -debug $(DEBUG) test9d : @echo Run an itemized test with no items cd mintest;$(MEGATEST) -preclean -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) -preclean -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) -preclean -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) -preclean -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 -j && 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 -j;make install rm -f */logging.db touch cleanprep fullprep : cleanprep cd fullrun;$(MEGATEST) -remove-runs :runname $(RUNNAME)% -target %/%/% -testpatt %/% cd fullrun;$(BINPATH)/dashboard -rows 15 & dashboard : cleanprep cd fullrun && $(BINPATH)/dashboard -rows $(ROWS) & newdashboard : cleanprep cd fullrun && $(BINPATH)/newdashboard & remove : 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 /tmp/.$(USER)-portlogger.db *run/db/* */megatest.db */logging.db */monitor.db fullrun/tmp/mt_*/* fullrun/tmp/mt_*/.db* fullrun/logs/*.log fullrun/*.log || 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/fdktestqa/fdk.config from [0cdf621a94] to [bb2780b886].
1 2 3 4 | [fields] SYSTEM TEXT RELEASE TEXT | < | | | > > > > > > > > > > > > > > > > > > | 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 | [fields] SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines # max_concurrent_jobs 150 max_concurrent_jobs 1000 # This is your link path, you can move it but it is generally better to keep it stable linktree #{shell readlink -f #{getenv MT_RUN_AREA_HOME}/../simplelinks} [include testqa/configs/megatest.abc.config] # timeout 0.025 [jobtools] maxload 4 launcher nbfake [server] # timeout 0.01 # homehost xena # homehost 143.182.225.38 # force server server-query-threshold 0 [jobtools] # launcher nbq -P ch_vp -C SLES11_EM64T_4G -Q /ciaf/fdk # launcher nbfake # maxload 4 |
Modified tests/fdktestqa/testqa/Makefile from [6c9750395d] to [d3de829000].
1 2 3 4 5 6 7 8 9 10 11 12 | BINDIR = $(PWD)/../../../bin PATH := $(BINDIR):$(PATH) MEGATEST = $(BINDIR)/megatest DASHBOARD = $(BINDIR)/dashboard RUNNAME = a all : $(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/% $(MEGATEST) -runtests % -target a/b :runname c bigbig : | > < | | > > > | | 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 | BINDIR = $(PWD)/../../../bin PATH := $(BINDIR):$(PATH) MEGATEST = $(BINDIR)/megatest DASHBOARD = $(BINDIR)/dashboard NEWDASHBOARD = $(BINDIR)/newdashboard RUNNAME = a all : $(MEGATEST) -remove-runs -target a/b :runname c -testpatt %/% $(MEGATEST) -runtests % -target a/b :runname c bigbig : for tn in a b c d;do \ ($(MEGATEST) -runtests % -target a/b :runname $tn & ) ; \ done bigrun : $(MEGATEST) -runtests bigrun -target a/bigrun :runname a$(shell date +%V) bigrun2 : $(MEGATEST) -runtests bigrun2 -target a/bigrun2 :runname a$(shell date +%V) bigrun3 : $(MEGATEST) -runtests bigrun3 -target a/bigrun3 :runname $(RUNNAME) dashboard : $(DASHBOARD) -rows 20 & newdashboard : $(NEWDASHBOARD) & compile : (cd ../../..;make -j && make install) clean : rm -rf ../simple*/*/* megatest.db db/* ../simple*/.db/* logs/* monitor.db |
Modified tests/fdktestqa/testqa/configs/megatest.abc.config from [568ec796ea] to [a1a8a77b6d].
1 2 3 4 5 6 | # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] | | | 1 2 3 4 5 6 7 8 9 | # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] # useshell yes [include megatest.def.config] |
Modified tests/fdktestqa/testqa/configs/megatest.def.config from [614ea68417] to [1df0e5e24a].
1 2 3 4 5 6 | # You can override environment variables for all your tests here [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] | | | 1 2 3 4 5 6 7 8 | # You can override environment variables for all your tests here [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] disk0 #{scheme (nice-path "#{getenv MT_RUN_AREA_HOME}/../simpleruns")} |
Modified tests/fdktestqa/testqa/megatest.config from [50948d2125] to [0bd41b6735].
1 2 | [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log | < < > > > < < | 1 2 3 4 5 6 7 8 9 | [setup] testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # launchwait no [jobtools] launcher nbfake [include ../fdk.config] |
Modified tests/fdktestqa/testqa/tests/bigrun/step1.sh from [45d51b92e4] to [e700391a61].
1 2 | #!/bin/bash if [ $NUMBER -lt 10 ];then | | | 1 2 3 4 5 6 7 8 9 10 | #!/bin/bash if [ $NUMBER -lt 10 ];then sleep 20 sleep `echo 4 * $NUMBER | bc` else sleep 130 fi if [[ $RANDOM -lt 10000 ]];then exit 1 |
︙ | ︙ |
Modified tests/fullrun/config/mt_include_1.config from [8efd108e44] to [f2402f5b23].
1 2 | [setup] # exectutable /path/to/megatest | | > | | 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 | [setup] # exectutable /path/to/megatest max_concurrent_jobs 50 linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links [jobtools] useshell yes # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local # workhosts localhost hermes # launcher exec nbfake # launcher nbfake # launcher loadrunner # launcher echo # launcher nbfind # launcher nodanggood # launcher loadrunner launcher nbfake # maxload *per cpu* maxload 1.5 # default waitdelay is 60 seconds waitdelay 15 ## use "xterm -e csi -- " as a launcher to examine the launch environment. ## exit with (exit) ## get a shell with (system "bash") |
︙ | ︙ |
Modified tests/fullrun/megatest.config from [6d157bfc9e] to [a6f800861f].
︙ | ︙ | |||
31 32 33 34 35 36 37 | # yes, anything else is no run-wait yes # Use http instead of direct filesystem access # transport http | | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | # yes, anything else is no run-wait yes # Use http instead of direct filesystem access # transport http # transport fs # If set to "default" the old code is used. Otherwise defaults to 200 or uses # numeric value given. # runqueue 20 # Default runtimelim 1d 1h 1m 10s |
︙ | ︙ | |||
59 60 61 62 63 64 65 | testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # or for hard links # testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. # FULL or 2, NORMAL or 1, OFF or 0 | | > > > > > > > > > > | 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 | testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log # or for hard links # testcopycmd cp --remove-destination -rlv TEST_SRC_PATH/. TEST_TARG_PATH/. # FULL or 2, NORMAL or 1, OFF or 0 synchronous 0 # Throttle roughly scales the db access milliseconds to seconds delay throttle 0.2 # Max retries allows megatest to re-check that a tests status has changed # as tests can have transient FAIL status occasionally maxretries 20 # Setup continued. [setup] # override the logview command # logviewer (%MTCMD%) 2> /dev/null > /dev/null # override the html viewer launch command # # htmlviewercmd firefox -new-window htmlviewercmd konqueror # -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run # (nb// this is in addition to NOT_STARTED which is automatically re-run) # allow-auto-rerun INCOMPLETE ZERO_ITEMS # could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD [validvalues] state start end 0 1 - 2 status pass fail n/a 0 1 running - 2 # These are set before all tests, override them # in the testconfig [pre-launch-env-overrides] section [env-override] # This variable is honored by the loadrunner script. The value is in percent MAX_ALLOWED_LOAD 200 # MT_XTERM_CMD overrides the terminal command # MT_XTERM_CMD xterm -bg lightgreen -fg black SPECIAL_ENV_VARS overide them here - should be seen at launch and in the runs TESTVAR [system echo $PWD] DEADVAR [system ls] VARWITHDOLLAR $HOME/.zshrc |
︙ | ︙ | |||
107 108 109 110 111 112 113 | # The empty var should have a definition with null string EMPTY_VAR WRAPPEDVAR This var should have the work blah thrice: \ blah \ blah | < < < > | > > > > > > > > > > > > | < | | > > > | 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 158 159 160 161 162 163 164 165 166 167 168 169 170 | # The empty var should have a definition with null string EMPTY_VAR WRAPPEDVAR This var should have the work blah thrice: \ blah \ blah MAX_ALLOWED_LOAD 200 # XTERM [system xterm] # RUNDEAD [system exit 56] [server] synchronous 0 # If the server can't be started on this port it will try the next port until # it succeeds port 8080 # This server will keep running this number of hours after last access. # Three minutes is 0.05 hours # timeout 0.025 timeout 0.1 # Server is required - slower but more resistant to Sqlite issues. # required yes # Start server when average query takes longer than this server-query-threshold 100 # 55500 # daemonize yes # hostname #{scheme (get-host-name)} ## disks are: ## name host:/path/to/area ## -or- ## name /path/to/area [disks] disk0 /foobarbazz disk1 not-a-disk [include config/mt_include_2.config] [include #{getenv USER}_testing.config] [jobgroups] # NOTE: job groups will falsely count the toplevel test as a job. If possible add N # to your jobgroups where N is the number of parallel runs you are likely to see # sqlite3 6 blockz 10 # to your jobgroups where N is the number of parallel runs you are likely to see # |
Modified tests/fullrun/runconfigs.config from [cdf025da8a] to [30a30e595a].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 | [default/ubuntu/nfs] WACKYVAR2 #{runconfigs-get CURRENT} [ubuntu/nfs/none] WACKYVAR2 #{runconfigs-get CURRENT} SOMEVAR2 This should show up in SOMEVAR4 if the target is ubuntu/nfs/none [default] SOMEVAR3 #{rget SOMEVAR} SOMEVAR4 #{rget SOMEVAR2} SOMEVAR5 #{runconfigs-get SOMEVAR2} [this/a/test] | > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | [default/ubuntu/nfs] WACKYVAR2 #{runconfigs-get CURRENT} [ubuntu/nfs/none] WACKYVAR2 #{runconfigs-get CURRENT} SOMEVAR2 This should show up in SOMEVAR4 if the target is ubuntu/nfs/none VARWITHDOLLARSIGNS The$USER/signs/should/be/replaced/with/variable [default] SOMEVAR3 #{rget SOMEVAR} SOMEVAR4 #{rget SOMEVAR2} SOMEVAR5 #{runconfigs-get SOMEVAR2} [this/a/test] |
︙ | ︙ |
Modified tests/fullrun/tests/exit_0/testconfig from [475b97c77b] to [5010ef5eb6].
1 2 3 4 5 6 7 8 9 10 | [setup] runscript main.sh [test_meta] author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single reviewed 09/10/2011, by Matt | > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | [setup] runscript main.sh [test_meta] author matt owner bob description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS tags first,single reviewed 09/10/2011, by Matt [triggers] NOT_STARTED/ xterm -e bash -s -- RUNNING/ xterm -e bash -s -- |
Modified tests/fullrun/tests/priority_8/main.sh from [0536bc3eb1] to [12267f0508].
1 2 3 4 5 6 7 8 9 10 | #!/bin/bash # a bunch of steps in 2 second increments for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html sleep 2 $MT_MEGATEST -step step$i :state end :status 0 done exit 0 | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | #!/bin/bash # a bunch of steps in 2 second increments for i in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17;do echo "start step before $i: `date`" $MT_MEGATEST -step step$i :state start :status running -setlog results$i.html echo "start step after $i: `date`" sleep 2 echo "end step before $i: `date`" $MT_MEGATEST -step step$i :state end :status 0 echo "end step after $i: `date`" done exit 0 |
Modified tests/fullrun/tests/runfirst/main.sh from [2d77d9ebfd] to [f50c79a657].
︙ | ︙ | |||
28 29 30 31 32 33 34 35 36 | loadstatus=$? if [[ `basename $PWD` == "mustfail" ]];then $MT_MEGATEST -test-status :state COMPLETED :status FAIL else $MT_MEGATEST -test-status :state COMPLETED :status $loadstatus -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment" fi # $MT_MEGATEST -test-status :state COMPLETED :status FAIL | > > | 28 29 30 31 32 33 34 35 36 37 38 | loadstatus=$? if [[ `basename $PWD` == "mustfail" ]];then $MT_MEGATEST -test-status :state COMPLETED :status FAIL else $MT_MEGATEST -test-status :state COMPLETED :status $loadstatus -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment" fi env > envfile.txt # $MT_MEGATEST -test-status :state COMPLETED :status FAIL |
Modified tests/fullrun/tests/test_mt_vars/currentisblah.sh from [38498b5b33] to [e891695e2f].
1 2 | #!/usr/bin/env bash | | | 1 2 3 | #!/usr/bin/env bash grep -e '^export CURRENT' megatest.sh | grep /tmp/nada |
Added tests/fullrun/tests/test_mt_vars/eval_vars.sh version [786761600e].
> > > > > > > | 1 2 3 4 5 6 7 | #!/bin/bash if env | grep VARWITHDOLLARSIGNS | grep USER;then exit 1 # fails! else exit 0 # good! fi |
Modified tests/fullrun/tests/test_mt_vars/testconfig from [a0c61adcaf] to [0d7c3216f9].
︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 | empty_var empty_var.sh # VACKYVAR should be set to a path vackyvar vackyvar.sh # test-path and test-file test-path test-path-file.sh [requirements] waiton runfirst priority 0 [items] NUMNUM [system cat $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME/$PREDICTABLE] | > > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | empty_var empty_var.sh # VACKYVAR should be set to a path vackyvar vackyvar.sh # test-path and test-file test-path test-path-file.sh # verify that vars with $ signs get expanded varwithdollar eval_vars.sh [requirements] waiton runfirst priority 0 [items] NUMNUM [system cat $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME/$PREDICTABLE] |
︙ | ︙ |
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 |
︙ | ︙ |
Added tests/rununittest.sh version [d9bb67915f].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | #!/bin/bash # Usage: rununittest.sh testname debuglevel # # Ensure all is made (cd ..;make && make install) # put megatest on path from correct location mtbindir=$(readlink -f ../bin) export PATH="${mtbindir}:$PATH" # Clean setup # dbdir=$(cd simplerun;megatest -show-config -section setup -var linktree)/.db rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir/*.db rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir 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 |
Modified tests/simplerun/megatest.config from [4fdc96f0ee] to [4850198caf].
1 2 3 4 5 6 7 8 9 | [fields] SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 # This is your link path, you can move it but it is generally better to keep it stable | > > > > > | | | 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 | [fields] SYSTEM TEXT RELEASE TEXT [setup] # Adjust max_concurrent_jobs to limit how much you load your machines max_concurrent_jobs 50 # Uncomment this to make the in-mem db into a disk based db (slower but good for debug) # be aware that some unit tests will fail with this due to persistent data # # tmpdb /tmp # This is your link path, you can move it but it is generally better to keep it stable linktree #{getenv MT_RUN_AREA_HOME}/../simplelinks # Valid values for state and status for steps, NB// It is not recommended you use this [validvalues] state start end completed # Job tools are more advanced ways to control how your jobs are launched [jobtools] useshell yes launcher nbfind # You can override environment variables for all your tests here [env-override] EXAMPLE_VAR example value # As you run more tests you may need to add additional disks, the names are arbitrary but must be unique [disks] disk0 #{getenv MT_RUN_AREA_HOME}/../simpleruns |
Added tests/simplerun/tests/test2/step1.sh version [67f9a133dc].
> > > | 1 2 3 | #!/usr/bin/env bash # Run your step here |
Deleted tests/simplerun/tests/test2/step1.sh.sh version [67f9a133dc].
|
| < < < |
Added tests/simplerun/tests/test2/step2.sh version [67f9a133dc].
> > > | 1 2 3 | #!/usr/bin/env bash # Run your step here |
Deleted tests/simplerun/tests/test2/step2.sh.sh version [67f9a133dc].
|
| < < < |
Added tests/stats.txt version [2a209bca81].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | DB Stats: a1236d6bf92ec5cb8955f490761b21b0d3eea9d3 ======== Cmd Count TotTime Avg get-count-tests-running-for-run-id 1035 237.0 0.23 get-count-tests-running-in-jobgroup 884 119.0 0.13 get-count-tests-running 884 169.0 0.19 get-prereqs-not-met 884 732.0 0.83 get-test-info-by-id 673 122.0 0.18 get-keys 476 1.0 0.00 get-test-id 356 42.0 0.12 testmeta-get-record 203 24.0 0.12 roll-up-pass-fail-counts 159 39.0 0.25 register-test 140 30.0 0.21 test-set-rundir-shortdir 128 98.0 0.77 test-set-status-state 94 45.0 0.48 find-and-mark-incomplete 32 0.0 0.00 state-status-msg 25 4.0 0.16 delete-tests-in-state 12 4.0 0.33 get-tests-for-run-mindata 8 0.0 0.00 get-all-run-ids 5 2.0 0.40 get-run-info 4 0.0 0.00 register-run 4 5.0 1.25 set-tests-state-status 4 15.0 3.75 get-tests-for-run 4 15.0 3.75 # After converting first three functions above to sqlite3:first-result DB Stats ======== Cmd Count TotTime Avg get-count-tests-running-for-run-id 1138 179.0 0.16 get-count-tests-running-in-jobgroup 987 91.0 0.09 get-count-tests-running 987 171.0 0.17 get-prereqs-not-met 987 892.0 0.90 get-test-info-by-id 672 95.0 0.14 get-keys 476 0.0 0.00 get-test-id 355 41.0 0.12 testmeta-get-record 203 15.0 0.07 roll-up-pass-fail-counts 159 30.0 0.19 register-test 140 22.0 0.16 test-set-rundir-shortdir 128 855.0 6.68 test-set-status-state 94 20.0 0.21 find-and-mark-incomplete 36 1.0 0.03 state-status-msg 24 5.0 0.21 delete-tests-in-state 12 2.0 0.17 get-tests-for-run-mindata 9 0.0 0.00 get-all-run-ids 5 1.0 0.20 register-run 4 1.0 0.25 get-tests-for-run 4 11.0 2.75 get-run-info 4 0.0 0.00 set-tests-state-status 4 17.0 4.25 DB Stats another run, converted one or two non-relevant functions to sqlite3:first-result ======== Cmd Count TotTime Avg get-count-tests-running-for-run-id 987 157.0 0.16 get-count-tests-running-in-jobgroup 836 79.0 0.09 get-count-tests-running 836 121.0 0.14 get-prereqs-not-met 836 513.0 0.61 get-test-info-by-id 673 85.0 0.13 get-keys 476 0.0 0.00 get-test-id 356 32.0 0.09 testmeta-get-record 203 19.0 0.09 roll-up-pass-fail-counts 159 27.0 0.17 register-test 140 23.0 0.16 test-set-rundir-shortdir 128 35.0 0.27 test-set-status-state 94 20.0 0.21 find-and-mark-incomplete 40 0.0 0.00 state-status-msg 25 5.0 0.20 delete-tests-in-state 12 1.0 0.08 get-tests-for-run-mindata 10 0.0 0.00 get-all-run-ids 5 0.0 0.00 set-tests-state-status 4 15.0 3.75 register-run 4 2.0 0.50 get-run-info 4 1.0 0.25 get-tests-for-run 4 12.0 3.00 |
Modified tests/tests.scm from [18c56c70d8] to [9d9074d93d].
︙ | ︙ | |||
22 23 24 25 26 27 28 | (let ((files (glob "*_records.scm"))) (for-each (lambda (file) (print "Loading " file) (load file)) files)) | < | < < < | < < < | < < < | | < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | (let ((files (glob "*_records.scm"))) (for-each (lambda (file) (print "Loading " file) (load file)) files)) (let* ((unit-test-name (list-ref (argv) 4)) (fname (conc "../unittests/" unit-test-name ".scm"))) (if (file-exists? fname) (load fname) (print "ERROR: Unit test " unit-test-name " not found in unittests directory"))) (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/" "%abc%") (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a" "abc") (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b" "abc") (list #t #t #t #f #f #t #t #t #f #t #t #t #f #t)) |
Added tests/unittests/basicserver.scm version [4e0a526d82].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 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 | ;;====================================================================== ;; S E R V E R ;;====================================================================== ;; Run like this: ;; ;; ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (delete-file* "logs/1.log") (define run-id 1) (test "setup for run" #t (begin (launch:setup-for-run) (string? (getenv "MT_RUN_AREA_HOME")))) ;; NON Server tests go here (test #f #f (db:dbdat-get-path *db*)) (test #f #f (db:get-run-name-from-id *db* run-id)) (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) ;; (exit) ;; Server tests go here (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) (server:kind-run run-id) (test "did server start within 20 seconds?" #t (let loop ((remtries 20) (running (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))) (if running (> running 0) (if (> remtries 0) (begin (thread-sleep! 1.1) (loop (- remtries 1) (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id))))))) (test "did server become available" #t (let loop ((remtries 10) (res (tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) (if res (vector? res) (begin (if (> remtries 0) (begin (thread-sleep! 1.1) (loop (- remtries 1)(tasks:get-server (db:delay-if-busy (tasks:open-db)) run-id))) res))))) (define user (current-user-name)) (define runname "mytestrun") (define keys (rmt:get-keys)) (define runinfo #f) (define keyvals '(("SYSTEM" "abc")("RELEASE" "def"))) (define header (vector "SYSTEM" "RELEASE" "id" "runname" "state" "status" "owner" "event_time")) ;; Setup ;; (test #f #f (not (client:setup run-id))) (test #f #f (not (hash-table-ref/default *runremote* run-id #f))) ;; Login ;; (test #f '(#t "successful login") (rmt:login-no-auto-client-setup (hash-table-ref/default *runremote* run-id #f) run-id)) (test #f '(#t "successful login") (rmt:login run-id)) ;; Keys ;; (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) ;; No data in db ;; (test #f '() (rmt:get-all-run-ids)) (test #f #f (rmt:get-run-name-from-id run-id)) (test #f (let ((runrec (vector #f #f))) (vector-set! runrec header 0) (vector-set! runrec (vector #f #f #f #f) 1) runrec) (rmt:get-run-info run-id)) ;; Insert data into db ;; (test #f 1 (rmt:register-run keyvals runname "new" "n/a" user)) ;; (test #f #f (rmt:get-runs-by-patt keys runname)) (test #f #t (rmt:general-call 'register-test run-id run-id "test-one" "")) ;; With data in db ;; (test #f '(1) (rmt:get-all-run-ids)) (test #f runname (rmt:get-run-name-from-id run-id)) (test #f runname (let ((run-info (rmt:get-run-info run-id))) (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname"))) ;; (vector header (vector "abc" "def" 1 "mytestrun" "new" "n/a" "matt" 1416280640.0)) ;; test killing server ;; (tasks:kill-server-run-id run-id) (test #f #f (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id)) ;; (test #f #f (client:setup run-id)) ;; (set! *transport-type* 'http) ;; ;; (test "setup for run" #t (begin (launch: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 "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) ;; (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) ;; (+ (db:test-get-pass_count dat) ;; (db:test-get-fail_count dat)))) ;; ;; (define testregistry (make-hash-table)) ;; (for-each ;; (lambda (tname) ;; (for-each ;; (lambda (itempath) ;; (let ((tkey (conc tname "/" itempath)) ;; (rpass (random 10)) ;; (rfail (random 10))) ;; (hash-table-set! testregistry tkey (list tname itempath)) ;; (rmt:general-call 'register-test 1 tname itempath) ;; (let* ((tid (rmt:get-test-id 1 tname itempath)) ;; (tdat (rmt:get-test-info-by-id tid))) ;; (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) ;; (let* ((resdat (rmt:get-test-info-by-id tid))) ;; (test "set/get pass fail counts" (list rpass rfail) ;; (list (db:test-get-pass_count resdat) ;; (db:test-get-fail_count resdat))))))) ;; (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) ;; (list "test1" "test2" "test3" "test4" "test5")) ;; ;; ;; (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) ;; (exit) |
Added tests/unittests/configfiles.scm version [b89134d61a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;====================================================================== ;; C O N F I G F I L E S ;;====================================================================== (define conffile #f) (test "Read a config" #t (hash-table? (read-config "test.config" #f #f))) (test "Read a config that doesn't exist" #t (hash-table? (read-config "nada.config" #f #f))) (set! conffile (read-config "test.config" #f #f)) (test "Get available diskspace" #t (number? (get-df "./"))) (test "Get best dir" #t (let ((bestdir (get-best-disk conffile))) (or (equal? "./" bestdir) (equal? "/tmp" bestdir)))) (test "Multiline variable" 4 (length (string-split (config-lookup conffile "metadata" "description") "\n"))) ;; db (define row (vector "a" "b" "c" "blah")) (define header (list "col1" "col2" "col3" "col4")) (test "Get row by header" "blah" (db:get-value-by-header row header "col4")) ;; (define *toppath* "tests") (define *db* #f) (test "open-db" #t (begin (set! *db* (open-db)) (if *db* #t #f))) ;; quit wasting time, I'm changing *db* to db (define db *db*) (test "get cpu load" #t (number? (get-cpu-load))) (test "get uname" #t (string? (get-uname))) (test "get validvalues as list" (list "start" "end" "completed") (string-split (config-lookup *configdat* "validvalues" "state"))) (for-each (lambda (item) (test (conc "get valid items (" item ")") item (items:check-valid-items "state" item))) (list "start" "end" "completed")) (for-each (lambda (item) (test (conc "get valid items (" item ")") item (items:check-valid-items "status" item))) (list "pass" "fail" "n/a")) (test #f #f (items:check-valid-items "state" "blahfool")) (test "write env files" "nada.csh" (begin (save-environment-as-files "nada") (and (file-exists? "nada.sh") (file-exists? "nada.csh")))) |
Added tests/unittests/dbrdbstruct.scm version [174e159a1e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;====================================================================== ;; S E R V E R ;;====================================================================== ;; Run like this: ;; ;; (cd ..;make && make install) && ./rununittest.sh server 1;(cd simplerun;megatest -stop-server 0) (test #f #t (vector? (make-dbr:dbstruct "/tmp"))) (define dbstruct (make-dbr:dbstruct "/tmp")) (test #f #t (begin (dbr:dbstruct-set-main! dbstruct "blah") #t)) (test #f "blah" (dbr:dbstruct-get-main dbstruct)) (for-each (lambda (run-id) (test #f #t (vector? (dbr:dbstruct-get-rundb-rec dbstruct run-id)))) (list 1 2 3 4 5 6 7 8 9 #f)) (test #f 0 (dbr:dbstruct-field-name->num 'rundb)) (test #f 1 (dbr:dbstruct-field-name->num 'inmem)) (test #f 2 (dbr:dbstruct-field-name->num 'mtime)) (test #f #f (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb)) (test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 'rundb "rundb") #t)) (test #f "rundb" (dbr:dbstruct-get-runvec-val dbstruct 1 'rundb)) (for-each (lambda (k) (test #f #t (begin (dbr:dbstruct-set-runvec-val! dbstruct 1 k (conc k)) #t)) (test #f (conc k) (dbr:dbstruct-get-runvec-val dbstruct 1 k))) '(rundb inmem mtime rtime stime inuse)) |
Added tests/unittests/inmemdb.scm version [be345ba03b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 (db:open-inmem-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))) |
Added tests/unittests/misc.scm version [68603bcdd2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;====================================================================== ;; P R O C E S S E S ;;====================================================================== (test "cmd-run-with-stderr->list" '("No such file or directory") (let ((reslst (cmd-run-with-stderr->list "ls" "/tmp/ihadbetternotexist"))) (string-search (regexp "No such file or directory")(car reslst)))) ;;====================================================================== ;; T E S T M A T C H I N G ;;====================================================================== ;; tests:glob-like-match (test #f '("abc") (tests:glob-like-match "abc" "abc")) (for-each (lambda (patt str expected) (test (conc patt " " str "=>" expected) expected (tests:glob-like-match patt str))) (list "abc" "~abc" "~abc" "a*c" "a%c") (list "abc" "abcd" "abc" "ABC" "ABC") (list '("abc") #t #f #f '("ABC")) ) ;; tests:match (test #f #t (tests:match "abc/def" "abc" "def")) (for-each (lambda (patterns testname itempath expected) (test (conc patterns " " testname "/" itempath "=>" expected) expected (tests:match patterns testname itempath))) (list "abc" "abc/%" "ab%/c%" "~abc/c%" "abc/~c%" "a,b/c,%/d" "%/,%/a" "%/,%/a" "%/,%/a" "%" "%" "%/" "%/") (list "abc" "abc" "abcd" "abc" "abc" "a" "abc" "def" "ghi" "a" "a" "a" "a") (list "" "" "cde" "cde" "cde" "" "" "a" "b" "" "b" "" "b") (list #t #t #t #f #f #t #t #t #f #t #t #t #f)) ;; db:patt->like (test #f "testname LIKE 't%'" (db:patt->like "testname" "t%" comparator: " AND ")) (test #f "testname LIKE 't%' AND testname LIKE '%t'" (db:patt->like "testname" "t%,%t" comparator: " AND ")) (test #f "item_path GLOB ''" (db:patt->like "item_path" "")) ;; test:match->sqlqry (test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname GLOB '' AND item_path LIKE 'b%')" (tests:match->sqlqry "a/b,a%,/b%")) (test #f "(testname GLOB 'a' AND item_path GLOB 'b') OR (testname LIKE 'a%' AND item_path LIKE '%') OR (testname LIKE '%' AND item_path LIKE 'b%')" (tests:match->sqlqry "a/b,a%,%/b%")) |
Added tests/unittests/runs.scm version [61908ea980].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 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 268 269 270 271 272 273 274 275 | (define keys (db:get-keys *db*)) (test "get all legal tests" (list "test1" "test2") (sort (get-all-legal-tests) string<=?)) (test "register-run" #t (number? (db:register-run *db* '(("SYSTEM" "key1")("RELEASE" "key2")) "myrun" "new" "n/a" "bob"))) (test #f #t (cdb:tests-register-test *runremote* 1 "nada" "")) (test #f 1 (cdb:remote-run db:get-test-id #f 1 "nada" "")) (test #f "NOT_STARTED" (vector-ref (open-run-close db:get-test-info #f 1 "nada" "") 3)) (test #f "NOT_STARTED" (vector-ref (cdb:get-test-info *runremote* 1 "nada" "") 3)) (test #f "FOO LIKE 'abc%def'" (db:patt->like "FOO" "abc%def")) (test #f "key2" (vector-ref (car (vector-ref (runs:get-runs-by-patt *db* '("SYSTEM" "RELEASE") "%" "key1/key2") 1)) 1)) (test #f "SYSTEM,RELEASE,id,runname,state,status,owner,event_time" (car (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))) (test #f #t (runs:operate-on 'print "%" "%" "%")) ;;(test "update-test-info" #t (test-update-meta-info *db* 1 "nada" (setenv "BLAHFOO" "1234") (unsetenv "NADAFOO") (test "env temp overrides" "xyz" (let ((prevvals (alist->env-vars '(("BLAHFOO" 4321)("NADAFOO" xyz)))) (result (get-environment-variable "NADAFOO"))) (alist->env-vars prevvals) result)) (test "env restored" "1234" (get-environment-variable "BLAHFOO")) (test "Items assoc" "Elephant" (cadar (cadr (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))))) (set! *verbosity* 6) (test "Items assoc" '()(item-assoc->item-list '(("a" "a b c d")("b" "c d e")("c" "")("d")))) (set! *verbosity* -1) (test "Items assoc empty items" '() (item-assoc->item-list '(("A")))) (set! *verbosity* 1) (test "Items table" "SEASON" (caadar (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter"))))) (test "Items table empty items I" '() (item-table->item-list '(("A")))) (test "Items table empty items II" '() (item-table->item-list '(("A" "")))) ;; Test out the steps code (define test-id #f) ;; force keepgoing ; (hash-table-set! args:arg-hash "-keepgoing" #t) (hash-table-set! args:arg-hash "-itempatt" "%") (hash-table-set! args:arg-hash "-testpatt" "%") (hash-table-set! args:arg-hash "-target" "ubuntu/r1.2") (test "Setup for a run" #t (begin (setup-for-run) #t)) (define *tdb* #f) (define keyvals #f) (test "target->keyval" #t (let ((kv (keys:target->keyval keys (args:get-arg "-target")))) (set! keyvals kv)(list? keyvals))) (define testdbpath (conc "/tmp/" (getenv "USER") "/megatest_testing")) (system (conc "rm -f " testdbpath "/testdat.db;mkdir -p " testdbpath)) (print "Using " testdbpath " for test db") (test #f #t (let ((db (open-test-db testdbpath))) (set! *tdb* db) (sqlite3#database? db))) (sqlite3#finalize! *tdb*) ;; (test "Remove the rollup run" #t (begin (remove-runs) #t)) (define tconfig #f) (test "get a testconfig" #t (let ((tconf (tests:get-testconfig "test1" 'return-procs))) (set! tconfig tconf) (hash-table? tconf))) (db:clean-all-caches) (test "set-megatest-env-vars" "ubuntu" (begin (set-megatest-env-vars 1 inkeys: keys) (get-environment-variable "SYSTEM"))) (test "setup-env-defaults" "see this variable" (begin (setup-env-defaults "runconfigs.config" 1 *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars") (get-environment-variable "ALLTESTS"))) (test #f "ubuntu" (car (keys:target-set-args keys (args:get-arg "-target") args:arg-hash))) (define rinfo #f) (test "get-run-info" #f (vector? (vector-ref (let ((rinf (cdb:remote-run db:get-run-info #f 1))) (set! rinfo rinf) rinf) 0))) (test "get-key-vals" "key1" (car (cdb:remote-run db:get-key-vals #f 1))) (test "tests:sort-by" '() (tests:sort-by-priority-and-waiton (make-hash-table))) (test "update-test_meta" "test1" (begin (runs:update-test_meta "test1" tconfig) (let ((dat (cdb:remote-run db:testmeta-get-record #f "test1"))) (vector-ref dat 1)))) (define test-path "tests/test1") (define disk-path #f) (test "get-best-disk" #t (string? (file-exists? (let ((d (get-best-disk *configdat*))) (set! disk-path d) d)))) (test "create-work-area" #t (symbolic-link? (car (create-work-area 1 rinfo keyvals 1 test-path disk-path "test1" '())))) (test #f "" (item-list->path '())) (test "launch-test" #t (string? (file-exists? (launch-test 1 1 rinfo keyvals "run1" tconfig "test1" test-path '() (make-hash-table))))) (test "Run a test" #t (general-run-call "-runtests" "run a test" (lambda (target runname keys keyvallst) (let ((test-patts "test%")) ;; (runs:run-tests target runname test-patts user (make-hash-table)) ;; (run:test run-id run-info key-vals runname test-record flags parent-test) ;; (set! *verbosity* 22) ;; (list 0 1 2)) (run:test 1 ;; run-id #f ;; run-info is yet only a dream keyvallst ;; (keys:target->keyval keys target) "run1" ;; runname (vector ;; test_records.scm tests:testqueue "test1" ;; testname tconfig ;; testconfig '() ;; waitons 0 ;; priority #f ;; items #f ;; itemsdat "" ;; itempath ) args:arg-hash ;; flags (e.g. -itemspatt) #f) ;; (set! *verbosity* 0) )))) (test "server stop" #f (let ((hostname (car *runremote*)) (port (cadr *runremote*))) (tasks:kill-server #t hostname port server-pid 'http) (open-run-close tasks:get-best-server tasks:open-db))) (exit 1) ;; (test "cache is coherent" #t (let ((cached-info (db:get-test-info-cached-by-id db 2)) ;; (non-cached (db:get-test-info-not-cached-by-id db 2))) ;; (print "\nCached: " cached-info) ;; (print "Noncached: " non-cached) ;; (equal? cached-info non-cached))) (change-directory test-work-dir) (test "Add a step" #t (begin (db:teststep-set-status! db 2 "step1" "start" 0 "This is a comment" "mylogfile.html") (sleep 2) (db:teststep-set-status! db 2 "step1" "end" "pass" "This is a different comment" "finallogfile.html") (set! test-id (db:test-get-id (car (cdb:remote-run db:get-tests-for-run #f 1 "test1" '() '())))) (number? test-id))) (test "Get rundir" #t (let ((rundir (cdb:remote-run db:test-get-rundir-from-test-id #f test-id))) (print "Rundir " rundir) (system (conc "mkdir -p " rundir)) (string? rundir))) (test #f #t (sqlite3#database? (open-test-db "./"))) (test "Create a test db" "../simpleruns/key1/key2/myrun/test1/testdat.db" (let ((tdb (open-run-close db:open-test-db-by-test-id db test-id))) (if tdb (sqlite3#finalize! tdb)) (file-exists? "../simpleruns/key1/key2/myrun/test1/testdat.db"))) (test "Get steps for test" #t (let ((steps (cdb:remote-run db:get-steps-for-test #f test-id))) (print steps) (> (length steps) 0))) (test "Get nice table for steps" "2.0s" (begin (vector-ref (hash-table-ref (open-run-close db:get-steps-table #f test-id) "step1") 4))) ;; (exit) (test #f "myrun" (cdb:remote-run db:get-run-name-from-id #f 1)) (test #f #f (cdb:remote-run db:roll-up-pass-fail-counts #f 1 "nada" "" "PASS")) ;;====================================================================== ;; R E M O T E C A L L S ;;====================================================================== (define start-wait (current-seconds)) (print "Starting intensive cache and rpc test") (for-each (lambda (params) (print "Intensive: params=" params) (cdb:tests-register-test *runremote* 1 (conc "test" (random 20)) "") (apply cdb:test-set-status-state *runremote* test-id params) (cdb:pass-fail-counts *runremote* test-id (random 100) (random 100)) (cdb:test-rollup-test_data-pass-fail *runremote* test-id) (cdb:roll-up-pass-fail-counts *runremote* 1 "test1" "" (cadr params)) (thread-sleep! 0.01)) ;; cache ordering granularity is at the second level. Should really be at the ms level '(("COMPLETED" "PASS" #f) ("NOT_STARTED" "FAIL" "Just testing") ("NOT_STARTED" "FAIL" "Just testing") ("NOT_STARTED" "FAIL" "Just testing") ("COMPLETED" "PASS" #f) ("NOT_STARTED" "FAIL" "Just testing") ("KILLED" "UNKNOWN" "More testing") ("NOT_STARTED" "FAIL" "Just testing") ("NOT_STARTED" "FAIL" "Just testing") ("COMPLETED" "PASS" #f) ("NOT_STARTED" "FAIL" "Just testing") ("NOT_STARTED" "FAIL" "Just testing") ("KILLED" "UNKNOWN" "More testing") ("NOT_STARTED" "FAIL" "Just testing") ("COMPLETED" "PASS" #f) ("NOT_STARTED" "FAIL" "Just testing") ("KILLED" "UNKNOWN" "More testing") ("NOT_STARTED" "FAIL" "Just testing") ("NOT_STARTED" "FAIL" "Just testing") ("COMPLETED" "PASS" #f) ("NOT_STARTED" "FAIL" "Just testing") ("NOT_STARTED" "FAIL" "Just testing") ("KILLED" "UNKNOWN" "More testing") ("NOT_STARTED" "FAIL" "Just testing") ("COMPLETED" "PASS" #f) ("NOT_STARTED" "FAIL" "Just testing") ("NOT_STARTED" "FAIL" "Just testing") ("KILLED" "UNKNOWN" "More testing") ("NOT_STARTED" "FAIL" "Just testing") ("NOT_STARTED" "FAIL" "Just testing") ("COMPLETED" "PASS" #f) ("NOT_STARTED" "FAIL" "Just testing") ("KILLED" "UNKNOWN" "More testing") ("NOT_STARTED" "FAIL" "Just testing") ("NOT_STARTED" "FAIL" "Just testing") ("COMPLETED" "PASS" #f) ("NOT_STARTED" "FAIL" "Just testing") ("KILLED" "UNKNOWN" "More testing") ("KILLED" "UNKNOWN" "More testing") )) ;; now set all tests to completed (cdb:flush-queue *runremote*) (let ((tests (cdb:remote-run db:get-tests-for-run #f 1 "%" '() '()))) (print "Setting " (length tests) " to COMPLETED/PASS") (for-each (lambda (test) (cdb:test-set-status-state *runremote* (db:test-get-id test) "COMPLETED" "PASS" "Forced pass")) tests)) ;; (process-wait server-pid) ;; (test "Server wait time" #t (let ((run-delta (- (current-seconds) start-wait))) ;; (print "Server ran for " run-delta " seconds") ;; (> run-delta 20))) (test "Rollup the run(s)" #t (begin (runs:rollup-run keys (keys->alist keys "na") "rollup" "matt") #t)) (hash-table-set! args:arg-hash ":runname" "%") (test "Remove the rollup run" #t (begin (operate-on 'remove-runs))) (print "Waiting for server to be done, should be about 20 seconds") (test "server stop" #f (let ((hostname (car *runremote*)) (port (cadr *runremote*))) (tasks:kill-server #t hostname port server-pid 'http) (open-run-close tasks:get-best-server tasks:open-db))) ;; (cdb:kill-server *runremote*) ;; (thread-join! th1 th2 th3) ;; ADD ME!!!! (db:get-prereqs-not-met *db* 1 '("runfirst") "" mode: 'normal) ;; ADD ME!!!! (rdb:get-tests-for-run *db* 1 "runfirst" #f '() '()) |
Added tests/unittests/server.scm version [fc736c5f6c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 | ;;====================================================================== ;; 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 1 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 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 1 "this is a comment" 1) #t)) (test "get comment" "this is a comment" (let ((trec (rmt:get-test-info-by-id 1 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 1) 2)) (test "get testinfo" "test1" (vector-ref (rmt:get-testinfo-state-status 1 1) 2)) ;;====================================================================== ;; D B ;;====================================================================== (test "pass fail counts" #t (rmt:general-call 'pass-fail-counts 10 9 1)) (test "get pass fail counts" 19 (let ((dat (rmt:get-test-info-by-id 1))) (+ (db:test-get-pass_count dat) (db:test-get-fail_count dat)))) (define testregistry (make-hash-table)) (for-each (lambda (tname) (for-each (lambda (itempath) (let ((tkey (conc tname "/" itempath)) (rpass (random 10)) (rfail (random 10))) (hash-table-set! testregistry tkey (list tname itempath)) (rmt:general-call 'register-test 1 tname itempath) (let* ((tid (rmt:get-test-id 1 tname itempath)) (tdat (rmt:get-test-info-by-id tid))) (rmt:general-call 'pass-fail-counts rpass rfail (db:test-get-id tdat)) (let* ((resdat (rmt:get-test-info-by-id tid))) (test "set/get pass fail counts" (list rpass rfail) (list (db:test-get-pass_count resdat) (db:test-get-fail_count resdat))))))) (list "" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j"))) (list "test1" "test2" "test3" "test4" "test5")) (test #f '(#t "exit process started") (rmt:kill-server)) ;; *toppath* *my-client-signature* #f))) |
Added tests/unittests/tests.scm version [da39a3ee5e].
Added tests/watch-monitor.sh version [b68f1ca512].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | #!/bin/bash if [ -e fullrun/db/monitor.db ];then sqlite3 fullrun/db/monitor.db << EOF .header on .mode column select * from servers order by start_time desc; .q EOF fi |
Modified tree.scm from [e7e38b65a4] to [02f8628298].
︙ | ︙ | |||
63 64 65 66 67 68 69 | (if (> depth node-depth) ;; (+ 1 node-depth)) #f (loop hed tal depth (+ nodenum 1))))) #f)))) ;; top is the top node name zeroeth node VALUE=0 (define (tree:add-node obj top nodelst #!key (userdata #f)) | > | | > | 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 | (if (> depth node-depth) ;; (+ 1 node-depth)) #f (loop hed tal depth (+ nodenum 1))))) #f)))) ;; top is the top node name zeroeth node VALUE=0 (define (tree:add-node obj top nodelst #!key (userdata #f)) (if (or (not (string? (iup:attribute obj "TITLE0"))) (string-null? (iup:attribute obj "TITLE0"))) (iup:attribute-set! obj "ADDBRANCH0" top)) (cond ((not (equal? top (iup:attribute obj "TITLE0"))) (print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0"))) ((null? nodelst)) (else (let loop ((hed (car nodelst)) (tal (cdr nodelst)) (depth 1) (pathl (list top))) ;; Because the tree dialog changes node numbers when ;; nodes are added or removed we must look up nodes ;; each and every time. 0 is the top node so default ;; to that. (let* ((newpath (append pathl (list hed))) (parentnode (tree:find-node obj pathl)) (nodenum (tree:find-node obj newpath))) ;; Add the branch under lastnode if not found (if (not nodenum) (begin (iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed) ;; ERROR? ADDING DATA TO PARENT, DONT WE WANT IT ON CREATED NODE? (if userdata (iup:attribute-set! obj (conc "USERDATA" parentnode) userdata)) (if (null? tal) #t ;; reset to top (loop (car nodelst)(cdr nodelst) 1 (list top)))) (if (null? tal) ;; if null here then this path has already been added |
︙ | ︙ | |||
109 110 111 112 113 114 115 | (take path node-depth) path)) (newpath (append trimpath (list node-title)))) (if (>= currnode nodenum) newpath (loop (+ currnode 1) newpath))))) | | > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (take path node-depth) path)) (newpath (append trimpath (list node-title)))) (if (>= currnode nodenum) newpath (loop (+ currnode 1) newpath))))) (define (tree:delete-node obj top node-path) ;; node-path is a list of strings (let ((id (tree:find-node obj (cons top node-path)))) (print "Found node to remove " id " for path " top " " node-path) (iup:attribute-set! obj (conc "DELNODE" id) "SELECTED"))) #| (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (run-id (tree-path->run-id (cdr run-path)))) (if run-id (begin (dboard:data-set-curr-run-id! *data* run-id) (dashboard:update-run-summary-tab))) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) )))) |# |
Modified utils/Makefile.installall from [3d28c758b8] to [c3d10e5280].
1 |
| | > > | | < | | | | | < < | < < < < < | | > > > > | > | | | | 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 | # Copyright 2013,2014 Matthew Welland. # # This program is made available under the GNU GPL version 2.0 or # greater. See the accompanying file COPYING for details. # # This program is distributed WITHOUT ANY WARRANTY; without even the # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # PURPOSE. # make PREFIX=/mfs/pkgs/chicken/chicken-core all help : @echo You may need to do the following first: @echo sudo apt-get install libreadline-dev @echo sudo apt-get install libwebkitgtk-dev libfreetype6-dev libx11-dev libxpm-dev libxmu-dev libxft-dev libgtk2.0-dev libgl1-mesa-dev libglu1-mesa-dev libpangox-1.0-dev bison @echo sudo apt-get install libmotif3 @echo For IUP set IUPBRANCH, currently $(IUPBRANCH) @echo You are using PREFIX=$(PREFIX) @echo You are using PROXY="$(PROXY)" @echo If needed set PROXY to host.dom:port @echo http_proxy=$(http_proxy) @echo PROX=$(PROX) @echo @echo To make all do: make all # Put the installation here ifeq ($(PREFIX),) PREFIX=$(PWD)/target endif # Set this on the command line of your make call if needed: make PROXY=host.com:1234 PROXY= # Select version of chicken, sqlite3 etc CHICKEN_VERSION=4.9.0.1 SQLITE3_VERSION=3080500 # http://www.sqlite.org/2014/sqlite-autoconf-3080500.tar.gz # Override IUPBRANCH to use other than trunk IUPBRANCH=iup-3.10.1 # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \ spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \ srfi-19 refdb ini-file # # Derived variables # ifeq ($(PROXY),) PROX:= else http_proxy:=http://$(PROXY) PROX:=-proxy $(PROXY) endif BUILDHOME=$(PWD) PATH:=$(PREFIX)/bin:$(PATH) LIBPATH=$(PREFIX)/lib$(ADDITIONAL_LIBPATH) LD_LIBRARY_PATH=$(LIBPATH) CHICKEN_INSTALL=$(PREFIX)/bin/chicken-install |
︙ | ︙ | |||
78 79 80 81 82 83 84 | ISARCHX86_64=$(shell uname -a | grep x86_64) ifeq ($(ISARCHX86_64),) ARCHSIZE= else ARCHSIZE=64_ endif | < > | | < < | | | | | > > | | > | > > | | | > > > > | | | | | | | > > > | > > < | < | | | | | < < | < | > | < | | | | > | > | > > | > > > | > > | | > | | | | > | 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 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 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | ISARCHX86_64=$(shell uname -a | grep x86_64) ifeq ($(ISARCHX86_64),) ARCHSIZE= else ARCHSIZE=64_ endif CSCLIBS=$(shell echo $(LD_LIBRARY_PATH) | sed 's/:/ -L/g') CSC_OPTIONS="-I$(PREFIX)/include -L$(CSCLIBS)" # CSC_OPTIONS=-I$(PREFIX)/include -L$(CSCLIBS) all : chkn eggs libiup logprobin $(PREFIX)/lib/sqlite3.so $(PREFIX)/bin/hs chkn : $(CHICKEN_INSTALL) eggs : $(EGGSOFILES) libiup : $(PREFIX)/lib/libavcall.a $(CHICKEN_EGG_DIR)/iup.so $(CHICKEN_EGG_DIR)/canvas-draw.so logprobin : $(PREFIX)/bin/logpro $(PREFIX)/bin/logpro : $(CHICKEN_EGG_DIR)/regex-literals.so $(CHICKEN_INSTALL) logpro # Silly rule to make installing eggs more makeish, I don't understand why I need the basename $(CHICKEN_EGG_DIR)/%.so : eggflags/%.flag $(CHICKEN_INSTALL) $(PROX) -keep-installed $(shell basename $*) $(EGGFLAGS) : # $(CHICKEN_INSTALL) mkdir -p eggflags touch $(EGGFLAGS) # some setup stuff # setup-chicken4x.sh : $(EGGFLAGS) (echo "export PATH=$(PATH)" > setup-chicken4x.sh) (echo "export LD_LIBRARY_PATH=$(LD_LIBRARY_PATH)" >> setup-chicken4x.sh) mkdir -p $(PREFIX) chicken-core/chicken.scm : chicken-$(CHICKEN_VERSION).tar.gz tar xfz chicken-$(CHICKEN_VERSION).tar.gz ln -sf chicken-$(CHICKEN_VERSION) chicken-core chicken-4.9.0rc1.tar.gz : wget http://code.call-cc.org/dev-snapshots/2014/04/17/chicken-4.9.0rc1.tar.gz chicken-4.9.0.1.tar.gz : wget http://code.call-cc.org/releases/4.9.0/chicken-4.9.0.1.tar.gz # git clone git://code.call-cc.org/chicken-core # git clone http://code.call-cc.org/git/chicken-core.git $(CHICKEN_INSTALL) : chicken-core/chicken.scm setup-chicken4x.sh cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) cd chicken-core;make PLATFORM=linux PREFIX=$(PREFIX) install #====================================================================== # S Q L I T E 3 #====================================================================== sqlite-autoconf-$(SQLITE3_VERSION).tar.gz : wget http://www.sqlite.org/2014/sqlite-autoconf-$(SQLITE3_VERSION).tar.gz sqlite-autoconf-$(SQLITE3_VERSION)/config.log : sqlite-autoconf-$(SQLITE3_VERSION).tar.gz tar xfz sqlite-autoconf-$(SQLITE3_VERSION).tar.gz $(PREFIX)/bin/sqlite3 : sqlite-autoconf-$(SQLITE3_VERSION)/config.log cd sqlite-autoconf-$(SQLITE3_VERSION);./configure --prefix=$(PREFIX);make;make install $(PREFIX)/lib/sqlite3.so : $(PREFIX)/bin/sqlite3 CSC_OPTIONS="-I$(PREFIX)/include -L$(PREFIX)/lib" $(CHICKEN_INSTALL) $(PROX) sqlite3 #====================================================================== # M A T T S U T I L S #====================================================================== opensrc.fossil : fossil clone http://www.kiatoa.com/fossils/opensrc opensrc.fossil opensrc/histstore/histstore.scm : opensrc.fossil mkdir -p opensrc cd opensrc;fossil open ../opensrc.fossil opensrc/histstore/hs : opensrc/histstore/histstore.scm chkn eggs $(PREFIX)/lib/sqlite3.so cd opensrc/histstore;$(PREFIX)/bin/csc histstore.scm -o hs $(PREFIX)/bin/hs : opensrc/histstore/hs cp -f opensrc/histstore/hs $(PREFIX)/bin/hs #====================================================================== # I U P #====================================================================== ffcall.fossil : fossil clone http://www.kiatoa.com/fossils/ffcall ffcall.fossil ffcall/README : ffcall.fossil mkdir -p ffcall cd ffcall && if [ -e README ];then fossil update; else fossil open ../ffcall.fossil; fi # NOTE: This worked fine *without* the enable-shared # $(PREFIX)/lib/libavcall.a : ffcall/README cd ffcall;./configure --prefix=$(PREFIX) --enable-shared && make && make install iuplib.fossil : fossil clone http://www.kiatoa.com/fossils/iuplib iuplib.fossil iup/installall.sh : iuplib.fossil mkdir -p iup cd iup && if [ -e installall.sh ];then fossil update $(IUPBRANCH); else fossil open ../iuplib.fossil;fossil update $(IUPBRANCH); fi iup/alldone : iup/installall.sh $(PREFIX)/include/iup.h $(PREFIX)/lib/libiup.so cd iup && ./makeall.sh $(PREFIX)/lib/libiup.so $(PREFIX)/include/iup.h : iup/installall.sh iup/alldone cd iup && ./installall.sh # $(PREFIX)/lib/libiup.so : iup/iup/alldone # touch -c $(PREFIX)/lib/libiup.so $(CHICKEN_EGG_DIR)/iup.so : $(PREFIX)/lib/libiup.so LD_LIBRARY_PATH=$(LD_LIBRARY_PATH) CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks -feature disable-iup-web iup $(CHICKEN_EGG_DIR)/canvas-draw.so : $(PREFIX)/lib/libiup.so CSC_OPTIONS=$(CSC_OPTIONS) $(CHICKEN_INSTALL) $(PROX) -D no-library-checks canvas-draw clean : rm -rf chicken-4.8.0 eggflags ffcall sqlite-autoconf-$(SQLITE3_VERSION) |
Deleted utils/Makefile_latest.installall version [a5be37ec2b].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Modified utils/mk_wrapper from [7459f2e147] to [8a8fb062fe].
1 2 3 4 5 6 7 8 | #!/bin/bash prefix=$1 cmd=$2 target=$3 if [ "$LD_LIBRARY_PATH" != "" ];then echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2 | > > > > > | > > > > | 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 | #!/bin/bash prefix=$1 cmd=$2 target=$3 if [ "$LD_LIBRARY_PATH" != "" ];then cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh" echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2 ( cat << __EOF if [ "\$LD_LIBRARY_PATH" != "" ];then export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH else export LD_LIBRARY_PATH=$LD_LIBRARY_PATH fi __EOF ) > $cfgfile echo else echo "INFO: LD_LIBRARY_PATH not set" >&2 fi echo "#!/bin/bash" > $target echo "source $prefix/bin/.\$(lsb_release -sr)/cfg.sh" >> $target echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target |
︙ | ︙ |
Modified utils/nbfake from [99a526d022] to [9de79bbac2].
1 | #!/bin/bash | > | > > > > > > > | > > | > | > | > > > > > > > | < | | > > > > > > | > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > | > | | 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 | #!/bin/bash ############################################################################### # # nbfake - capture command output in a logfile # # nbfake behavior can be changed by setting the following env vars: # NBFAKE_HOST SSH to $NBFAKE_HOST and run command # NBFAKE_LOG Logfile for nbfake output # ############################################################################### if [[ -z "$@" ]]; then cat <<__EOF nbfake usage: nbfake <command to run> nbfake behavior can be changed by setting the following env vars: NBFAKE_HOST SSH to \$NBFAKE_HOST and run command NBFAKE_LOG Logfile for nbfake output __EOF exit fi #============================================================================== # Setup #============================================================================== # Can't always trust $PWD CURRWD=$(pwd) # Make sure nbfake host and logfile are set. Fall back to old-style variable names if [[ -z "$NBFAKE_HOST" && -n "$TARGETHOST" ]]; then MY_NBFAKE_HOST=$TARGETHOST unset TARGETHOST else MY_NBFAKE_HOST=$NBFAKE_HOST unset NBFAKE_HOST fi if [[ -z "$NBFAKE_LOG" && -n "$TARGETHOST_LOGF" ]]; then MY_NBFAKE_LOG=$TARGETHOST_LOGF unset TARGETHOST_LOGF else MY_NBFAKE_LOG=$NBFAKE_LOG unset NBFAKE_LOG fi # Set default nbfake log if [[ -z "$MY_NBFAKE_LOG" ]]; then MY_NBFAKE_LOG=NBFAKE-$(date +%GWW%V.%u_%T) fi #============================================================================== # Run and log #============================================================================== cat <<__EOF >&2 #====================================================================== # NBFAKE logging command to: $MY_NBFAKE_LOG # $* #====================================================================== __EOF if [[ -z "$MY_NBFAKE_HOST" ]]; then # Run locally sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &" else # run remotely ssh -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\"" fi |
Deleted utils/nbload version [4b5138d43f].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added utils/plot-code.scm version [de4d05b676].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | #!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq (use regex srfi-69 srfi-13) (define targs #f) (define files (cddddr (argv))) (let ((targdat (cadddr (argv)))) (if (equal? targdat "-") (set! targs files) (set! targs (string-split targdat ",")))) (define filedat-defns (make-hash-table)) (define filedat-usages (make-hash-table)) (define defn-rx (regexp "^\\s*\\(define\\s+\\(([^\\s\\)]+).*")) (define all-regexs (make-hash-table)) (define all-fns '()) (define (print-err . data) (with-output-to-port (current-error-port) (lambda () (apply print data)))) (print-err "Making graph for files: " (string-intersperse targs ", ")) (print-err "Looking at files: " (string-intersperse files ", ")) ;; Gather the functions ;; (for-each (lambda (fname) (print-err "Processing file " fname) (with-input-from-file fname (lambda () (let loop ((inl (read-line))) (if (not (eof-object? inl)) (let ((match (string-match defn-rx inl))) (if match (let ((fnname (cadr match))) ;; (print " " fnname) (set! all-fns (cons fnname all-fns)) (hash-table-set! filedat-defns fname (cons fnname (hash-table-ref/default filedat-defns fname '()))) )) (loop (read-line)))))))) files) ;; fill up the regex hash (print-err "Make the huge regex hash") (for-each (lambda (fnname) (hash-table-set! all-regexs fnname (regexp (conc "^(|.*[^a-zA-Z]+)" fnname "([^a-zA-Z]+|)$")))) (cons "toplevel" all-fns)) (define breadcrumbs (make-hash-table)) (define (have-function inl) (let loop ((hed (car all-fns)) (tal (cdr all-fns))) (if (string-contains inl hed) #t (if (null? tal) #f (loop (car tal)(cdr tal)))))) (define (look-for-all-calls inl fnname) (if (have-function inl) ;; (string-search have-function-rx inl) (let loop ((hed (car all-fns)) (tal (cdr all-fns)) (res '())) (let ((match (string-match (hash-table-ref all-regexs hed) inl))) (if match (let ((newres (cons hed res))) (if (null? tal) newres (loop (car tal) (cdr tal) newres))) (if (null? tal) res (loop (car tal)(cdr tal) res))))) '())) ;; Gather the usages (print "digraph G {") (define curr-cluster-num 0) (define function-calls '()) (for-each (lambda (fname) (let ((last-func #f)) (print-err "Processing file " fname) (print "subgraph cluster_" curr-cluster-num " {") (set! curr-cluster-num (+ curr-cluster-num 1)) (with-input-from-file fname (lambda () (with-output-to-port (current-error-port) (lambda () (print "Analyzing file " fname))) (print "label=\"" fname "\";") (let loop ((inl (read-line)) (fnname "toplevel") (allcalls '())) (if (eof-object? inl) (begin (set! function-calls (cons (list fnname allcalls) function-calls)) (for-each (lambda (call-name) (hash-table-set! breadcrumbs call-name #t)) allcalls) (print-err "function: " fnname " allcalls: " allcalls)) (let ((match (string-match defn-rx inl))) (if match (let ((func-name (cadr match))) (if last-func (print "\"" func-name "\" -> \"" last-func "\";") (print "\"" func-name "\";")) (set! last-func func-name) (hash-table-set! breadcrumbs func-name #t) (loop (read-line) func-name allcalls)) (let ((calls (look-for-all-calls inl fnname))) (loop (read-line) fnname (append allcalls calls))))))))) (print "}"))) targs) (print-err "breadcrumbs: " (hash-table-keys breadcrumbs)) (print-err "function-calls: " function-calls) (for-each (lambda (function-call) (print-err "function-call: " function-call) (let ((fnname (car function-call)) (calls (cadr function-call))) (for-each (lambda (callname) (print (if (hash-table-ref/default breadcrumbs callname #f) "" "// ") "\"" fnname "\" -> \"" callname "\";")) calls))) function-calls) (print "}") (exit) |
Added widgets.scm version [3d56925ea9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 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 | (require-library srfi-4 iup) (import srfi-4 iup iup-pplot iup-glcanvas) ;; iup-web (define (popup dlg . args) (apply show dlg #:modal? 'yes args) (destroy! dlg)) (define (properties ih) (popup (element-properties-dialog ih)) 'default) (define dlg (dialog (vbox (hbox ; headline (fill) (frame (label " Inspect control and dialog classes " fontsize: 15)) (fill) margin: '0x0) (label "") (label "Dialogs" fontsize: 12) (hbox (button "dialog" action: (lambda (self) (properties (dialog (vbox))))) (button "color-dialog" action: (lambda (self) (properties (color-dialog)))) (button "file-dialog" action: (lambda (self) (properties (file-dialog)))) (button "font-dialog" action: (lambda (self) (properties (font-dialog)))) (button "message-dialog" action: (lambda (self) (properties (message-dialog)))) (fill) margin: '0x0) (hbox (button "layout-dialog" action: (lambda (self) (properties (layout-dialog)))) (button "element-properties-dialog" action: (lambda (self) (properties (element-properties-dialog (create 'user))))) (fill) margin: '0x0) (label "") (label "Composition widgets" fontsize: 12) (hbox (button "fill" action: (lambda (self) (properties (fill)))) (button "hbox" action: (lambda (self) (properties (hbox)))) (button "vbox" action: (lambda (self) (properties (vbox)))) (button "zbox" action: (lambda (self) (properties (zbox)))) (button "radio" action: (lambda (self) (properties (radio (vbox))))) (button "normalizer" action: (lambda (self) (properties (normalizer)))) (button "cbox" action: (lambda (self) (properties (cbox)))) (button "sbox" action: (lambda (self) (properties (sbox (vbox))))) (button "split" action: (lambda (self) (properties (split (vbox) (vbox))))) (fill) margin: '0x0) (label "") (label "Standard widgets" fontsize: 12) (hbox (button "button" action: (lambda (self) (properties (button)))) (button "canvas" action: (lambda (self) (properties (canvas)))) (button "frame" action: (lambda (self) (properties (frame)))) (button "label" action: (lambda (self) (properties (label)))) (button "listbox" action: (lambda (self) (properties (listbox)))) (button "progress-bar" action: (lambda (self) (properties (progress-bar)))) (button "spin" action: (lambda (self) (properties (spin)))) (fill) margin: '0x0) (hbox (button "tabs" action: (lambda (self) (properties (tabs)))) (button "textbox" action: (lambda (self) (properties (textbox)))) (button "toggle" action: (lambda (self) (properties (toggle)))) (button "treebox" action: (lambda (self) (properties (treebox)))) (button "valuator" action: (lambda (self) (properties (valuator "")))) (fill) margin: '0x0) (label "") (label "Additional widgets" fontsize: 12) (hbox (button "cells" action: (lambda (self) (properties (cells)))) (button "color-bar" action: (lambda (self) (properties (color-bar)))) (button "color-browser" action: (lambda (self) (properties (color-browser)))) (button "dial" action: (lambda (self) (properties (dial "")))) (button "matrix" action: (lambda (self) (properties (matrix)))) (fill) margin: '0x0) (hbox (button "pplot" action: (lambda (self) (properties (pplot)))) (button "glcanvas" action: (lambda (self) (properties (glcanvas)))) ;; (button "web-browser" ;; action: (lambda (self) (properties (web-browser)))) (fill) margin: '0x0) (label "") (label "Menu widgets" fontsize: 12) (hbox (button "menu" action: (lambda (self) (properties (menu)))) (button "menu-item" action: (lambda (self) (properties (menu-item)))) (button "menu-separator" action: (lambda (self) (properties (menu-separator)))) (fill) margin: '0x0) (label "") (label "Images" fontsize: 12) (hbox (button "image/palette" action: (lambda (self) (properties (image/palette 1 1 (u8vector->blob (u8vector 0)))))) (button "image/rgb" action: (lambda (self) (properties (image/rgb 1 1 (u8vector->blob (u8vector 0)))))) (button "image/rgba" action: (lambda (self) (properties (image/rgba 1 1 (u8vector->blob (u8vector 0)))))) (button "image/file" action: (lambda (self) (properties ;; same attributes as image/palette (image/palette 1 1 (u8vector->blob (u8vector 0)))))) ;; needs a file in current directory ;(image/file "chicken.ico")))) ; ok ;(image/file "chicken.png")))) ; doesn't work (fill) margin: '0x0) (label "") (label "Other widgets" fontsize: 12) (hbox (button "clipboard" action: (lambda (self) (properties (clipboard)))) (button "timer" action: (lambda (self) (properties (timer)))) (button "spinbox" action: (lambda (self) (properties (spinbox (vbox))))) (fill) margin: '0x0) (fill) (button "E&xit" expand: 'horizontal action: (lambda (self) 'close)) ) margin: '15x15 title: "Iup inspector")) (show dlg) (main-loop) (exit 0) |
Deleted zmq-transport.scm version [dc7b4eceb5].
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |