32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
(require-library mutils)
;; (use zmq)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
|
<
>
>
|
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
(require-library mutils)
;; (use zmq)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
(declare (uses db))
;; (declare (uses dcommon))
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses ftail))
(import ftail)
;;(declare (uses mtconfigf))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
|
569
570
571
572
573
574
575
576
577
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
|
(printf "Sending signal/term to ~A\n" pid)
(process-signal pid signal/term))))))
(process:children #f))
(original-exit exit-code)))))
;; for some switches always print the command to stderr
;;
(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status")
(debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
;; some switches imply homehost. Exit here if not on homehost
;;
(let ((homehost-required (list "-cleanup-db" "-server")))
(if (apply args:any? homehost-required)
(if (not (common:on-homehost?))
(for-each
(lambda (switch)
(if (args:get-arg switch)
(begin
(debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
(exit 1))))
homehost-required))))
;;======================================================================
;; Misc setup stuff
;;======================================================================
(debug:setup)
(if (args:get-arg "-logging")(set! *logging* #t))
(if (debug:debug-mode 3) ;; we are obviously debugging
(set! open-run-close open-run-close-no-exception-handling))
(if (args:get-arg "-itempatt")
(let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
(debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
|
|
|
|
>
|
570
571
572
573
574
575
576
577
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
|
(printf "Sending signal/term to ~A\n" pid)
(process-signal pid signal/term))))))
(process:children #f))
(original-exit exit-code)))))
;; for some switches always print the command to stderr
;;
(if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status")
(debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
;; some switches imply homehost. Exit here if not on homehost
;;
(let ((homehost-required (list "-cleanup-db" "-server")))
(if (apply args:any-defined? homehost-required)
(if (not (common:on-homehost?))
(for-each
(lambda (switch)
(if (args:get-arg switch)
(begin
(debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
(exit 1))))
homehost-required))))
;;======================================================================
;; Misc setup stuff
;;======================================================================
(debug:setup)
(if (args:get-arg "-logging")
(debug:add-logging-callback db:log-event))
(if (debug:debug-mode 3) ;; we are obviously debugging
(set! open-run-close open-run-close-no-exception-handling))
(if (args:get-arg "-itempatt")
(let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt"))))
(debug:print 0 *default-log-port* "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval)
|
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
|
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f))
(change-directory testpath)
(if (not (launch:setup))
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(if (and state status)
(let ((comment (launch:load-logpro-dat run-id test-id step)))
;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
|
>
>
>
>
>
|
|
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
|
(runscript (assoc/default 'runscript cmdinfo))
(db-host (assoc/default 'db-host cmdinfo))
(run-id (assoc/default 'run-id cmdinfo))
(test-id (assoc/default 'test-id cmdinfo))
(itemdat (assoc/default 'itemdat cmdinfo))
(work-area (assoc/default 'work-area cmdinfo))
(db #f))
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "ERROR: the work directory " testpath " has disappeared or become unreadable! Cannot proceed, exiting now.")
(exit 1))
(change-directory testpath))
(if (not (launch:setup))
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(if (and state status)
(let ((comment (launch:load-logpro-dat run-id test-id step)))
;; (rmt:test-set-log! run-id test-id (conc stepname ".html"))))
|