Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -52,10 +52,44 @@ csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard mtut: $(OFILES) mtut.scm csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut +TCMTOBJS = \ + api.o \ + archive.o \ + cgisetup/models/pgdb.o \ + client.o \ + common.o \ + configf.o \ + daemon.o \ + db.o \ + env.o \ + http-transport.o \ + items.o \ + keys.o \ + launch.o \ + lock-queue.o \ + margs.o \ + mt.o \ + megatest-version.o \ + ods.o \ + portlogger.o \ + process.o \ + rmt.o \ + rpc-transport.o \ + runconfig.o \ + runs.o \ + server.o \ + tasks.o \ + tdb.o \ + tests.o \ + + +tcmt : $(TCMTOBJS) tcmt.scm + csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt + # install documentation to $(PREFIX)/docs # DOES NOT REBUILD DOCS # $(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html mkdir -p $(PREFIX)/share/docs @@ -114,10 +148,17 @@ $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut $(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil chmod a+x $(PREFIX)/bin/mtutil + +$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt + $(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt + +$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper + utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt + chmod a+x $(PREFIX)/bin/tcmt # $(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard # $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard # $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper @@ -193,11 +234,13 @@ install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ - $(PREFIX)/share/db/mt-pg.sql $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/newdashboard + $(PREFIX)/share/db/mt-pg.sql $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/tcmt + +# $(PREFIX)/bin/newdashboard $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -11,11 +11,11 @@ (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) -(declare (uses tdb)) +;; (declare (uses tdb)) (declare (uses http-transport)) ;;(declare (uses nmsg-transport)) (include "common_records.scm") ;; ADDED tcmt.scm Index: tcmt.scm ================================================================== --- /dev/null +++ tcmt.scm @@ -0,0 +1,160 @@ +;; Copyright 2006-2017, 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. +;; +;;====================================================================== +;; +;; Wrapper to enable running Megatest flows under teamcity +;; +;; 1. Run the megatest process and pass it all the needed parameters +;; 2. Every five seconds check for state/status changes and print the info +;; + +(use srfi-1 posix srfi-69 srfi-18) + +(declare (uses margs)) +(declare (uses rmt)) +(declare (uses common)) +(declare (uses megatest-version)) + +(include "megatest-fossil-hash.scm") +(include "db_records.scm") + +(define origargs (cdr (argv))) +(define remargs (args:get-args + (argv) + `( "-target" + "-reqtarg" + "-runname" + ) + `("-tc-repl" + ) + args:arg-hash + 0)) + +;; ##teamcity[testStarted name='suite.testName'] +;; ##teamcity[testStdOut name='suite.testName' out='text'] +;; ##teamcity[testStdErr name='suite.testName' out='error text'] +;; ##teamcity[testFailed name='suite.testName' message='failure message' details='message and stack trace'] +;; ##teamcity[testFinished name='suite.testName' duration='50'] +;; + +(define (print-changes-since data run-ids last-update tsname target runname) + (let ((now (current-seconds))) + (handle-exceptions + exn + (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn))) + (for-each + (lambda (run-id) + (let* ((tests (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f 'shortlist last-update #f))) + ;; (print "DEBUG: got tests=" tests) + (for-each + (lambda (testdat) + (let* ((testn (db:test-get-fullname testdat)) + (testname (db:test-get-testname testdat)) + (itempath (db:test-get-item-path testdat)) + (tctname (if (string=? itempath "") testname (conc testname "." itempath))) + (state (db:test-get-state testdat)) + (status (db:test-get-status testdat)) + (duration (db:test-get-run_duration testdat)) + (comment (db:test-get-comment testdat)) + (logfile (db:test-get-final_logf testdat)) + (prevstat (hash-table-ref/default data testn #f)) + (newstat (if (equal? state "RUNNING") + "RUNNING" + (if (equal? state "COMPLETED") + status + "UNK")))) + ;; (print "DEBUG: testn=" testn " state=" state " status=" status " prevstat=" prevstat " newstat=" newstat) + (if (or (not prevstat) + (not (equal? prevstat newstat))) + (begin + (case (string->symbol newstat) + ((RUNNING) (print "##teamcity[testStarted name='" tctname "']")) + ((PASS SKIP) (print "##teamcity[testFinished name='" tctname "' duration='" duration "']")) + (else + (print "##teamcity[testFailed name='" tctname "' message='" comment "' details='" logfile "']"))) + (hash-table-set! data testn newstat))))) + tests))) + run-ids)) + now)) + +(define (monitor pid) + (let ((run-ids #f) + (testdat (make-hash-table)) + (keys #f) + (last-update 0) + (target (or (args:get-arg "-target") + (args:get-arg "-reqtarg"))) + (runname (args:get-arg "-runname")) + (tsname (common:get-testsuite-name))) + (if (and target runname) + (begin + (launch:setup) + (set! keys (rmt:get-keys)))) + (let loop () + (handle-exceptions + exn + ;; (print "Process done.") + (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn))) + (let-values (((pidres exittype exitstatus) + (process-wait pid #t))) + (if (and keys + (not run-ids)) + (let* ((runs (rmt:get-runs-by-patt keys + (args:get-arg "-runname") + (or (args:get-arg "-target")(args:get-arg "-reqtarg")) + #f ;; offset + #f ;; limit + #f ;; fields + 0 ;; last-update + )) + (header (db:get-header runs)) + (rows (db:get-rows runs)) + (run-ids-in (map (lambda (row) + (db:get-value-by-header row header "id")) + rows))) + (set! run-ids run-ids-in))) + ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids) + (if keys + (set! last-update (print-changes-since testdat run-ids last-update tsname target runname))) + (if (eq? pidres 0) + (begin + (thread-sleep! 3) + (loop)) + (begin + ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids) + (print "TCMT: All done.") + ))))))) + +;; (if (not (eq? pidres 0)) ;; (not exitstatus)) +;; (begin +;; (thread-sleep! 3) +;; (loop)) +;; (print "Process: megatest " (string-intersperse origargs " ") " is done."))))) +(define (main) + (let* ((mt-done #f) + (pid #f) + (th1 (make-thread (lambda () + (print "Running megatest " (string-intersperse origargs " ")) + (set! pid (process-run "megatest" origargs))) + "Megatest job")) + (th2 (make-thread (lambda () + (monitor pid)) + "Monitor job"))) + (thread-start! th1) + (thread-sleep! 1) ;; give the process time to get going + (thread-start! th2) + (thread-join! th2))) + +(if (args:get-arg "-tc-repl") + (repl) + (main)) + +;; (process-wait) +