Overview
| Comment: | Added re-reload of testconfig at begining of run:test. It will likely need to be tweaked - especially it will need some additional variables set. |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.70-defunct-try |
| Files: | files | file ages | folders |
| SHA1: |
ad3f2a1d6fadbabece9869b27922e33f |
| User & Date: | matt on 2019-12-10 20:37:51 |
| Other Links: | branch diff | manifest | tags |
Context
|
2019-12-10
| ||
| 21:13 | Untested extention of SKIP to ALL files listed on the var. check-in: 7cb6cc1b64 user: matt tags: v1.70-defunct-try | |
| 20:37 | Added re-reload of testconfig at begining of run:test. It will likely need to be tweaked - especially it will need some additional variables set. check-in: ad3f2a1d6f user: matt tags: v1.70-defunct-try | |
| 19:11 | Added level hints to megamod.scm check-in: 50e6a59d65 user: mrwellan tags: v1.70-defunct-try | |
Changes
Modified runs-inc.scm from [41f773e598] to [d4c36b796e].
| ︙ | ︙ | |||
1724 1725 1726 1727 1728 1729 1730 | ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step ;; (define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) ;; All these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) (test-waitons (tests:testqueue-get-waitons test-record)) | < < < < < < < > > > > > > > > > > | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 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 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 |
;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
;;
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry)
;; All these vars might be referenced by the testconfig file reader
(let* ((test-name (tests:testqueue-get-testname test-record))
(test-waitons (tests:testqueue-get-waitons test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(item-path "")
(db #f)
(full-test-name #f))
;; setting itemdat to a list if it is #f
(if (not itemdat)(set! itemdat '()))
(set! item-path (item-list->path itemdat))
(set! full-test-name (db:test-make-full-name test-name item-path))
(runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process
(let* ((test-conf (tests:get-testconfig test-name item-path all-tests-registry #t force-create: #t))
;; (tests:testqueue-get-testconfig test-record ))
(test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
(force (hash-table-ref/default flags "-force" #f))
(rerun (hash-table-ref/default flags "-rerun" #f))
(keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x")))
)
(debug:print-info 4 *default-log-port*
"\nTESTNAME: " full-test-name
"\n test-config: " (hash-table->alist test-conf)
"\n itemdat: " itemdat
)
(debug:print 2 *default-log-port* "Attempting to launch test " full-test-name)
;; (setenv "MT_TEST_NAME" test-name) ;;
;; (setenv "MT_ITEMPATH" item-path)
;; (setenv "MT_RUNNAME" runname)
(change-directory *toppath*)
;; Here is where the test_meta table is best updated
;; Yes, another use of a global for caching. Need a better way?
;;
;; There is now a single call to runs:update-all-test_meta and this
;; per-test call is not needed. Given the delicacy of the move to
;; v1.55 this code is being left in place for the time being.
;;
(if (not (hash-table-ref/default *test-meta-updated* test-name #f))
(begin
(hash-table-set! *test-meta-updated* test-name #t)
(runs:update-test_meta test-name test-conf)))
;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer"))
(let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
(test-id (rmt:get-test-id run-id test-name item-path))
(testdat (if test-id (rmt:get-test-info-by-id run-id test-id) #f)))
(if (not testdat)
(let loop ()
;; ensure that the path exists before registering the test
;; NOPE: Cannot! Don't know yet which disk area will be assigned....
;; (system (conc "mkdir -p " new-test-path))
;;
;; (open-run-close tests:register-test db run-id test-name item-path)
;;
;; NB// for the above line. I want the test to be registered long before this routine gets called!
;;
(if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path)))
(if (not test-id)
(begin
(debug:print 2 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id)
(rmt:register-test run-id test-name item-path)
(set! test-id (rmt:get-test-id run-id test-name item-path))))
(debug:print-info 4 *default-log-port* "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"")
(set! testdat (rmt:get-test-info-by-id run-id test-id))
(if (not testdat)
(begin
(debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in one second")
(thread-sleep! 1)
(loop)))))
(if (not testdat) ;; should NOT happen
(debug:print-error 0 *default-log-port* "failed to get test record for test-id " test-id))
(set! test-id (db:test-get-id testdat))
(if (common:file-exists? test-path)
(change-directory test-path)
(begin
(debug:print-error 0 *default-log-port* "test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?")
(change-directory *toppath*)))
(case (if force ;; (args:get-arg "-force")
'NOT_STARTED
(if testdat
(string->symbol (test:get-state testdat))
'failed-to-insert))
((failed-to-insert)
(debug:print-error 0 *default-log-port* "Failed to insert the record into the db"))
((NOT_STARTED COMPLETED DELETED INCOMPLETE)
(let ((runflag #f))
(cond
;; -force, run no matter what
(force (set! runflag #t))
;; NOT_STARTED, run no matter what
((member (test:get-state testdat) '("DELETED" "NOT_STARTED" "INCOMPLETE"))(set! runflag #t))
;; not -rerun and PASS, WARN or CHECK, do no run
((and (or (not rerun)
keepgoing)
;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK
(or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED"))
(member (test:get-state testdat) '("COMPLETED"))))
(debug:print-info 2 *default-log-port* "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat))
(hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED)
(set! runflag #f))
;; -rerun and status is one of the specifed, run it
((and rerun
(let* ((rerunlst (string-split rerun ","))
(must-rerun (member (test:get-status testdat) rerunlst)))
(debug:print-info 3 *default-log-port* "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun)
must-rerun))
(debug:print-info 2 *default-log-port* "Rerun forced for test " test-name "/" item-path)
(set! runflag #t))
;; -keepgoing, do not rerun FAIL
((and keepgoing
(member (test:get-status testdat) '("FAIL")))
(set! runflag #f))
((and (not rerun)
(member (test:get-status testdat) '("FAIL" "n/a")))
(set! runflag #t))
(else (set! runflag #f)))
(debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
(if (not runflag)
(if (not parent-test)
(if (runs:lownoise (conc "not starting test" full-test-name) 60)
(debug:print 1 *default-log-port* "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat)
"\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat)
"\" or -force to override")))
;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are
;; already met.
;; This would be a great place to do the process-fork
;;
(let ((skip-test #f)
(skip-check (configf:get-section test-conf "skip")))
(cond
;; Have to check for skip conditions. This one skips if there are same-named tests
;; currently running
((and skip-check
(configf:lookup test-conf "skip" "prevrunning"))
;; run-ids = #f means *all* runs
(let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)))
(if (not (null? running-tests)) ;; have to skip
(set! skip-test "Skipping due to previous tests running"))))
;; split the string and OR of file-exists?
((and skip-check
(configf:lookup test-conf "skip" "fileexists"))
(if (common:file-exists? (configf:lookup test-conf "skip" "fileexists"))
(set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists")))))
((and skip-check
(configf:lookup test-conf "skip" "filenotexists"))
(if (not (common:file-exists? (configf:lookup test-conf "skip" "filenotexists")))
(set! skip-test (conc "Skipping due to non existance of file " (configf:lookup test-conf "skip" "filenotexists")))))
((and skip-check
(configf:lookup test-conf "skip" "script"))
(if (= (system (configf:lookup test-conf "skip" "script")) 0)
(set! skip-test (conc "Skipping due to zero return value of script " (configf:lookup test-conf "skip" "script")))))
((and skip-check
(configf:lookup test-conf "skip" "rundelay"))
;; run-ids = #f means *all* runs
(let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay")))
(running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))
(completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED" "INCOMPLETE") '("PASS" "FAIL" "ABORT") #f)) ;; ironically INCOMPLETE is same as COMPLETED in this contex
(last-run-times (map db:mintest-get-event_time completed-tests))
(time-since-last (- (current-seconds) (if (null? last-run-times) 0 (common:max last-run-times)))))
(if (or (not (null? running-tests)) ;; have to skip if test is running
(> numseconds time-since-last))
(set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago"))))))
(if skip-test
(begin
(mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test)
(debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test))
;;
;; Here the test is handed off to launch.scm for launch-test to complete the launch process
;;
(if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags))
(begin
(print "ERROR: Failed to launch the test. Exiting as soon as possible")
(set! *globalexitstatus* 1) ;;
(process-signal (current-process-id) signal/kill))))))))
((KILLED)
(debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED))
((LAUNCHED REMOTEHOSTSTART RUNNING)
(debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))
;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
;; (db:test-get-run_duration testdat)))
;; (or incomplete-timeout
;; 6000)) ;; i.e. no update for more than 6000 seconds
;; (begin
;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")))
(else
(debug:print-error 0 *default-log-port* "Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
(case (string->symbol (test:get-state testdat))
((COMPLETED INCOMPLETE)
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN))
(else
(hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)))))))))
;;======================================================================
;; END OF NEW STUFF
;;======================================================================
(define (get-dir-up-n dir . params)
(let ((dparts (string-split dir "/"))
|
| ︙ | ︙ |
Modified tests-inc.scm from [d022ea8899] to [7718906378].
| ︙ | ︙ | |||
1501 1502 1503 1504 1505 1506 1507 |
#f))
;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
;; else read the testconfig file
;; if have path to test directory save the config as .testconfig and return it
;;
| | > | 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 |
#f))
;; if .testconfig exists in test directory read and return it
;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata"
;; else read the testconfig file
;; if have path to test directory save the config as .testconfig and return it
;;
(define (tests:get-testconfig test-name item-path test-registry system-allowed
#!key (force-create #f)(allow-write-cache #t)(wait-a-minute #f))
(let* ((use-cache (common:use-cache?))
(cache-path (tests:get-test-path-from-environment))
(cache-file (and cache-path (conc cache-path "/.testconfig")))
(cache-exists (and cache-file
(not force-create) ;; if force-create then pretend there is no cache to read
(common:file-exists? cache-file)))
(cached-dat (if (and (not force-create)
|
| ︙ | ︙ |