Megatest

Diff
Login

Differences From Artifact [5f9f026431]:

To Artifact [2803cc22f9]:


548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
	      (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)

	  







|







548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
	      (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_TESTSUITE_NAME" (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)

	  
706
707
708
709
710
711
712
713





714
715
716
717
718
719
720
	 (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







|
>
>
>
>
>







706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
	 (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)))
         (cxt       (hash-table-ref/default *contexts* toppath #f)))

    ;; create our cxt for this area if it doesn't already exist
    (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt)))

    ;; (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
819
820
821
822
823
824
825

826

827
828
829
830
831
832
833
	       (if (not (file-exists? tlink))
		   (create-symbolic-link linktree tlink)))))
	  (begin
	    (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
	    )))
    (if (and *toppath*
	     (directory-exists? *toppath*))

	(setenv "MT_RUN_AREA_HOME" *toppath*)

	(begin
	  (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")))
    (server:set-transport)
    *toppath*))

(define (get-best-disk confdat testconfig)
  (let* ((disks   (or (and testconfig (hash-table-ref/default testconfig "disks" #f))







>
|
>







824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
	       (if (not (file-exists? tlink))
		   (create-symbolic-link linktree tlink)))))
	  (begin
	    (debug:print-error 0 *default-log-port* "linktree not defined in [setup] section of megatest.config")
	    )))
    (if (and *toppath*
	     (directory-exists? *toppath*))
	(begin
	  (setenv "MT_RUN_AREA_HOME" *toppath*)
	  (setenv "MT_TESTSUITE_NAME" (common:get-testsuite-name)))
	(begin
	  (debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")))
    (server:set-transport)
    *toppath*))

(define (get-best-disk confdat testconfig)
  (let* ((disks   (or (and testconfig (hash-table-ref/default testconfig "disks" #f))
1029
1030
1031
1032
1033
1034
1035








1036
1037
1038
1039
1040
1041
1042
;; 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
;;      (launch-test db (cadr status) test-conf))
(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)








  (change-directory *toppath*)
  (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
   (list ;; (list "MT_TEST_RUN_DIR" work-area)
    (list "MT_RUN_AREA_HOME" *toppath*)
    (list "MT_TEST_NAME" test-name)
    ;; (list "MT_ITEM_INFO" (conc itemdat)) 
    (list "MT_RUNNAME"   runname)







>
>
>
>
>
>
>
>







1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
;; 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
;;      (launch-test db (cadr status) test-conf))
(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
  (let loop ((delta        (- (current-seconds) *last-launch*))
	     (launch-delay (string->number (or (configf:lookup *configdat* "setup" "launch-delay") "5"))))
    (if (> launch-delay delta)
	(begin
	  (debug:print-info 0 *default-log-port* "Delaying launch of " test-name " for " (- launch-delay delta) " seconds")
	  (thread-sleep! (- launch-delay delta))
	  (loop (- (current-seconds) *last-launch*) launch-delay))))
  (set! *last-launch* (current-seconds))
  (change-directory *toppath*)
  (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
   (list ;; (list "MT_TEST_RUN_DIR" work-area)
    (list "MT_RUN_AREA_HOME" *toppath*)
    (list "MT_TEST_NAME" test-name)
    ;; (list "MT_ITEM_INFO" (conc itemdat)) 
    (list "MT_RUNNAME"   runname)