Megatest

Check-in [211ecbabeb]
Login
Overview
Comment:adding some file-exists? protections and a fix to force-server? from 1.63
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | runaway-servers-fix
Files: files | file ages | folders
SHA1: 211ecbabeb183d2abe6bb9c4930c132e1a24272f
User & Date: bjbarcla on 2017-03-23 12:49:50
Other Links: branch diff | manifest | tags
Context
2017-03-23
13:27
Remove -O4, fixed the force server switch. check-in: c5f5a4ad19 user: matt tags: runaway-servers-fix
12:49
adding some file-exists? protections and a fix to force-server? from 1.63 check-in: 211ecbabeb user: bjbarcla tags: runaway-servers-fix
12:23
merged in matts fix for testsuite; resolved conflicts with common:file-exists? additions check-in: 474e1543fa user: bjbarcla tags: v1.63
12:12
fixed let in common:force-server? check-in: 4df9fd5d18 user: bjbarcla tags: runaway-servers-fix
Changes

Modified common.scm from [fcf4113792] to [fe39965c84].

921
922
923
924
925
926
927
928
























929
930
931
932
933
934
935
     (tags-testpatt
      (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
      tags-testpatt)
     ((and (equal? args-testpatt "%") rtestpatt)
      (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
      rtestpatt)
     (else args-testpatt))))
     
























(define (common:get-linktree)
  (or (getenv "MT_LINKTREE")
      (if *configdat*
	  (configf:lookup *configdat* "setup" "linktree")
	  #f)))

(define (common:args-get-runname)







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







921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
     (tags-testpatt
      (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
      tags-testpatt)
     ((and (equal? args-testpatt "%") rtestpatt)
      (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
      rtestpatt)
     (else args-testpatt))))



(define (common:false-on-exception thunk #!key (message #f))
  (handle-exceptions exn
                     (begin
                       (if message
                           (debug:print-info 0 *default-log-port* message))
                       #f) (thunk) ))

(define (common:file-exists? path-string)
  ;; this avoids stack dumps in the case where 

  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg:  system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
  (common:false-on-exception (lambda () (file-exists? path-string))
                             message: (conc "Unable to access path: " path-string)
                             ))

(define (common:directory-exists? path-string)
  ;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg:  system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
  (common:false-on-exception (lambda () (directory-exists? path-string))
                             message: (conc "Unable to access path: " path-string)
                             ))


(define (common:get-linktree)
  (or (getenv "MT_LINKTREE")
      (if *configdat*
	  (configf:lookup *configdat* "setup" "linktree")
	  #f)))

(define (common:args-get-runname)
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
	   (and *configdat*
		(equal? (configf:lookup *configdat* "setup" "use-cache") "no")))))

;; force use of server?
;;
(define (common:force-server?)
  (let* ((force-setting (configf:lookup "server" "force"))
	(force-type    (if force-setting (string->symbol force-setting) #f)))
    (case force-type
      ((#f)     #f)
      ((always) #t)
      ((test)   (if (args:get-arg "-execute") ;; we are in a test
		    #t
		    #f)))))








|







1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
	   (and *configdat*
		(equal? (configf:lookup *configdat* "setup" "use-cache") "no")))))

;; force use of server?
;;
(define (common:force-server?)
  (let* ((force-setting (configf:lookup "server" "force"))
         (force-type    (if force-setting (string->symbol force-setting) #f)))
    (case force-type
      ((#f)     #f)
      ((always) #t)
      ((test)   (if (args:get-arg "-execute") ;; we are in a test
		    #t
		    #f)))))

Modified launch.scm from [d367925a31] to [c20e1b3984].

778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
	     (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
	 ;; 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") use-cache)
	  (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







|









|







778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
	     (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 (common: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
	 ;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
     ((and mtcachef (common:file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME") use-cache)
	  (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
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
		(begin
		  (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")
		  (exit 2))))))
	;; additional house keeping
	(let* ((linktree (common:get-linktree)))
	  (if linktree
	      (begin
		(if (not (file-exists? linktree))
		    (begin
		      (handle-exceptions
			  exn
			  (begin
			    (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree)
			    (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
			    (exit 1))







|







869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
		(begin
		  (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.")
		  (exit 2))))))
	;; additional house keeping
	(let* ((linktree (common:get-linktree)))
	  (if linktree
	      (begin
	    (if (not (common:file-exists? linktree))
		    (begin
		      (handle-exceptions
			  exn
			  (begin
			    (debug:print-error 0 *default-log-port* "Something went wrong when trying to create linktree dir at " linktree)
			    (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
			    (exit 1))
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
	 (lnktarget (conc lnkpath "/" item-path)))

    ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical
    ;;                                                 rundir   shortdir
    (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path run-id)

    (debug:print 2 *default-log-port* "INFO:\n       lnkbase=" lnkbase "\n       lnkpath=" lnkpath "\n  toptest-path=" toptest-path "\n     test-path=" test-path)
    (if (not (file-exists? linktree))
	(begin
	  (debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree)
	  (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
    ;; create the directory for the tests dir links, this is needed no matter what...
    (if (and (not (directory-exists? lnkbase))
	     (not (file-exists? lnkbase)))
	(handle-exceptions
	 exn
	 (begin
	   (debug:print-error 0 *default-log-port* "Problem creating linktree base at " lnkbase)
	   (print-error-message exn (current-error-port)))
	 (create-directory lnkbase #t)))
    







|




|
|







965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
	 (lnktarget (conc lnkpath "/" item-path)))

    ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical
    ;;                                                 rundir   shortdir
    (rmt:general-call 'test-set-rundir-shortdir run-id lnkpathf test-path testname item-path run-id)

    (debug:print 2 *default-log-port* "INFO:\n       lnkbase=" lnkbase "\n       lnkpath=" lnkpath "\n  toptest-path=" toptest-path "\n     test-path=" test-path)
    (if (not (common:file-exists? linktree))
	(begin
	  (debug:print 0 *default-log-port* "WARNING: linktree did not exist! Creating it now at " linktree)
	  (create-directory linktree #t))) ;; (system (conc "mkdir -p " linktree))))
    ;; create the directory for the tests dir links, this is needed no matter what...
    (if (and (not (common:directory-exists? lnkbase))
	     (not (common:file-exists? lnkbase)))
	(handle-exceptions
	 exn
	 (begin
	   (debug:print-error 0 *default-log-port* "Problem creating linktree base at " lnkbase)
	   (print-error-message exn (current-error-port)))
	 (create-directory lnkbase #t)))