Megatest

(use posix-extras pathname-expand files)


(import commonmod
	debugprint
	rmtmod
	(prefix mtargs args:))
	
(define (remove-server-files directory-path)
  (let ((files (glob (string-append directory-path "/server*"))))
    (for-each delete-file* files)))
(include "common_records.scm")

(define (remove-files filespec)
  (let ((files (glob filespec)))
    (for-each delete-file* files)))

(define (stop-the-train)
  (thread-start! (make-thread (lambda ()
				(let loop ()
				  (if (and *toppath*
					   (file-exists? (conc *toppath*"/stop-the-train")))
				      (let* ((msg (conc "ERROR: found file "*toppath*"/stop-the-train, exiting immediately")))
					;; yes, print to current-output-port AND *default-log-port*, annoying but necessary I think
					(print msg)
                                        (remove-server-files (conc *toppath* "/logs"))
					(debug:print 0 *default-log-port* msg)
                                        (remove-files (conc *toppath* "/logs/server*"))
                                        (remove-files (conc *toppath* "/.servinfo/*"))
                                        (remove-files (conc *toppath* "/.mtdb/*lock"))
					(exit 1)))
				  (thread-sleep! 5)
				  (loop))))))

  (- megatest-version (common:get-last-run-version-number)))

(define (common:version-changed?)
  (not (equal? (common:get-last-run-version)
               (common:version-signature))))


;; From 1.70 to 1.81, db's are compatible.
;;
;; BUG: This logic is almost certainly not quite correct.
;;
(define (common:api-changed?)

  (let* ((megatest-major-version (substring (->string megatest-version) 0 4))
	 (run-major-version (substring (conc (common:get-last-run-version)) 0 4)))

    (and (not (member megatest-major-version '("1.81" "1.80")))
	 (not (equal? megatest-major-version run-major-version)))))



;;======================================================================
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct #!key (full #f))
  (case (rmt:transport-mode)

	 (sort (hash-table-keys directories) (lambda (a b)(> (string-length a)(string-length b))))))
    ))

;;======================================================================
;; E N V I R O N M E N T   V A R S
;;======================================================================

(define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES" "HOSTNAME" "PROMPT_COMMAND")))
  ;;(bb-check-path msg: "save-environment-as-files entry")
  (let ((envvars (get-environment-variables))
        (whitesp (regexp "[^a-zA-Z0-9_\\-:,\\.\\/%$]"))
	(mungeval (lambda (val)
		    (cond
		     ((eq? val #t) "") ;; convert #t to empty string
		     ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one

;; 
;; [hosts]
;; arm cubie01 cubie02
;; x86_64 zeus xena myth01
;; allhosts #{g hosts arm} #{g hosts x86_64}
;; 
;; [host-types]
;; C/M/A      lets megatest know this launcher provides C cores, M bytes memory for architecture A 
;; 2/2G/arm   smart -cores 2 -memory 2G -arch arm
;; general #MTLOWESTLOAD #{g hosts allhosts}
;; arm     #MTLOWESTLOAD #{g hosts arm}
;; nbgeneral nbjob run JOBCOMMAND -log $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME.$MT_TESTNAME-$MT_ITEM_PATH.lgo
;;
;; NOTE: host-rules is ONLY used for MTLOWESTLOAD
;;
;; [host-rules]
;; # maxnload   => max normalized load
;; # maxnjobs   => max jobs per cpu
;; # maxjobrate => max jobs per second
;; general maxnload=1.1; maxnjobs=1.2; maxjobrate=0.1 
;; 
;; [launchers]
;; envsetup general
;; xor/%/n 2/2G/arm
;; % nbgeneral
;; 
;; [jobtools]
;; # if defined and not "no" flexi-launcher will bypass "launcher" unless no match.
;; flexi-launcher yes  
;; launcher nbfake
;; mode adjutant|normal (default is normal)
;; 
;;
;; mode is 'normal (i.e. directly use launcher) or 'adjutant (i.e. use adjutant)
;;
(define (common:get-launcher configdat testname itempath mode)
  (let ((fallback-launcher (configf:lookup configdat "jobtools" "launcher")))
    (if (and (configf:lookup configdat "jobtools" "flexi-launcher") ;; overrides launcher
	     (not (equal? (configf:lookup configdat "jobtools" "flexi-launcher") "no")))
	(let* ((launchers         (hash-table-ref/default configdat "launchers" '())))
	  (if (null? launchers)
	      fallback-launcher
	      (let loop ((hed (car launchers))
			 (tal (cdr launchers)))
		(let ((patt      (car hed))
		      (host-type (cadr hed)))
		  (if (tests:match patt testname itempath) ;; have a launcher match for this test
		      (begin
			(debug:print-info 2 *default-log-port* "Have flexi-launcher match for " testname "/" itempath " = " host-type)
			(let ((launcher (configf:lookup configdat "host-types" host-type))) ;; find the actual launcher from the host-types table
			  ;; if we are in adjutant mode then we want to return both host-type and launcher
			  (if launcher
			      (let* ((launcher-parts (string-split launcher))
				     (launcher-exe   (car launcher-parts)))
				(if (equal? launcher-exe "#MTLOWESTLOAD") ;; this is our special case, we will find the lowest load and craft a nbfake commandline
				    (let host-loop ((targ-host (common:get-least-loaded-host (cdr launcher-parts) host-type configdat))
						    (count     100))
				      (if targ-host
					  (conc "remrun " targ-host)
					  (if (> count 0)
					      
					      (begin
						(debug:print 0 *default-log-port* "INFO: Waiting for a host for host-type " host-type)
						(thread-sleep! (- 101 count))
						(host-loop (common:get-least-loaded-host (cdr launcher-parts) host-type configdat)
							   (- count 1)))
					      (begin
						(debug:print 0 *default-log-port* "FATAL: Failed to find a host from #MTLOWESTLOAD for host-type " host-type)
						(exit)))))
				    (case mode
				      ((adjutant) (list host-type launcher))
				      (else       launcher))))
			      (begin
				(debug:print-info 0 *default-log-port* "WARNING: no launcher found for host-type " host-type)
				(if (null? tal)
				    fallback-launcher
				    (loop (car tal)(cdr tal)))))))
		      ;; no match, try again
		      (if (null? tal)