Megatest

Check-in [d7a2ec4dce]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Cherry-picked fix for bad defense against NFS directory propagation delays into v1.64
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.64
Files: files | file ages | folders
SHA1: d7a2ec4dce709afdf83b32e1b610ed9ebf8c927d
User & Date: matt on 2017-10-17 22:01:06
Other Links: branch diff | manifest | tags
Context
2017-10-18
17:06
added exception handler around trigger handler that was stack dumping for asicqa check-in: 50fc48a28b user: bjbarcla tags: v1.64, v1.6434
2017-10-17
22:01
Cherry-picked fix for bad defense against NFS directory propagation delays into v1.64 check-in: d7a2ec4dce user: matt tags: v1.64
2017-10-13
10:39
Using set-state-status with preclean instead of actual removal of run in the CleanRunExecute button of the test control panel check-in: b0128aaf09 user: mrwellan tags: v1.64
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified launch.scm from [0c1e4ef13e] to [c7aa39b563].

︙
454
455
456
457
458
459
460










461



























462
463
464
465
466
467
468
469

470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529

530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564

454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470

471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508


























































509







510




















511
512
513
514
515
516
517








+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








+


-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








                                  (if (substring-index "/" runscript)
                                      runscript ;; use unadultered if contains slashes
                                      (let ((fulln (conc work-area "/" runscript)))
	                                  (if (and (common:file-exists? fulln)
                                                   (file-execute-access? fulln))
                                              fulln
                                              runscript))))) ;; assume it is on the path
               (check-work-area           (lambda ()
                                            ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
                                            (let loop ((count 0))
                                              (if (or (common:directory-exists? work-area)
                                                      (> count 10))
                                                  (change-directory work-area)
                                                  (begin
                                                    (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
                                                    (thread-sleep! 10)
                                                    (loop (+ count 1)))))
	       ) ;; (rollup-status 0)

                                            (if (not (string=?  (common:real-path work-area)(common:real-path (current-directory))))
                                                (begin
                                                  (debug:print 0 *default-log-port*
                                                               "INFO: we are expecting to be in directory " work-area "\n"
                                                               "     but we are actually in the directory " (current-directory) "\n"
                                                               "     doing another change dir.")
                                                  (change-directory work-area)))
                                            
                                            ;; spot check that the files in testpath are available. Too often NFS delays cause problems here.
                                            (let ((files      (glob (conc testpath "/*")))
                                                  (bad-files '()))
                                              (for-each
                                               (lambda (fullname)
                                                 (let* ((fname (pathname-strip-directory fullname))
                                                        (targn (conc work-area "/" fname)))
                                                   (if (not (file-exists? targn))
                                                       (set! bad-files (cons fname bad-files)))))
                                               files)
                                              (if (not (null? bad-files))
                                                  (begin
                                                    (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.")
                                                    (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", "))
                                                    (launch:test-copy testpath work-area))))
                                            ;; one more time, change to the work-area directory
                                            (change-directory work-area)))
	       ) ;; let*

	  (if contour (setenv "MT_CONTOUR" contour))
	  
	  ;; immediated set some key variables from CMDINFO data, yes, these will be set again below ...
	  ;;
	  (setenv "MT_TESTSUITENAME" areaname)
	  (setenv "MT_RUN_AREA_HOME" top-path)
	  (set! *toppath* top-path)
          (change-directory *toppath*) ;; temporarily switch to the run area home
	  (setenv "MT_TEST_RUN_DIR"  work-area)

	;;    ;; On NFS it can be slow and unreliable to get needed startup information.
	;;    ;;  i. Check if we are on the homehost, if so, proceed
	;;    ;; ii. Check if host and port passed in via CMDINFO are valid and if
	;;    ;;     possible use them.
	;;    (let ((bestadrs (server:get-best-guess-address (get-host-name)))
	;;    	(needcare #f))
	;;      (if (equal? homehost bestadrs) ;; we are likely on the homehost
	;;    	(debug:print-info 0 *default-log-port* "test " test-name " appears to be running on the homehost " homehost)
	;;    	(let ((host-port (if serverurl (string-split serverurl ":") #f)))
	;;    	  (if (not *runremote*)(set! *runremote* (make-remote))) ;; init *runremote*
	;;    	  (if (string? homehost)
	;;    	      (if (and host-port
	;;    		       (> (length host-port) 1))
	;;    		  (let* ((host      (car host-port))
        ;;                           (port      (cadr host-port))
        ;;                           (start-res (http-transport:client-connect host port))
        ;;                           (ping-res  (rmt:login-no-auto-client-setup start-res)))
	;;    		    (if (and start-res
	;;    			     ping-res)
	;;    			;; (begin ;; let ((url  (http-transport:server-dat-make-url start-res)))
	;;    			(begin
	;;    			  (remote-conndat-set! *runremote* start-res)
	;;    			  ;; (remote-server-url-set! *runremote* url)
	;;    			  ;; (if (server:ping url)
	;;    			  (debug:print-info 0 *default-log-port* "connected to " host ":" port " using CMDINFO data."))
	;;    			(begin
	;;    			  (debug:print-info 0 *default-log-port* "have CMDINFO data but failed to connect to " host ":" port)
	;;    			  (set! *runremote* #f))
	;;    			  ;; (remote-conndat-set! *runremote* #f))
	;;    			))
	;;    		  (begin
	;;    		    (set! *runremote* #f)
	;;    		    (debug:print-info 0 *default-log-port* (if host-port
	;;    							       (conc "received invalid host-port information " host-port)
	;;    							       "no host-port information received"))
	;;    		    ;; potential for bad situation if simultaneous starting of hundreds of jobs on servers, set needcare.
	;;    		    (set! needcare #t)))
	;;    	      (begin
	;;    		(set! *runremote* #f)
	;;    		(debug:print-info 0 *default-log-port* "received no homehost information. Please report this to support as it should not happen.")
	;;    		(set! needcare #t)))))
	;;      (if needcare  ;; due to very slow NFS we will do a brute force mkdir to ensure that the directory inode it truly available on this host
	;;    	(let ((logdir (conc top-path "/logs"))) ;; we'll try to create this directory
	;;    	  (handle-exceptions
	;;    	      exn
	;;    	      (debug:print 0 *default-log-port* "Failed to create directory " logdir " expect problems, message: " ((condition-property-accessor 'exn 'message) exn))
	;;    	    (create-directory logdir #t)))))
	;;    	  
	  ;; NFS might not have propagated the directory meta data to the run host - give it time if needed
	  (let loop ((count 0))
	    (if (or (common:directory-exists? work-area)
		    (> count 10))
		(change-directory work-area)
		(begin
		  (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
		  (thread-sleep! 10)
		  (loop (+ count 1)))))

	  (launch:setup) ;; should be properly in the run area home now
          (if (not (string=?  (common:real-path work-area)(common:real-path (current-directory))))
              (begin
                (debug:print 0 *default-log-port*
                             "INFO: we are expecting to be in directory " work-area "\n"
                             "     but we are actually in the directory " (current-directory) "\n"
                             "     doing another change dir.")
                (change-directory work-area)))
          
	  ;; spot check that the files in testpath are available. Too often NFS delays cause problems here.
	  (let ((files      (glob (conc testpath "/*")))
		(bad-files '()))
	    (for-each
	     (lambda (fullname)
	       (let* ((fname (pathname-strip-directory fullname))
                      (targn (conc work-area "/" fname)))
		 (if (not (file-exists? targn))
		     (set! bad-files (cons fname bad-files)))))
	     files)
	    (if (not (null? bad-files))
                (begin
                  (debug:print 0 *default-log-port* "INFO: test data from " testpath " not copied properly or filesystem problems causing data to not be found. Re-running the copy command.")
                  (debug:print 0 *default-log-port* "INFO: missing files from " work-area ": " (string-intersperse bad-files ", "))
                  (launch:test-copy testpath work-area))))

          ;; one more time, change to the work-area directory
          (change-directory work-area)
          
	  (launch:setup) ;; should be properly in the top-path now
	  (set! tconfigreg (tests:get-all))
	  (let ((sighand (lambda (signum)
			   ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
			   (if (eq? signum signal/stop)
			       (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
			   (set! *time-to-exit* #t)
			   (print "Received signal " signum ", cleaning up before exit. Please wait...")
︙
615
616
617
618
619
620
621




622
623
624
625
626
627
628

568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585








+
+
+
+








	  ;; one of these is defunct/redundant ...
	  (if (not (launch:setup force-reread: #t))
	      (begin
		(debug:print 0 *default-log-port* "Failed to setup, exiting") 
		;; (sqlite3:finalize! db)
		;; (sqlite3:finalize! tdb)
		(exit 1)))
          ;; validate that the test run area is available
          (check-work-area)
          
          ;; still need to go back to run area home for next couple steps
	  (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))))
︙
647
648
649
650
651
652
653



654
655
656
657
658
659
660

604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620








+
+
+








	    (if (or (common:file-exists? work-area)
		    (> count 10))
		(change-directory work-area)
		(begin
		  (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found")
		  (thread-sleep! 10)
		  (loop (+ count 1)))))

          ;; now we can switch to the work-area?
          (change-directory work-area)
          ;;(bb-check-path msg: "launch:execute post block 1.5")
	  ;; (change-directory work-area) 
	  (set! keyvals    (keys:target->keyval keys target))
	  ;; apply pre-overrides before other variables. The pre-override vars must not
	  ;; clobbers things from the official sources such as megatest.config and runconfigs.config
	  (if (string? set-vars)
	      (let ((varpairs (string-split set-vars ",")))
︙

This page was generated in about 0.11s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00