1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
|
res)
'()))
;; clear vars matching pattern, run proc, set vars back
;; if proc is a string run that string as a command with
;; system.
;;
(define (common:without-vars proc . var-patts)
(let ((vars (make-hash-table)))
(for-each
(lambda (vardat) ;; each env var
(for-each
(lambda (var-patt)
(if (string-match var-patt (car vardat))
|
>
>
>
|
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
|
res)
'()))
;; clear vars matching pattern, run proc, set vars back
;; if proc is a string run that string as a command with
;; system.
;;
(define (common:without-vars proc . var-patts)
(let ((vars (make-hash-table)))
(for-each
(lambda (vardat) ;; each env var
(for-each
(lambda (var-patt)
(if (string-match var-patt (car vardat))
|
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
|
((string? proc)(system proc))
(proc (proc)))
(hash-table-for-each
vars
(lambda (var val)
(setenv var val)))
vars))
(define (common:run-a-command cmd #!key (with-vars #f))
(let* ((pre-cmd (dtests:get-pre-command))
(post-cmd (dtests:get-post-command))
(fullcmd (if (or pre-cmd post-cmd)
(conc pre-cmd cmd post-cmd)
(conc "viewscreen " cmd))))
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
|
((string? proc)(system proc))
(proc (proc)))
(hash-table-for-each
vars
(lambda (var val)
(setenv var val)))
vars))
(define (common:get-param-mapping #!key (flavor #f))
"returns alist mapping string keys in testconfig/subrun to megatest command line switches; if flavor is switch-symbol, maps tcmt symbolic switches to megatest switches"
(let ((default '(("tag-expr" . "-tagexpr")
("mode-patt" . "-modepatt")
("run-name" . "-runname")
("contour" . "-contour")
("mode-patt" . "-mode-patt")
("test-patt" . "-testpatt")
("msg" . "-m")
("new" . "-set-state-status"))))
(if (eq? flavor 'switch)
(map (lambda (x)
(cons (string->symbol (conc "-" (car x)) (cdr x))))
default)
default)))
(define (common:sub-megatest-selector-switches test-run-dir)
(let* ((switch-def-alist (common:get-param-mapping flavor: 'config)))
(subrunfile (conc test-run-dir "/testconfig.subrun" ))
(subrundata (with-input-from-file subrunfile read))
(subrunconfig (configf:alist->config subrundata)))
;; note - get precmd from subrun section
;; apply to submegatest commands
(apply append
(filter-map (lambda (item)
(let ((config-key (car item))
(switch (cdr item))
(val (configf:lookup subrunconfig switch)))
(if val
(list switch val)
#f)))
switch-def-alist))))
(define (common:sub-megatest-run test-run-dir switches #!key (logfile #f))
(let* ((real-logfile (or logfile (conc (test-run-dir) "/subrun-"
(string-substitute "[/*]" "_" (string-intersperse switches "^"))"-"
(number->string (current-seconds)) ".log")))
(selector-switches (common:sub-megatest-selector-switches test-run-dir))
(cmd-list `("megatest" ,@selector-switches ,@switches "-log" ,real-logfile))
)
(call-with-environment-variables
(list (cons "PATH" (conc (get-environment-variable "PATH") ":.")))
(lambda ()
(common:without-vars proc "^MT_.*")
))))
(define (common:run-a-command cmd #!key (with-vars #f))
(let* ((pre-cmd (dtests:get-pre-command))
(post-cmd (dtests:get-post-command))
(fullcmd (if (or pre-cmd post-cmd)
(conc pre-cmd cmd post-cmd)
(conc "viewscreen " cmd))))
|