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
457
458
459
460
|
;; 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
;; got here but there are race condiitions - re-do all setup and try one more time
(if (launch:setup)
(begin
(launch:cache-config)
(set! testconfig (full-runconfigs-read))) ;; redunantly redundant, but does it resolve the race?
(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
|
|
<
>
|
>
>
|
>
>
|
|
>
|
<
<
|
>
>
>
>
>
|
<
>
|
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
|
>
>
|
>
>
>
>
>
>
>
>
>
|
|
|
|
|
>
>
>
>
|
>
|
<
<
<
|
|
<
<
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
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
|
(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* ((runname (common:args-get-runname))
(target (common:args-get-target))
(linktree (common:get-linktree))
(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)
(cond
;; data was read and cached and available in *configstatus*
((eq? *configstatus* 'fulldata)
*toppath*)
;; if mtcachef exists just read it
((and mtcachef (file-exists? mtcachef))
(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)
*toppath*)
;; we have all the info needed to fully process runconfigs and megatest.config
(mtcachef
(let ((first-pass (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 first-pass
(begin
(set! *configdat* (car first-pass))
(set! *configinfo* first-pass)
(set! *toppath* (cadr first-pass))
;; 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 (if target (keys:target->keyval keys target) #f))
(sections (if target (list "default" target) #f)) ;; for runconfigs
(linktree (or (getenv "MT_LINKTREE")
(if *configdat* (configf:lookup *configdat* "setup" "linktree") #f)))
(runconfigdat (begin
(setenv "MT_RUN_AREA_HOME" *toppath*)
(if key-vals
(for-each (lambda (kt)
(setenv (car kt) (cadr kt)))
key-vals))
(read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections))))
(if cancreate (configf:write-alist runconfigdat rccachef))
(set! *runconfigdat* runconfigdat)
(let ((second-pass (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 cancreate (configf:write-alist (car second-pass) mtcachef))
(set! *configdat* (car second-pass))
(set! *toppath* (cadr second-pass))
(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"))
(sections (if target (list "default" target) #f))
(rdat (read-config (conc (or *toppath* (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat))
"/runconfigs.config") #f #t sections: sections)))
(set! *configinfo* cfgdat)
(set! *configdat* (car cfgdat))
(set! *runconfigdat* rdat)
(set! *toppath* (cadr cfgdat))
(set! *configstatus* 'partial))))
;; final house keeping
(let* ((keys (rmt:get-keys))
(key-vals (if target (keys:target->keyval keys target) #f))
(sections (if target (list "default" target) #f)) ;; for runconfigs
(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
|