Megatest

	 (first   (car loadavg))
	 (next    (cadr loadavg))
	 (adjload (* maxload numcpus))
	 (loadjmp (- first next)))
    (cond
     ((and (> first adjload)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "server start delayed " waitdelay " seconds due to load " first " exceeding max of " adjload " on server " (or remote-host (get-host-name)) " (normalized load-limit: " maxload ") " (if msg msg ""))
      (thread-sleep! waitdelay)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host))
     ((and (> loadjmp numcpus)
	   (> count 0))
      (debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
      (thread-sleep! waitdelay)
      (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1) msg: msg remote-host: remote-host)))))

(define (common:wait-for-homehost-load maxload msg)
  (let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
                     #f
                     (common:get-homehost)))
         (hh     (if hh-dat (car hh-dat) #f))
         (numcpus (common:get-num-cpus hh)))
    (common:wait-for-normalized-load maxload msg hh)))

(define (common:get-num-cpus remote-host)
  (let ((proc (lambda ()
		(let loop ((numcpu 0)
			   (inl    (read-line)))
		  (if (eof-object? inl)
		      numcpu
		      (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
				(+ numcpu 1)
				numcpu)
			    (read-line)))))))
    (if remote-host
	(with-input-from-pipe 
	 (conc "ssh " remote-host " cat /proc/cpuinfo")
	 proc)
	(with-input-from-file "/proc/cpuinfo" proc))))

;; wait for normalized cpu load to drop below maxload
;;
(define (common:wait-for-normalized-load maxload msg remote-host)
  (let ((num-cpus (common:get-num-cpus remote-host)))
    (common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host)))

(define (get-uname . params)
  (let* ((uname-res (process:cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
	 (uname #f))
    (if (null? (car uname-res))

                                   (setup-env-defaults runconfigf run-id (make-hash-table) keydat environ-patt: keystring))
	 			 (make-hash-table))))
	       (testconfig    (begin
				;; (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path)
				(runs:set-megatest-env-vars run-id inkeyvals: keydat inrunname: runname intarget: keystring testname: testname itempath: item-path) ;; these may be needed by the launching process
				(handle-exceptions
				 exn  ;; NOTE: I've no idea why this was written this way. Research, study and fix needed!
				 (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f allow-write-cache: #f)
				 (tests:get-testconfig (db:test-get-testname testdat) item-path test-registry #t allow-write-cache: #f))))
	       (viewlog    (lambda (x)
			     (if (common:file-exists? logfile)
					;(system (conc "firefox " logfile "&"))
				 (dcommon:run-html-viewer logfile)
				 (message-window (conc "File " logfile " not found")))))
	       (view-a-log (lambda (lfile) 
			     (let ((lfilename (conc rundir "/" lfile)))

       (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))
     options)
    data-synced))

(define (db:tmp->megatest.db-sync dbstruct last-update)
  (let* ((mtdb        (dbr:dbstruct-mtdb dbstruct))
	 (tmpdb       (db:get-db dbstruct))
	 (refndb      (dbr:dbstruct-refndb dbstruct))
	 (res         (db:sync-tables (db:sync-all-tables-list dbstruct) last-update tmpdb refndb mtdb)))
    (stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)
    res))

;;;; run-ids
;;    if #f use *db-local-sync* : or 'local-sync-flags
;;    if #t use timestamps      : or 'timestamps
;;
;;  NB// no-sync-db is the db handle, not a flag!
;;

	 db 
	 (conc
	  "SELECT d.id,d.archive_area_name,disk_path,last_df,last_df_time FROM archive_disks AS d
             INNER JOIN archive_blocks AS b ON d.id=b.archive_disk_id
             WHERE b.id IN (" (string-intersperse (map conc res) ",") ") AND
         last_df > ?;")
	 dneeded))
    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
    blocks))
    
;; returns id of the record, register a disk allocated to archiving and record it's last known
;; available space
;;
(define (db:archive-register-disk dbstruct bdisk-name bdisk-path df)
  (let* ((dbdat        (db:get-db dbstruct)) ;; archive tables are in main.db

                                          WHERE archive_disk_id=? AND disk_path=?;"
				   bdisk-id archive-path du))
	  res)
	(begin
	  (sqlite3:execute db "INSERT OR REPLACE INTO archive_blocks (archive_disk_id,disk_path,last_du)
                                                        VALUES (?,?,?);"
			   bdisk-id archive-path (or du 0))
	  (db:archive-register-block-name dbstruct bdisk-id archive-path du: du)))
    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
    res))


;; The "archived" field in tests is overloaded; 0 = not archived, > 0 archived in block with given id
;;
(define (db:test-set-archive-block-id dbstruct run-id test-id archive-block-id)
  (db:with-db
   dbstruct

     (if (string-match (regexp "^[/~]+.*") outputfile) ;; full path?
	 outputfile
	 (begin
	   (debug:print 0 *default-log-port* "WARNING: path given, " outputfile " is relative, prefixing with current directory")
	   (conc (current-directory) "/" outputfile)))
     results)
    ;; brutal clean up
    (stack-push! (dbr:dbstruct-dbstack dbstruct) dbdat)
    (system "rm -rf tempdir")))

;; (db:extract-ods-file db "outputfile.ods" '(("sysname" "%")("fsname" "%")("datapath" "%")) "%")

  "RUNNING" [
     shape="record";
     label="{RUNNING|{n/a|<here> PASS |<here> FAIL}}";
  ]

  "COMPLETED" [
      shape="record";
      label = "{COMPLETED|{PASS | SKIP | WAIVED | FAIL | CHECK| ABORT}}";
  ]


"RUNNING" -> "COMPLETED";
"RUNNING" -> "INCOMPLETE" [label="test dead for > 24hrs"];

	     (not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
	     (not (equal? curr-ip target-host)))
	(begin
	  (debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
	  (setenv "TARGETHOST" target-host)))
      
    (setenv "TARGETHOST_LOGF" logfile)
    (common:wait-for-normalized-load load-limit " delaying server start due to load" target-host) ;; do not try starting servers on an already overloaded machine, just wait forever
    (system (conc "nbfake " cmdln))
    (unsetenv "TARGETHOST_LOGF")
    (if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
    (thread-join! log-rotate)
    (pop-directory)))

;; given a path to a server log return: host port startseconds

					  (not sync-in-progress)
					  (not recently-synced))))
              (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop.  need-sync="need-sync" sync-in-progress=" sync-in-progress
				" should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync
				" sync-done=" sync-done " sync-period=" sync-period)
              (if (and (> sync-period 5)
                       (common:low-noise-print 30 "sync-period"))
                  (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds."))
	      ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced))
	      ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync)
	      (if will-sync (set! *db-sync-in-progress* #t))
	      (mutex-unlock! *db-multi-sync-mutex*)
	      (if will-sync
                  (let (;; (max-sync-duration  (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK!
                        (sync-start         (current-milliseconds)))

;;
;; 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 regex defstruct)

(use trace)
;; (trace-call-sites #t)

(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"
		    "-delay"   ;; how long to wait for unexpected changes to 
		    )
		 `("-tc-repl"
		   )
		 args:arg-hash
		 0))

(defstruct testdat
  (tc-type #f)
  (state   #f)
  (status  #f)
  (overall #f)
  (flowid  #f)
  tctname
  tname
  (event-time #f)
  details
  comment
  duration
  (start-printed #f)
  (end-printed   #f))

;;======================================================================
;; GLOBALS
;;======================================================================

;; Gotta have a global? Stash it in the *global* hash table.
;;
(define *global* (make-hash-table))

(define (tcmt:print tdat flush-mode)
  (let* ((comment  (if (testdat-comment tdat)
		       (conc " message='" (testdat-comment tdat) "'")
		       ""))
	 (details  (if (testdat-details tdat)
		       (conc " details='" (testdat-details tdat) "'")
		       ""))
	 (flowid   (conc " flowId='" (testdat-flowid   tdat) "'"))
	 (duration (conc " duration='" (* 1e3 (testdat-duration tdat)) "'"))
	 (tcname   (conc " name='" (testdat-tctname  tdat) "'"))
	 (state    (string->symbol (testdat-state tdat)))
	 (status   (string->symbol (testdat-status tdat)))
	 (startp   (testdat-start-printed tdat))
	 (endp     (testdat-end-printed   tdat))
	 (etime    (testdat-event-time    tdat))
	 (overall  (case state
		     ((RUNNING)   state)
		     ((COMPLETED) state)
		     (else 'UNK)))
	 (tstmp    (conc " timestamp='" (time->string (seconds->local-time etime) "%FT%T.000") "'")))
    (case overall
      ((RUNNING)
       (if (not startp)
	   (begin
	     (print "##teamcity[testStarted "  tcname flowid tstmp "]")
	     (testdat-start-printed-set! tdat #t))))
      ((COMPLETED)
       (if (not startp) ;; start stanza never printed
	   (begin
	     (print "##teamcity[testStarted " tcname flowid tstmp "]")
	     (testdat-start-printed-set! tdat #t)))
       (if (not endp)
	   (begin
	     (if (member status '(PASS WARN SKIP WAIVED))
		 (print "##teamcity[testFinished" tcname flowid comment details duration "]")
		 (print "##teamcity[testFailed  " tcname flowid comment details "]"))
	     (testdat-end-printed-set! tdat #t))))
      (else
       (if flush-mode
	   (begin
	     (if (not startp)
		 (begin
		   (print "##teamcity[testStarted " tcname flowid tstmp "]")
		   (testdat-start-printed-set! tdat #t)))
	     (if (not endp)
		 (begin
		   (print "##teamcity[testFailed  " tcname flowid comment details "]")
		   (testdat-end-printed-set! tdat #t)))))))
    ;; (print "ERROR: tc-type \"" (testdat-tc-type tdat) "\" not recognised for " tcname)))
    (flush-output)))

;; ;; returns values: flag newlst
;; (define (remove-duplicate-completed  tdats)
;;   (let* ((flag       #f)
;;          (state      (testdat-state      tdat))
;;          (status     (testdat-status     tdat))
;;          (event-time (testdat-event-time tdat))
;;          (tname      (testdat-tname      tdat)))
;;     (let loop ((hed (car tdats))
;;                (tal (cdr tdats))
;;                (new '()))
;;       (if (and (equal? state "COMPLETED")
;;                (equal? tname (testdat-tname hed))
;;                (equal? state (testdat-state hed))) ;; we have a duplicate COMPLETED call
;;           (begin
;;             (set! flag #t) ;; A changed completed
            
;; process the queue of tests gathered so far. List includes one entry for every test so far seen
;; the last record for a test is preserved. Items are only removed from the list if over 15 seconds
;; have passed since it happened. This allows for compression of COMPLETED/FAIL followed by some other
;; state/status
;;
(define (process-queue data age flush-mode)
  ;; here we process tqueue and gather those over 15 seconds (configurable?) old
  (let* ((print-time (- (current-seconds) age)) ;; print stuff over 15 seconds old
         (tqueue-raw (hash-table-ref/default data 'tqueue '()))
         (tqueue     (reverse (delete-duplicates tqueue-raw     ;; REMOVE duplicates by testname and state
                                                 (lambda (a b)
                                                   (and (equal? (testdat-tname a)(testdat-tname b))        ;; need oldest to newest
                                                        (equal? (testdat-state a) (testdat-state b)))))))) ;; "COMPLETED")
    ;; (equal? (testdat-state b) "COMPLETED")))))))
    (if (not (null? tqueue))
        (hash-table-set!
         data
         'tqueue
         (let loop ((hed (car tqueue)) ;; by this point all duplicates by state COMPLETED are removed
                    (tal (cdr tqueue))
                    (rem '()))
           (if (> print-time (testdat-event-time hed)) ;; event happened over 15 seconds ago
               (begin
                 (tcmt:print hed flush-mode)
                 (if (null? tal)
                     rem ;; return rem to be processed in the future
                     (loop (car tal)(cdr tal) rem)))
               (if (null? tal)
                   (cons hed rem) ;; return rem + hed for future processing
                   (loop (car tal)(cdr tal)(cons hed rem)))))))))

                            ;; ##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']
;; 
;; flush; #f, normal call. #t, last call, print out something for NOT_STARTED, etc.
;;

;;;;;;;   (begin
;;;;;;;     (case (string->symbol newstat)
;;;;;;;       ((UNK)       ) ;; do nothing
;;;;;;;       ((RUNNING)   (print "##teamcity[testStarted name='" tctname "' flowId='" flowid "']"))
;;;;;;;       ((PASS SKIP WARN WAIVED) (print "##teamcity[testFinished name='" tctname "' duration='" (* 1e3 duration) "'" cmtstr details " flowId='" flowid "']"))
;;;;;;;       (else
;;;;;;; 	(print "##teamcity[testFailed name='" tctname "' " cmtstr details " flowId='" flowid "']")))
;;;;;;;     (flush-output)

;; (trace rmt:get-tests-for-run)

(define (update-queue-since data run-ids last-update tsname target runname flowid flush) ;; 
  (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 #f last-update #f)))
	   ;; (print "DEBUG: got tests=" tests)
	   (for-each
	    (lambda (test-rec)
	      (let* ((tqueue   (hash-table-ref/default data 'tqueue '())) ;; NOTE: the key is a symbol! This allows keeping disparate info in the one hash, lazy but a quick solution for right now.
		     (is-top   (db:test-get-is-toplevel  test-rec))
		     (tname    (db:test-get-fullname     test-rec))
		     (testname (db:test-get-testname     test-rec))
		     (itempath (db:test-get-item-path    test-rec))
		     (tctname  (if (string=? itempath "") testname (conc testname "." (string-translate itempath "/" "."))))
		     (state    (db:test-get-state        test-rec))
		     (status   (db:test-get-status       test-rec))
		     (etime    (db:test-get-event_time   test-rec))
		     (duration (or (any->number (db:test-get-run_duration test-rec)) 0))
		     (comment  (db:test-get-comment      test-rec))
		     (logfile  (db:test-get-final_logf   test-rec))

                     (hostn    (db:test-get-host         test-rec))
                     (pid      (db:test-get-process_id   test-rec))
		     (newstat  (cond
				((equal? state "RUNNING")   "RUNNING")
				((equal? state "COMPLETED") status)
				(flush   (conc state "/" status))
				(else "UNK")))
		     (cmtstr   (if (and (not flush) comment)
				   comment
				   (if flush
				       (conc "Test ended in state/status=" state "/" status  (if  (string-match "^\\s*$" comment)
												  ", no Megatest comment found."
												  (conc ", Megatest comment=\"" comment "\""))) ;; special case, we are handling stragglers
				       #f)))
		     (details  (if (string-match ".*html$" logfile)
				   (conc *toppath* "/lt/" target "/" runname "/" testname (if (equal? itempath "") "/" (conc "/" itempath "/")) logfile)
				   #f))
		     (prev-tdat (hash-table-ref/default data tname #f)) 
		     (tdat      (if is-top
				    #f
				    (let ((new (or prev-tdat (make-testdat)))) ;; recycle the record so we keep track of already printed items
				      (testdat-flowid-set!     new (or (testdat-flowid new)
                                                                       (if (eq? pid 0)
                                                                           tctname
                                                                           (conc hostn "-" pid))))
				      (testdat-tctname-set!    new tctname)
				      (testdat-tname-set!      new tname)
				      (testdat-state-set!      new state)
				      (testdat-status-set!     new status)
				      (testdat-comment-set!    new cmtstr)
				      (testdat-details-set!    new details)
				      (testdat-duration-set!   new duration)
				      (testdat-event-time-set! new etime) ;; (current-seconds))
				      (testdat-overall-set!    new newstat)



				      (hash-table-set! data tname new)

				      new))))
		(if (not is-top)
		    (hash-table-set! data 'tqueue (cons tdat tqueue)))
                (hash-table-set! data tname tdat)
                ))
            tests)))
       run-ids)
      now))
      
(define (monitor pid)
  (let* ((run-ids '())
	 (testdats (make-hash-table))  ;; each entry is a list of testdat structs
	 (keys    #f)
	 (last-update 0)
	 (target  (or (args:get-arg "-target")
		      (args:get-arg "-reqtarg")))
	 (runname (args:get-arg "-runname"))
	 (tsname  #f)
	 (flowid  (conc target "/" runname))
	 (tdelay  (string->number (or (args:get-arg "-delay") "15"))))
    (if (and target runname)
	(begin
	  (launch:setup)
	  (set! keys (rmt:get-keys))))
    (set! tsname  (common:get-testsuite-name))
    (print "TCMT: for testsuite=" tsname " found runname=" runname ", target=" target ", keys=" keys " and successfully ran launch:setup. Using " flowid " as the flowId.")
    (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
		  (or (not run-ids)
		      (null? run-ids)))
	     (let* ((runs (rmt:get-runs-by-patt keys
						runname 

				       (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 (eq? pidres 0)
	     (begin
	       (if keys
                   (begin
                     (set! last-update (- (update-queue-since testdats run-ids last-update tsname target runname flowid #f) 5))
                     (process-queue testdats tdelay #f)))
               (thread-sleep! 3)
	       (loop))
	     (begin
	       ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids)
	       (print "TCMT: processing any tests that did not formally complete.")
	       (update-queue-since testdats run-ids 0 tsname target runname flowid #t) ;; call in flush mode
               (process-queue testdats 0 #t)
	       (print "TCMT: All done.")
	       ))))))
;;;;; )

;; (trace print-changes-since)

;; (if (not (eq? pidres 0))	  ;; (not exitstatus))
;; 	  (begin
;; 	    (thread-sleep! 3)
;; 	    (loop))
;; 	  (print "Process: megatest " (string-intersperse origargs " ") " is done.")))))
(define (main)

      #f))

;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
;; else read the testconfig file
;;   if have path to test directory save the config as .testconfig and return it
;;
(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t))
  (let* ((use-cache    (common:use-cache?))
	 (cache-path   (tests:get-test-path-from-environment))
	 (cache-file   (and cache-path (conc cache-path "/.testconfig")))
	 (cache-exists (and cache-file
			    (not force-create)  ;; if force-create then pretend there is no cache to read
			    (common:file-exists? cache-file)))
	 (cached-dat   (if (and (not force-create)

								      "pre-launch-env-vars"
								      #f))
				       #f)))
		(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
		(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
		(if (and testexists
			 cache-file
			 (file-write-access? cache-path)
			 allow-write-cache)
		    (let ((tpath (conc cache-path "/.testconfig")))
		      (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
                      (if (not (common:in-running-test?))
                          (configf:write-alist tcfg tpath))))
		tcfg))))))
  
;; sort tests by priority and waiton

#!/bin/bash

(cd ../..;make install) && RN=tcmt_m;megatest -remove-runs -target ubuntu/nfs/none -runname tcmt_m -testpatt %;\
    tcmt -run -target ubuntu/nfs/none -runname tcmt_m -testpatt % -rerun-clean 2>&1 | tee all.log | grep teamcity | tee teamcity.log