Megatest

Diff
Login

Differences From Artifact [390d72793b]:

To Artifact [e9781be215]:


243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
		  (debug:print 0 "INFO: Not starting job yet - directory " top-path " not found")
		  (thread-sleep! 10)
		  (loop (+ count 1)))))

	  (let ((sighand (lambda (signum)
			   ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
			   (if (eq? signum signal/stop)
			 (debug:print 0 "ERROR: attempt to STOP process. Exiting."))
			   (set! *time-to-exit* #t)
			   (print "Received signal " signum ", cleaning up before exit. Please wait...")
			   (let ((th1 (make-thread (lambda ()
						     (tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED")
						     (print "Killed by signal " signum ". Exiting")
						     (thread-sleep! 1)
						     (exit 1))))







|







243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
		  (debug:print 0 "INFO: Not starting job yet - directory " top-path " not found")
		  (thread-sleep! 10)
		  (loop (+ count 1)))))

	  (let ((sighand (lambda (signum)
			   ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
			   (if (eq? signum signal/stop)
			       (debug:print 0 "ERROR: attempt to STOP process. Exiting."))
			   (set! *time-to-exit* #t)
			   (print "Received signal " signum ", cleaning up before exit. Please wait...")
			   (let ((th1 (make-thread (lambda ()
						     (tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED")
						     (print "Killed by signal " signum ". Exiting")
						     (thread-sleep! 1)
						     (exit 1))))
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
	      (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))







|










|







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
	      (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 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))
429
430
431
432
433
434
435

436


437









438
439
440
441
442
443
444
				 ;; then, if runscript ran ok (or did not get called)
				 ;; do all the ezsteps (if any)
				 (if ezsteps
				     (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
					     ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
					     ;;       ezstep names need a full re-eval here.
					     (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs)))

					    (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())))


				       (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...









				       (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
				       ;; if ezsteps was defined then we are sure to have at least one step but check anyway
				       (if (not (> (length ezstepslst) 0))
					   (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
					   (let loop ((ezstep (car ezstepslst))
						      (tal    (cdr ezstepslst))
						      (prevstep #f))







>
|
>
>
|
>
>
>
>
>
>
>
>
>







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
				 ;; then, if runscript ran ok (or did not get called)
				 ;; do all the ezsteps (if any)
				 (if ezsteps
				     (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
					     ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic
					     ;;       ezstep names need a full re-eval here.
					     (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs)))
					    (ezstepslst (if (hash-table? testconfig)
							    (hash-table-ref/default testconfig "ezsteps" '())
							    #f)))
				       (if testconfig
					   (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
					   (begin
					     (launch:setup)
					     (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n  "
							  (string-intersperse (tests:get-tests-search-path *configdat*) "\n  "))))
				       ;; after all that, still no testconfig? Time to abort
				       (if (not testconfig)
					   (begin
					     (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now")
					     (exit 1)))
				       (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
				       ;; if ezsteps was defined then we are sure to have at least one step but check anyway
				       (if (not (> (length ezstepslst) 0))
					   (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
					   (let loop ((ezstep (car ezstepslst))
						      (tal    (cdr ezstepslst))
						      (prevstep #f))
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
	      (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
	    (mutex-unlock! m)
	    (debug:print 2 "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " 
			 work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
	    (if (not (launch:einf-exit-status exit-info))
		(exit 4)))))))

;; set up the very basics needed for doing anything here.














(define (launch:setup-for-run #!key (force #f))






















  ;; would set values for KEYS in the environment here for better support of env-override but 

  ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to 


  ;; pass on that idea for now




  ;; special case
  (if (or force (not (hash-table? *configdat*)))  ;; no need to re-open on every call

      (begin

	(set! *configinfo* (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
				   (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
							    (get-environment-variable "MT_TARGET")   "/"

							    (get-environment-variable "MT_RUNNAME")  "/"
							    ".megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))



				     (if (file-exists? alistconfig)

					 (list (configf:read-alist alistconfig)


					       (get-environment-variable "MT_RUN_AREA_HOME"))


					 #f))

				   #f) ;; no config cached - give up
			       (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname"))))


				 (if runname (setenv "MT_RUNNAME" runname))







				 (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* ((tmptransport (configf:lookup *configdat* "server" "transport"))
	       (transport    (if tmptransport (string->symbol tmptransport) 'http)))
	  (if (member transport '(http rpc nmsg))
	      (set! *transport-type* transport)
	      (begin
		(debug:print 0 "ERROR: Unrecognised transport " transport)
		(exit))))


	(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 (launch:cache-config)
  ;; if we have a linktree and -runtests and -target and the directory exists dump the config
  ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
  (if (and *configdat* 
	   (or (args:get-arg "-run")
	       (args:get-arg "-runtests")))
      (let* ((linktree (get-environment-variable "MT_LINKTREE"))
	     (target   (common:args-get-target))
	     (runname  (or (args:get-arg "-runname")
			   (args:get-arg ":runname")))
	     (fulldir  (conc linktree "/"
			     target "/"
			     runname)))
	(debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%"))
	(if (file-exists? linktree) ;; can't proceed without linktree
	    (begin
	      (if (not (file-exists? fulldir))
		  (create-directory fulldir #t)) ;; need to protect with exception handler 
	      (if (and target
		       runname
		       (file-exists? fulldir))
		  (let ((tmpfile  (conc fulldir "/.megatest.cfg." (current-seconds)))
			(targfile (conc fulldir "/.megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))
		    (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg")
		    (configf:write-alist *configdat* tmpfile)
		    (system (conc "ln -sf " tmpfile " " targfile))
		    )))))))

(define (get-best-disk confdat testconfig)
  (let* ((disks   (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
		      (hash-table-ref/default confdat "disks" #f)))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
		     (string->number (or m "10000")))))
    (if disks 







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
>
|
>
>
>
>
|
|
>
|
>
|
<
|
>
|
|
>
>
>
|
>
|
>
>
|
>
>
|
>
|
<
>
>
|
>
>
>
>
>
>
>
|
|
|
|
|
>
>
>
>
>
|
>
|
<
<
<
|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







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
	      (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
	    (mutex-unlock! m)
	    (debug:print 2 "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " 
			 work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
	    (if (not (launch:einf-exit-status exit-info))
		(exit 4)))))))

;; gather available information, if legit read configs in this order:
;;
;;   if have cache;
;;      read it a return it
;;   else
;;     megatest.config     (do not cache)
;;     runconfigs.config   (cache if all vars avail)
;;     megatest.config     (cache if all vars avail)
;;   returns:
;;     *toppath*
;;   side effects:
;;     sets; *configdat*    (megatest.config info)
;;           *runconfigdat* (runconfigs.config info)
;;           *configstatus* (status of the read data)
;;
(define (launch:setup #!key (force #f))
  (let* ((toppath  (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
	 (runname  (common:args-get-runname))
	 (target   (common:args-get-target))
	 (linktree (common:get-linktree))
	 (sections (if target (list "default" target) #f)) ;; for runconfigs
	 (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config 
	 (rundir   (if (and runname target linktree)(conc linktree "/" target "/" runname) #f))
	 (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-"  megatest-version "-" megatest-fossil-hash)))
	 (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-"  megatest-version "-" megatest-fossil-hash)))
	 (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir))))
    ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef)
    (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
    (cond
     ;; data was read and cached and available in *configstatus*, toppath has already been set
     ((eq? *configstatus* 'fulldata)
      *toppath*)
     ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
     ((and mtcachef (file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME"))
      (set! *configdat*    (configf:read-alist mtcachef))
      (set! *runconfigdat* (configf:read-alist rccachef))
      (set! *configinfo*   (list *configdat*  (get-environment-variable "MT_RUN_AREA_HOME")))
      (set! *configstatus* 'fulldata)
      (set! *toppath*      (get-environment-variable "MT_RUN_AREA_HOME"))
      *toppath*)
     ;; we have all the info needed to fully process runconfigs and megatest.config
     (mtcachef              
      (let* ((first-pass (find-and-read-config        ;; NB// sets MT_RUN_AREA_HOME as side effect
				  mtconfig
				  environ-patt: "env-override"
				  given-toppath: toppath
				  pathenvvar: "MT_RUN_AREA_HOME"))
	     (first-rundat  (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t 
					 sections: sections)))
	(set! *runconfigdat* first-rundat)
	(if first-pass  ;; 
	    (begin
	      (set! *configdat*  (car first-pass))
	      (set! *configinfo* first-pass)

	      (set! *toppath*    (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
	      (set! toppath      *toppath*)
	      (setenv "MT_RUN_AREA_HOME" *toppath*)
	      ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it
	      (let* ((keys         (rmt:get-keys))
		     (key-vals     (keys:target->keyval keys target))
		     (linktree     (or (getenv "MT_LINKTREE")
				       (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
		     (second-pass  (find-and-read-config
				    mtconfig
				    environ-patt: "env-override"
				    given-toppath: toppath
				    pathenvvar: "MT_RUN_AREA_HOME"))
		     (runconfigdat (begin     ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
				     (for-each (lambda (kt)
						 (setenv (car kt) (cadr kt)))
					       key-vals)
				     (read-config (conc toppath "/runconfigs.config") *runconfigdat* #t 

						  sections: sections))))
		(if cancreate (configf:write-alist runconfigdat rccachef))
		(set! *runconfigdat* runconfigdat)
		(if cancreate (configf:write-alist *configdat* mtcachef))
		(if cancreate (set! *configstatus* 'fulldata))))
	    ;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table
	    (set! *configdat* (make-hash-table))
	    )))
     ;; else read what you can and set the flag accordingly
     (else
      (let* ((cfgdat   (find-and-read-config 
			(or (args:get-arg "-config") "megatest.config")
			environ-patt: "env-override"
			given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
			pathenvvar: "MT_RUN_AREA_HOME")))
	(if cfgdat
	    (let* ((toppath  (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
		   (rdat     (read-config (conc toppath
						"/runconfigs.config") *runconfigdat* #t sections: sections)))
	      (set! *configinfo*   cfgdat)
	      (set! *configdat*    (car cfgdat))
	      (set! *runconfigdat* rdat)
	      (set! *toppath*      toppath)



	      (set! *configstatus* 'partial))
	    (begin
	      (debug:print 0 "ERROR: No " mtconfig " file found. Giving up.")
	      (exit 2))))))
    ;; additional house keeping
    (let* ((linktree (or (getenv "MT_LINKTREE")
			 (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))))
      (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 (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.")))


    *toppath*))





























(define (get-best-disk confdat testconfig)
  (let* ((disks   (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
		      (hash-table-ref/default confdat "disks" #f)))
	 (minspace (let ((m (configf:lookup confdat "setup" "minspace")))
		     (string->number (or m "10000")))))
    (if disks