Megatest is free software released under the General Public License v2.0. Please see the file COPYING in the source distribution for details.
-
-
-
-Email: matt@kiatoa.com.
+
Email: matt@kiatoa.com.
Web: www.kiatoa.com/fossils/megatest
-
-
-
-This document is believed to be acurate at the time of writing but as with any opensource project the source code itself is the final arbiter of the softwares behaviour. It is the responsibility of the end user to validate that the code will perform as they expect. The author assumes no responsibility for any inaccuracies that this document may contain. In no event will Matthew Welland be liable for direct, indirect, special, exemplary, incidental, or consequential damages resulting from any defect or omission in this document, even if advised of the possibility of such damages.
+
This document is believed to be acurate at the time of writing but as with any opensource project the source code itself is the reference. It is the responsibility of the end user to validate that the code will perform as they expect. The author assumes no responsibility for any inaccuracies that this document may contain. In no event will Matthew Welland be liable for direct, indirect, special, exemplary, incidental, or consequential damages resulting from any defect or omission in this document, even if advised of the possibility of such damages.
-This document is a snapshot in time and the Megatest software has likely been changed since publication. This document and the product that it describes may be improved at any time, without notice or obligation.
+This document is a snapshot in time and Megatest software has likely changed since publication. This document and Megatest may be improved at any time, without notice or obligation.
-Megatest is intended to provide the minimum needed resources to make writing a suite of tests for software, design engineering or process control (via owlfs for example) without being specialized for any specific problem space. Megatest in of itself does not know what constitutes a PASS or FAIL of a test. In most cases megatest is best used in conjunction with logpro or a similar tool to parse, analyze and decide on the test outcome. A call to megatest can then be made to record the result.
+Megatest is intended to provide the minimum needed resources to make writing a suite of tests and implementing continuous build for software, design engineering or process control (via owlfs for example) without being specialized for any specific problem space. Megatest in of itself does not know what constitutes a PASS or FAIL of a test. In most cases megatest is best used in conjunction with logpro or a similar tool to parse, analyze and decide on the test outcome.
-All data to specify the tests and configure the system is stored in plain text files. All system state is stored in an sqlite3 database. Tests are launched using the launching system available for the distributed compute platform in use. A template script is provided which can launch jobs on local and remote Linux hosts. Currently megatest uses the network filesystem to “call home” to your master sqlite3 database.
+All data to specify the tests and configure the system is stored in plain text files. All system state is stored in an sqlite3 database. Tests are launched using the launching system available for the distributed compute platform in use. A template script is provided which can launch jobs on local and remote Linux hosts. Currently megatest uses the network filesystem to “call home” to your master sqlite3 database.
-Chicken scheme and a number of “eggs” are required for building megatest. See the file utils/installall.sh for an automated way to install the dependencies on Linux.
+Chicken scheme and a number of “eggs” are required for building megatest. See the file utils/installall.sh for an automated way to install the dependencies on Linux.
-4.1 A Simple Test with one Step
+5.1 A Simple Test with one Step
mkdir simpletest
cd simpletest
@@ -422,11 +449,11 @@
-4.2 Create your testconfig file
+5.2 Create your testconfig file
# testconfig
@@ -435,11 +462,11 @@
-4.3 Create the main.csh script
+5.3 Create the main.csh script
Note: Using csh is NOT recommended. Use bash, perl, ruby, zsh or anything other than csh. We use csh here because it is popular in the EDA industry for which Megatest was originally created.
@@ -462,11 +489,11 @@
You can now run megatest and the created test directory will contain the new files “run_simulation.html” and “run_simulation.log”. If you are using the dashboard you can click on the run and then push the “View log” button to view the log file in firefox.
-4.4 Simple Test with Multiple Steps
+5.4 Simple Test with Multiple Steps
To run multiple steps simply add them to the main.csh file. Here we add a step to test “cpu2”. The second step that tests cpu2 will only run after the step that tested “cpu1” completes.
@@ -484,14 +511,14 @@
-5 Simple Test with Multiple Steps, Some in Parallel
+6 Simple Test with Multiple Steps, Some in Parallel
A good way to run steps in parallel within a single test, especially when there are following steps, is to use the Unix Make utility. Writing Makefiles is beyond the scope of this document but here is a minimal example that will run “runsim cpu1” and “runsim cpu2” in parallel. For more information on make try “info make” at the Linux command prompt.
-6 Simple Test with Iteration
+7 Simple Test with Iteration
Since no jobs run after the cpu1 and cpu2 simulations in this test it is possible to use iterated mode.
-6.1 Update your testconfig file for iteration
+7.1 Update your testconfig file for iteration
[setup]
runscript main.csh
@@ -548,11 +575,11 @@
-6.2 Rewrite your main.csh for iteration
+7.2 Rewrite your main.csh for iteration
#!/bin/tcsh -x
@@ -567,11 +594,11 @@
-6.3 Tests with Inter-test dependencies
+7.3 Tests with Inter-test dependencies
Sometimes a test depends on the output from a previous test or it may not make sense to run a test is another test does not complete with status “PASS”. In either of these scenarios you can use the “waiton” keyword in your testconfig file to indicate that this test must wait on one or more tests to complete before being launched. In this example there is no point in running the “system” test if the “cpu” and “mem” tests either do not complete or complete but with status “FAIL”.
@@ -583,11 +610,11 @@
-6.4 Rolling up Miscellaneous Data
+7.4 Rolling up Miscellaneous Data
Use the -load-test-data switch to roll up arbitrary data from a test into the test_data table.
@@ -626,11 +653,11 @@
If status is specified its value overrides the above calculations.
To roll up a number of tests in a sequence of runs to a single run use the -rollup command.
@@ -642,32 +669,32 @@
All keys must be specified and the runname is the name of the run that will be created. All paths are kept original inside the database. When -remove-runs is used to delete runs the data is not deleted if there are rollups that refer to the data.
Pushing one of the buttons on the main dashboard will bring up the test specific dashboard. Values are updated in semi-real time as the test runs.
-
+
-8 Generating an OpenDocument Spreadsheet from the Database
+9 Generating an OpenDocument Spreadsheet from the Database
And OpenDocument multi-paned spreadsheet can be generated from the megatest.db file by running -extract-ods
@@ -679,17 +706,82 @@
You can optionally specify the keys for your database to limit further the runs to extract into the spreadsheet. The first sheet contains all the run data and subsequent sheets contain data rolled up for the individual tests.
# Flow: <flowname>
+[flowconfig]
+# turn on item level dependencies
+itemdeps on
+
+[flowsteps]
+# <testname>[,<predecessor>]
+
+# Run the test "copydata"
+copydata
+
+# Run the test "setup" after copydata completes with PASS, WARN or WAIVE
+setup,copydata
+
+# once the test "setup" completes successfully run sim1, sim2 and sim3
+sim1,setup
+sim2,setup
+sim3,setup
+
+Note: The monitor is usable but incomplete as of Megatest v1.31. Click on the “Monitor” button on the dashboard to start the monitor and give it a try.
+
+Note: whitespace is preserved including at the end of line. Ensure your entries only have whitespace at the end of line when needed to avoid problems.
+
Use only if necessary, megatest will extract the location from where it used to launch and add append that to the PATH for test runs.
-
+
-
+
runsdir
-
+
full path to where the link tree to all runs will be created
-
+
no
-
+
Because your runs may be spread out over several disk partitions a central link tree is created to make finding all the runs easy.
-
+
[fields]
-
+
string of letters, numbers and underscore
-
+
string of letters, numbers and underscore
-
+
at least one
-
+
-
+
[jobtools]
-
+
launcher
-
+
command line used to launch jobs - the job command (megatest -execute) will be appended to this
-
+
no
-
+
-
+
-
+
workhosts
-
+
list of hostnames to run jobs on NOT SUPPORTED RIGHT NOW
-
+
n/a
-
+
+
+
+
+
+[jobgroups]
+
+
+string of letters, numbers and underscore
+
+
+number
+
+
+no
+
+
+Control number of jobs allowed to concurrently run in categories. See [jobgroup] in testconfig
+
-
+
[env-override]
-
+
string of letters, numbers and underscore
-
+
any string
-
+
no
-
+
These are set on the test launching machine, not the test running machine. Typical usage is to control the host or run queue for launching tests. These values will not be seen by the test when it runs.
-
+
[disks]
-
+
string of letters, numbers and underscore
-
+
a valid path writable by the test launching process and by the test process
-
+
yes
-
+
The disk usage balancing algorithm is to choose the disk with the least space for each test run.
variables set in this section will be available for all runs, defining the same variable in another section will override the value from the default section
-
+
[field1value/field2value...]
-
+
string of letters, numbers and underscore
-
+
any
-
+
no
-
+
the values in this section will be set for any run where field1 is field1value, field2 is field2value and fieldN is fieldNvalue.
The script must be executable and either provide the full path or put a copy at the top of your test directory
-
+
[requirements]
-
+
waiton
-
+
list of valid test names
-
+
no
-
+
This test will not run until the named tests are state completed and status PASS
-
+
+
+
+
+jobgroup
+
+
+
+
+
+
+
+
+
+
+
+
+
+
[items]
-
+
any valid
-
+
list of values
-
+
+no
+
+
+The test will be repeated once for each item with the variable name set to the value. If there is more than one variable then the test will be run against all unique combinations of the values
+
+
+
+
+
+[eztests]
+
+
+any valid
+
+
+stepname command
+
+
no
-
-The test will be repeated once for each item with the variable name set to the value. If there is more than one variable then the test will be run against all unique combinations of the values
+
+Use in addition to or instead of runscript for easy implementation of steps. If <stepname>.logpro exists it will be applied to the <stepname>.log and resulting exit code will be used to determine PASS/FAIL/WARN
ADDED docs/html/monitor-state-diagram.png
Index: docs/html/monitor-state-diagram.png
==================================================================
--- /dev/null
+++ docs/html/monitor-state-diagram.png
cannot compute difference between binary files
Index: docs/megatest.lyx
==================================================================
--- docs/megatest.lyx
+++ docs/megatest.lyx
@@ -285,12 +285,11 @@
\begin_layout Standard
\begin_inset VSpace medskip
\end_inset
This document is believed to be acurate at the time of writing but as with
- any opensource project the source code itself is the final arbiter of the
- softwares behaviour.
+ any opensource project the source code itself is the reference.
It is the responsibility of the end user to validate that the code will
perform as they expect.
The author assumes no responsibility for any inaccuracies that this document
may contain.
In no event will Matthew Welland be liable for direct, indirect, special,
@@ -299,14 +298,14 @@
damages.
\end_layout
\begin_layout Standard
-This document is a snapshot in time and the Megatest software has likely
- been changed since publication.
- This document and the product that it describes may be improved at any
- time, without notice or obligation.
+This document is a snapshot in time and Megatest software has likely changed
+ since publication.
+ This document and Megatest may be improved at any time, without notice
+ or obligation.
\end_layout
\begin_layout Standard
\begin_inset Newpage newpage
@@ -459,18 +458,17 @@
Megatest design philosophy
\end_layout
\begin_layout Standard
Megatest is intended to provide the minimum needed resources to make writing
- a suite of tests for software, design engineering or process control (via
- owlfs for example) without being specialized for any specific problem space.
+ a suite of tests and implementing continuous build for software, design
+ engineering or process control (via owlfs for example) without being specialize
+d for any specific problem space.
Megatest in of itself does not know what constitutes a PASS or FAIL of
a test.
In most cases megatest is best used in conjunction with logpro or a similar
tool to parse, analyze and decide on the test outcome.
- A call to megatest can then be made to record the result.
-
\end_layout
\begin_layout Subsection
Megatest architecture
\end_layout
@@ -1675,10 +1673,23 @@
\end_layout
\begin_layout Subsection
Monitor logic
\end_layout
+
+\begin_layout Standard
+Note: The monitor is usable but incomplete as of Megatest v1.31.
+ Click on the
+\begin_inset Quotes eld
+\end_inset
+
+Monitor
+\begin_inset Quotes erd
+\end_inset
+
+ button on the dashboard to start the monitor and give it a try.
+\end_layout
\begin_layout Standard
\begin_inset Graphics
filename monitor-state-diagram.svg
@@ -1692,10 +1703,16 @@
\end_layout
\begin_layout Subsection
Configuration file Syntax
\end_layout
+
+\begin_layout Standard
+Note: whitespace is preserved including at the end of line.
+ Ensure your entries only have whitespace at the end of line when needed
+ to avoid problems.
+\end_layout
\begin_layout Subsubsection
Sections
\end_layout
@@ -2008,11 +2025,11 @@
megatest.config
\end_layout
\begin_layout Standard
\begin_inset Tabular
-
+
@@ -2344,10 +2361,58 @@
\begin_layout Plain Layout
\end_layout
+\end_inset
+
+
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+[jobgroups]
+\end_layout
+
+\end_inset
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+string of letters, numbers and underscore
+\end_layout
+
+\end_inset
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+number
+\end_layout
+
+\end_inset
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+no
+\end_layout
+
+\end_inset
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+Control number of jobs allowed to concurrently run in categories.
+ See [jobgroup] in testconfig
+\end_layout
+
\end_inset
@@ -2743,11 +2808,11 @@
testconfig file
\end_layout
\begin_layout Standard
\begin_inset Tabular
-
+
@@ -2894,54 +2959,150 @@
\end_inset
-
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+
+\end_layout
+
+\end_inset
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+jobgroup
+\end_layout
+
+\end_inset
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+
+\end_layout
+
+\end_inset
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+
+\end_layout
+
+\end_inset
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+
+\end_layout
+
+\end_inset
+
+
+
+
\begin_inset Text
\begin_layout Plain Layout
[items]
\end_layout
\end_inset
-
+
\begin_inset Text
\begin_layout Plain Layout
any valid
\end_layout
\end_inset
-
+
\begin_inset Text
\begin_layout Plain Layout
list of values
\end_layout
\end_inset
-
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+no
+\end_layout
+
+\end_inset
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+The test will be repeated once for each item with the variable name set
+ to the value.
+ If there is more than one variable then the test will be run against all
+ unique combinations of the values
+\end_layout
+
+\end_inset
+
+
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+[eztests]
+\end_layout
+
+\end_inset
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+any valid
+\end_layout
+
+\end_inset
+
+
+\begin_inset Text
+
+\begin_layout Plain Layout
+stepname command
+\end_layout
+
+\end_inset
+
+
\begin_inset Text
\begin_layout Plain Layout
no
\end_layout
\end_inset
-
+
\begin_inset Text
\begin_layout Plain Layout
-The test will be repeated once for each item with the variable name set
- to the value.
- If there is more than one variable then the test will be run against all
- unique combinations of the values
+Use in addition to or instead of runscript for easy implementation of steps.
+ If .logpro exists it will be applied to the .log and
+ resulting exit code will be used to determine PASS/FAIL/WARN
\end_layout
\end_inset
@@ -3870,11 +4031,11 @@
\begin_inset Text
\begin_layout Plain Layout
-If using logpro to asses the PASS/FAIL status of the step you specify the
+If using logpro to acess the PASS/FAIL status of the step you specify the
logpro file with this parameter.
\end_layout
\end_inset
ADDED docs/monitor-state-diagram.svg
Index: docs/monitor-state-diagram.svg
==================================================================
--- /dev/null
+++ docs/monitor-state-diagram.svg
@@ -0,0 +1,220 @@
+
+
+
+
ADDED docs/test-launch-state-diagram.svg
Index: docs/test-launch-state-diagram.svg
==================================================================
--- /dev/null
+++ docs/test-launch-state-diagram.svg
@@ -0,0 +1,553 @@
+
+
+
+
Index: items.scm
==================================================================
--- items.scm
+++ items.scm
@@ -117,10 +117,37 @@
'()
#f)))
res)))
;; Nope, not now, return null as of 6/6/2011
-
+(define (check-valid-items class item)
+ (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class)))
+ (if s (string-split s) #f))))
+ (if valid-values
+ (if (member item valid-values)
+ item #f)
+ item)))
+
+(define (items:get-items-from-config tconfig)
+ (let* (;; db is always at *toppath*/db/megatest.db
+ (items (hash-table-ref/default tconfig "items" '()))
+ (itemstable (hash-table-ref/default tconfig "itemstable" '())))
+ (debug:print 5 "items: " items " itemstable: " itemstable)
+ (set! items (map (lambda (item)
+ (if (procedure? (cadr item))
+ (list (car item)((cadr item)))
+ item))
+ items))
+ (set! itemstable (map (lambda (item)
+ (if (procedure? (cadr item))
+ (list (car item)((cadr item)))
+ item))
+ itemstable))
+ (if (or (not (null? items))(not (null? itemstable)))
+ (append (item-assoc->item-list items)
+ (item-table->item-list itemstable))
+ '(()))))
+
;; (pp (item-assoc->item-list itemdat))
Index: key_records.scm
==================================================================
--- key_records.scm
+++ key_records.scm
@@ -19,7 +19,9 @@
(string-join (map (lambda (k)(conc (key:get-fieldname k) " "
(key:get-fieldtype k)))
(append keys additional)) ","))
(define-inline (item-list->path itemdat)
- (string-intersperse (map cadr itemdat) "/"))
+ (if (list? itemdat)
+ (string-intersperse (map cadr itemdat) "/")
+ ""))
Index: launch.scm
==================================================================
--- launch.scm
+++ launch.scm
@@ -168,17 +168,18 @@
(debug:print 4 "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
" stepparms: " stepparms " stepcmd: " stepcmd)
(if (file-exists? (conc stepname ".logpro"))(set! logpro-used #t))
- ;; first source the previous environment
- (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh") (get-environment-variable "SHELL")) ".csh" ".sh"))))
- (if (and prevstep (file-exists? prev-env))
- (set! script (conc script "source " prev-env))))
+ ;; ;; first source the previous environment
+ ;; (let ((prev-env (conc ".ezsteps/" prevstep (if (string-search (regexp "csh")
+ ;; (get-environment-variable "SHELL")) ".csh" ".sh"))))
+ ;; (if (and prevstep (file-exists? prev-env))
+ ;; (set! script (conc script "source " prev-env))))
;; call the command using mt_ezstep
- (set! script (conc script ";mt_ezstep " stepname " " stepcmd))
+ (set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
(debug:print 4 "script: " script)
(teststep-set-status! db run-id test-name stepname "start" "-" itemdat #f #f)
;; now launch
@@ -216,18 +217,22 @@
" this-step-status: " this-step-status " overall-status: " overall-status
" next-status: " next-status " rollup-status: " rollup-status)
(case next-status
((warn)
(set! rollup-status 2)
- (test-set-status! db run-id test-name "COMPLETED" "WARN" itemdat
+ ;; (test-set-status! db run-id test-name "COMPLETED" "WARN" itemdat
+ (test-set-status! db run-id test-name "RUNNING" "WARN" itemdat
(if (eq? this-step-status 'warn) "Logpro warning found" #f)
#f))
((pass)
- (test-set-status! db run-id test-name "COMPLETED" "PASS" itemdat #f #f))
+ ;; (test-set-status! db run-id test-name "COMPLETED" "PASS" itemdat #f #f))
+ (test-set-status! db run-id test-name "RUNNING" "PASS" itemdat #f #f))
(else ;; 'fail
(set! rollup-status 1) ;; force fail
- (test-set-status! db run-id test-name "COMPLETED" "FAIL" itemdat (conc "Failed at step " stepname) #f)))))
+ ;; (test-set-status! db run-id test-name "COMPLETED" "FAIL" itemdat (conc "Failed at step " stepname) #f)
+ (test-set-status! db run-id test-name "RUNNING" "FAIL" itemdat (conc "Failed at step " stepname) #f)
+ ))))
(if (and (steprun-good? logpro-used (vector-ref exit-info 2))
(not (null? tal)))
(loop (car tal) (cdr tal) stepname)))
(debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
(monitorjob (lambda ()
@@ -374,13 +379,17 @@
(key-vals (get-key-vals db run-id))
(key-str (string-intersperse key-vals "/"))
(dfullp (conc disk-path "/" key-str "/" runname "/" testname
item-path))
(toptest-path (conc disk-path "/" key-str "/" runname "/" testname))
- (runsdir (config-lookup *configdat* "setup" "runsdir"))
- (lnkpath (conc (if runsdir runsdir (conc *toppath* "/runs"))
- "/" key-str "/" runname item-path)))
+ (linktree (let ((rd (config-lookup *configdat* "setup" "linktree")))
+ (if rd rd (conc *toppath* "/runs"))))
+ (lnkpath (conc linktree "/" key-str "/" runname item-path)))
+ (if (not (file-exists? linktree))
+ (begin
+ (debug:print 0 "WARNING: linktree did not exist! Creating it now at " linktree)
+ (system (conc "mkdir -p " linktree))))
;; since this is an iterated test this is as good a place as any to
;; update the toptest record with its location rundir
(if (not (equal? item-path ""))
(db:test-set-rundir! db run-id testname "" toptest-path))
(debug:print 2 "Setting up test run area")
@@ -387,15 +396,15 @@
(debug:print 2 " - creating run area in " dfullp)
(system (conc "mkdir -p " dfullp))
(debug:print 2 " - creating link from " dfullp "/" testname " to " lnkpath)
(system (conc "mkdir -p " lnkpath))
-;; I suspect this section was deleting test directories under some
-;; wierd sitations
+ ;; I suspect this section was deleting test directories under some
+ ;; wierd sitations? This doesn't make sense - reenabling the rm -f
-;; (if (file-exists? (conc lnkpath "/" testname))
-;; (system (conc "rm -f " lnkpath "/" testname)))
+ (if (file-exists? (conc lnkpath "/" testname))
+ (system (conc "rm -f " lnkpath "/" testname)))
(system (conc "ln -sf " dfullp " " lnkpath "/" testname))
(if (directory? dfullp)
(begin
(let* ((cmd (conc "rsync -av" (if (> *verbosity* 1) "" "q") " " test-path "/ " dfullp "/"))
(status (system cmd)))
DELETED matrix.scm
Index: matrix.scm
==================================================================
--- matrix.scm
+++ /dev/null
@@ -1,44 +0,0 @@
-(require-library iup canvas-draw canvas-draw-iup)
-
-(module matrix-test
- (matrix-dialog)
- (import
- scheme chicken extras
- iup canvas-draw canvas-draw-iup
- (only canvas-draw-base pointer->canvas))
-
-(define ncols 8)
-(define nlins 8)
-(define width 32)
-(define height 32)
-
-;; (define (render-cell handle i j x-min x-max y-min y-max canvas)
-;; (set! (canvas-foreground canvas)
-;; (if (or (and (odd? i) (odd? j)) (and (even? i) (even? j)))
-;; #xffffff
-;; #x000000))
-;; (canvas-box! canvas x-min x-max y-min y-max))
-
-(define matrix-dialog
- (dialog
- #:title "Matrix Test"
- (let ((mat (matrix
- ; #:expand "YES"
- ; #:scrollbar "YES"
- #:numcol ncols
- #:numlin nlins
- #:numcol-visible ncols
- #:numlin-visible nlins
- #:click-cb (lambda (obj lin col status)
- (print "obj: " obj " lin: " lin " col: " col " status: " status)))))
- (attribute-set! mat "0:0" "Testing")
- mat)))
-
-) ;; end module
-
-(import
- (only iup show main-loop)
- matrix-test)
-
-(show matrix-dialog)
-(main-loop)
Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -1,7 +1,7 @@
;; Always use two digit decimal
;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00..
(declare (unit megatest-version))
-(define megatest-version 1.34)
+(define megatest-version 1.36)
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -91,11 +91,11 @@
-update-meta : update the tests metadata for all tests
-env2file fname : write the environment to fname.csh and fname.sh
-setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
Spreadsheet generation
- -extract-ods : extract an open document spreadsheet from the database
+ -extract-ods fname.ods : extract an open document spreadsheet from the database
-pathmod path : insert path, i.e. path/runame/itempath/logfile.html
will clear the field if no rundir/testname/itempath/logfile
if it contains forward slashes the path will be converted
to windows style
@@ -233,11 +233,15 @@
(args:get-arg "-itempatt")))
(sqlite3:finalize! db)
(set! *didsomething* #t)))))
(if (args:get-arg "-remove-runs")
- (remove-runs))
+ (general-run-call
+ "-remove-runs"
+ "remove runs"
+ (lambda (db target runname keys keynames keyvallst)
+ (remove-runs))))
;;======================================================================
;; Query runs
;;======================================================================
@@ -324,15 +328,48 @@
;; run all tests are are Not COMPLETED and PASS or CHECK
(if (args:get-arg "-runall")
(general-run-call
"-runall"
"run all tests"
- (lambda (db keys keynames keyvallst)
- (let* ((test-names (get-all-legal-tests))) ;; "PROD" is ignored for now
- (debug:print 1 "INFO: Attempting to start the following tests...")
- (debug:print 1 " " (string-intersperse test-names ","))
- (run-tests db test-names)))))
+ (lambda (db target runname keys keynames keyvallst)
+ (runs:run-tests db
+ target
+ runname
+ (args:get-arg "-testpatt")
+ (args:get-arg "-itempatt")
+ user
+ (make-hash-table)))))
+
+;;======================================================================
+;; run one test
+;;======================================================================
+
+;; 1. find the config file
+;; 2. change to the test directory
+;; 3. update the db with "test started" status, set running host
+;; 4. process launch the test
+;; - monitor the process, update stats in the db every 2^n minutes
+;; 5. as the test proceeds internally it calls megatest as each step is
+;; started and completed
+;; - step started, timestamp
+;; - step completed, exit status, timestamp
+;; 6. test phone home
+;; - if test run time > allowed run time then kill job
+;; - if cannot access db > allowed disconnect time then kill job
+
+(if (args:get-arg "-runtests")
+ (general-run-call
+ "-runtests"
+ "run a test"
+ (lambda (db target runname keys keynames keyvallst)
+ (runs:run-tests db
+ target
+ runname
+ (args:get-arg "-runtests")
+ (args:get-arg "-itempatt")
+ user
+ (make-hash-table)))))
;;======================================================================
;; Rollup into a run
;;======================================================================
(if (args:get-arg "-rollup")
@@ -352,42 +389,18 @@
(if (args:get-arg "-extract-ods")
(general-run-call
"-extract-ods"
"Make ods spreadsheet"
- (lambda (db keys keynames keyvallst)
+ (lambda (db target runname keys keynames keyvallst)
(let ((outputfile (args:get-arg "-extract-ods"))
(runspatt (args:get-arg ":runname"))
(pathmod (args:get-arg "-pathmod"))
(keyvalalist (keys->alist keys "%")))
+ (debug:print 2 "Extract ods, outputfile: " outputfile " runspatt: " runspatt " keyvalalist: " keyvalalist)
(db:extract-ods-file db outputfile keyvalalist (if runspatt runspatt "%") pathmod)))))
-;;======================================================================
-;; run one test
-;;======================================================================
-
-;; 1. find the config file
-;; 2. change to the test directory
-;; 3. update the db with "test started" status, set running host
-;; 4. process launch the test
-;; - monitor the process, update stats in the db every 2^n minutes
-;; 5. as the test proceeds internally it calls megatest as each step is
-;; started and completed
-;; - step started, timestamp
-;; - step completed, exit status, timestamp
-;; 6. test phone home
-;; - if test run time > allowed run time then kill job
-;; - if cannot access db > allowed disconnect time then kill job
-
-(if (args:get-arg "-runtests")
- (general-run-call
- "-runtests"
- "run a test"
- (lambda (db keys keynames keyvallst)
- (let ((test-names (string-split (args:get-arg "-runtests") ",")))
- (run-tests db test-names)))))
-
;;======================================================================
;; execute the test
;; - gets called on remote host
;; - receives info from the -execute param
;; - passes info to steps via MT_CMDINFO env var (future is to use a dot file)
ADDED monitor.scm
Index: monitor.scm
==================================================================
--- /dev/null
+++ monitor.scm
@@ -0,0 +1,25 @@
+;; Copyright 2006-2011, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit runs))
+(declare (uses db))
+(declare (uses common))
+(declare (uses items))
+(declare (uses runconfig))
+
+(include "common_records.scm")
+(include "key_records.scm")
+(include "db_records.scm")
+(include "run_records.scm")
+
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -16,48 +16,17 @@
(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
+(declare (uses tests))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
-
-;; register a test run with the db
-(define (register-run db keys) ;; test-name)
- (let* ((keystr (keys->keystr keys))
- (comma (if (> (length keys) 0) "," ""))
- (andstr (if (> (length keys) 0) " AND " ""))
- (valslots (keys->valslots keys)) ;; ?,?,? ...
- (keyvallst (keys->vallist keys)) ;; extracts the values from remainder of (argv)
- (runname (get-with-default ":runname" #f))
- (state (get-with-default ":state" "no"))
- (status (get-with-default ":status" "n/a"))
- (allvals (append (list runname state status user) keyvallst))
- (qryvals (append (list runname) keyvallst))
- (key=?str (string-intersperse (map (lambda (k)(conc (key:get-fieldname k) "=?")) keys) " AND ")))
- (debug:print 3 "keys: " keys " allvals: " allvals " keyvallst: " keyvallst)
- (debug:print 2 "NOTE: using key " (string-intersperse keyvallst "/") " for this run")
- (if (and runname (null? (filter (lambda (x)(not x)) keyvallst))) ;; there must be a better way to "apply and"
- (let ((res #f))
- (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");")
- allvals)
- (apply sqlite3:for-each-row
- (lambda (id)
- (set! res id))
- db
- (let ((qry (conc "SELECT id FROM runs WHERE (runname=? " andstr key=?str ");")))
- ;(debug:print 4 "qry: " qry)
- qry)
- qryvals)
- (sqlite3:execute db "UPDATE runs SET state=?,status=? WHERE id=?;" state status res)
- res)
- (begin
- (debug:print 0 "ERROR: Called without all necessary keys")
- #f))))
+(include "test_records.scm")
;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
@@ -87,298 +56,10 @@
db
(conc "SELECT " keystr " FROM runs WHERE runname like ? " key-patt ";")
runnamepatt)
(vector header res)))
-(define (register-test db run-id test-name item-path)
- (let ((item-paths (if (equal? item-path "")
- (list item-path)
- (list item-path ""))))
- (for-each
- (lambda (pth)
- (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');"
- run-id
- test-name
- pth
- ;; (conc "," (string-intersperse tags ",") ",")
- ))
- item-paths )))
-
-;; get the previous record for when this test was run where all keys match but runname
-;; returns #f if no such test found, returns a single test record if found
-(define (test:get-previous-test-run-record db run-id test-name item-path)
- (let* ((keys (db:get-keys db))
- (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
- (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
- (keyvals #f))
- ;; first look up the key values from the run selected by run-id
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! keyvals (cons a b)))
- db
- (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
- (if (not keyvals)
- #f
- (let ((prev-run-ids '()))
- (apply sqlite3:for-each-row
- (lambda (id)
- (set! prev-run-ids (cons id prev-run-ids)))
- db
- (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
- ;; for each run starting with the most recent look to see if there is a matching test
- ;; if found then return that matching test record
- (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
- (if (null? prev-run-ids) #f
- (let loop ((hed (car prev-run-ids))
- (tal (cdr prev-run-ids)))
- (let ((results (db-get-tests-for-run db hed test-name item-path '() '())))
- (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
- (if (and (null? results)
- (not (null? tal)))
- (loop (car tal)(cdr tal))
- (if (null? results) #f
- (car results))))))))))
-
-;; get the previous records for when these tests were run where all keys match but runname
-;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
-;; can use wildcards.
-(define (test:get-matching-previous-test-run-records db run-id test-name item-path)
- (let* ((keys (db:get-keys db))
- (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
- (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
- (keyvals #f)
- (tests-hash (make-hash-table)))
- ;; first look up the key values from the run selected by run-id
- (sqlite3:for-each-row
- (lambda (a . b)
- (set! keyvals (cons a b)))
- db
- (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
- (if (not keyvals)
- '()
- (let ((prev-run-ids '()))
- (apply sqlite3:for-each-row
- (lambda (id)
- (set! prev-run-ids (cons id prev-run-ids)))
- db
- (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
- ;; collect all matching tests for the runs then
- ;; extract the most recent test and return that.
- (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
- ", previous run ids found: " prev-run-ids)
- (if (null? prev-run-ids) '() ;; no previous runs? return null
- (let loop ((hed (car prev-run-ids))
- (tal (cdr prev-run-ids)))
- (let ((results (db-get-tests-for-run db hed test-name item-path '() '())))
- (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
- ", item-path " item-path " results: " (intersperse results "\n"))
- ;; Keep only the youngest of any test/item combination
- (for-each
- (lambda (testdat)
- (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
- (stored-test (hash-table-ref/default tests-hash full-testname #f)))
- (if (or (not stored-test)
- (and stored-test
- (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
- ;; this test is younger, store it in the hash
- (hash-table-set! tests-hash full-testname testdat))))
- results)
- (if (null? tal)
- (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
- (loop (car tal)(cdr tal))))))))))
-
-(define (test-set-status! db run-id test-name state status itemdat-or-path comment dat)
- (let* ((real-status status)
- (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path)))
- (testdat (db:get-test-info db run-id test-name item-path))
- (test-id (if testdat (db:test-get-id testdat) #f))
- (otherdat (if dat dat (make-hash-table)))
- ;; before proceeding we must find out if the previous test (where all keys matched except runname)
- ;; was WAIVED if this test is FAIL
- (waived (if (equal? status "FAIL")
- (let ((prev-test (test:get-previous-test-run-record db run-id test-name item-path)))
- (if prev-test ;; true if we found a previous test in this run series
- (let ((prev-status (db:test-get-status prev-test))
- (prev-state (db:test-get-state prev-test))
- (prev-comment (db:test-get-comment prev-test)))
- (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)
- (if (and (equal? prev-state "COMPLETED")
- (equal? prev-status "WAIVED"))
- prev-comment ;; waived is either the comment or #f
- #f))
- #f))
- #f)))
- (if waived (set! real-status "WAIVED"))
- (debug:print 4 "real-status " real-status ", waived " waived ", status " status)
-
- ;; update the primary record IF state AND status are defined
- (if (and state status)
- (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;"
- state real-status run-id test-name item-path))
-
- ;; if status is "AUTO" then call rollup
- (if (and test-id state status (or (equal? status "AUTO")(equal? status "AUTO-WARN")))
- (db:test-data-rollup db test-id status))
-
- ;; add metadata (need to do this way to avoid SQL injection issues)
-
- ;; :first_err
- ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
- ;; (if val
- ;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))
- ;;
- ;; ;; :first_warn
- ;; (let ((val (hash-table-ref/default otherdat ":first_warn" #f)))
- ;; (if val
- ;; (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))
-
- (let ((category (hash-table-ref/default otherdat ":category" ""))
- (variable (hash-table-ref/default otherdat ":variable" ""))
- (value (hash-table-ref/default otherdat ":value" #f))
- (expected (hash-table-ref/default otherdat ":expected" #f))
- (tol (hash-table-ref/default otherdat ":tol" #f))
- (units (hash-table-ref/default otherdat ":units" ""))
- (dcomment (hash-table-ref/default otherdat ":comment" "")))
- (debug:print 4
- "category: " category ", variable: " variable ", value: " value
- ", expected: " expected ", tol: " tol ", units: " units)
- (if (and value expected tol) ;; all three required
- (db:csv->test-data db test-id
- (conc category ","
- variable ","
- value ","
- expected ","
- tol ","
- units ","
- dcomment ","))))
-
- ;; need to update the top test record if PASS or FAIL and this is a subtest
- (if (and (not (equal? item-path ""))
- (or (equal? status "PASS")
- (equal? status "WARN")
- (equal? status "FAIL")
- (equal? status "WAIVED")
- (equal? status "RUNNING")))
- (begin
- (sqlite3:execute
- db
- "UPDATE tests
- SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'),
- pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED'))
- WHERE run_id=? AND testname=? AND item_path='';"
- run-id test-name run-id test-name run-id test-name)
- (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING
- (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" run-id test-name)
- (sqlite3:execute
- db
- "UPDATE tests
- SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN
- 'RUNNING'
- ELSE 'COMPLETED' END,
- status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END
- WHERE run_id=? AND testname=? AND item_path='';"
- run-id test-name run-id test-name))))
- (if (or (and (string? comment)
- (string-match (regexp "\\S+") comment))
- waived)
- (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;"
- (if waived waived comment) run-id test-name item-path))
- ))
-
-(define (test-set-log! db run-id test-name itemdat logf)
- (let ((item-path (item-list->path itemdat)))
- (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;"
- logf run-id test-name item-path)))
-
-(define (test-set-toplog! db run-id test-name logf)
- (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';"
- logf run-id test-name))
-
-(define (tests:summarize-items db run-id test-name force)
- ;; if not force then only update the record if one of these is true:
- ;; 1. logf is "log/final.log
- ;; 2. logf is same as outputfilename
- (let ((outputfilename (conc "megatest-rollup-" test-name ".html"))
- (orig-dir (current-directory))
- (logf #f))
- (sqlite3:for-each-row
- (lambda (path final_logf)
- (set! logf final_logf)
- (if (directory? path)
- (begin
- (print "Found path: " path)
- (change-directory path))
- ;; (set! outputfilename (conc path "/" outputfilename)))
- (print "No such path: " path)))
- db
- "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';"
- run-id test-name)
- (print "summarize-items with logf " logf)
- (if (or (equal? logf "logs/final.log")
- (equal? logf outputfilename)
- force)
- (begin
- (if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock
- (print "Obtained lock for " outputfilename)
- (print "Failed to obtain lock for " outputfilename))
- (let ((oup (open-output-file outputfilename))
- (counts (make-hash-table))
- (statecounts (make-hash-table))
- (outtxt "")
- (tot 0))
- (with-output-to-port
- oup
- (lambda ()
- (set! outtxt (conc outtxt "Summary: " test-name
- "
Summary for " test-name "
"))
- (sqlite3:for-each-row
- (lambda (id itempath state status run_duration logf comment)
- (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0)))
- (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0)))
- (set! outtxt (conc outtxt "
")))
- db
- "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';"
- run-id test-name)
-
- (print "
")
- ;; Print out stats for status
- (set! tot 0)
- (print "
State stats
")
- (for-each (lambda (state)
- (set! tot (+ tot (hash-table-ref statecounts state)))
- (print "
" state "
" (hash-table-ref statecounts state) "
"))
- (hash-table-keys statecounts))
- (print "
Total
" tot "
")
- (print "
")
- ;; Print out stats for state
- (set! tot 0)
- (print "
Status stats
")
- (for-each (lambda (status)
- (set! tot (+ tot (hash-table-ref counts status)))
- (print "
" status
- "
" (hash-table-ref counts status) "
"))
- (hash-table-keys counts))
- (print "
Total
" tot "
")
- (print "
")
-
- (print "
"
- "
Item
State
Status
Comment
"
- outtxt "
")
- (release-dot-lock outputfilename)))
- (close-output-port oup)
- (change-directory orig-dir)
- (test-set-toplog! db run-id test-name outputfilename)
- )))))
-
;; ;; TODO: Converge this with db:get-test-info
;; (define (runs:get-test-info db run-id test-name item-path)
;; (let ((res #f)) ;; (vector #f #f #f #f #f #f)))
;; (sqlite3:for-each-row
;; (lambda (id run-id test-name state status)
@@ -390,74 +71,10 @@
(define (runs:test-get-full-path test)
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
-(define (check-valid-items class item)
- (let ((valid-values (let ((s (config-lookup *configdat* "validvalues" class)))
- (if s (string-split s) #f))))
- (if valid-values
- (if (member item valid-values)
- item #f)
- item)))
-
-(define (teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile)
- (debug:print 4 "run-id: " run-id " test-name: " test-name)
- (let* ((state (check-valid-items "state" state-in))
- (status (check-valid-items "status" status-in))
- (item-path (item-list->path itemdat))
- (testdat (db:get-test-info db run-id test-name item-path)))
- (debug:print 5 "testdat: " testdat)
- (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works.
- (or (not state)(not status)))
- (debug:print 0 "WARNING: Invalid " (if status "status" "state")
- " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
- (if testdat
- (let ((test-id (test:get-id testdat)))
- ;; FIXME - this should not update the logfile unless it is specified.
- (sqlite3:execute db
- "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);"
- test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile "")))
- (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db"))))
-
-(define (test-get-kill-request db run-id test-name itemdat)
- (let* ((item-path (item-list->path itemdat))
- (testdat (db:get-test-info db run-id test-name item-path)))
- (equal? (test:get-state testdat) "KILLREQ")))
-
-(define (test-set-meta-info db run-id testname itemdat)
- (let ((item-path (item-list->path itemdat))
- (cpuload (get-cpu-load))
- (hostname (get-host-name))
- (diskfree (get-df (current-directory)))
- (uname (get-uname "-srvpio"))
- (runpath (current-directory)))
- (sqlite3:execute db "UPDATE tests SET host=?,cpuload=?,diskfree=?,uname=?,rundir=? WHERE run_id=? AND testname=? AND item_path=?;"
- hostname
- cpuload
- diskfree
- uname
- runpath
- run-id
- testname
- item-path)))
-
-(define (test-update-meta-info db run-id testname itemdat minutes cpuload diskfree tmpfree)
- (let ((item-path (item-list->path itemdat)))
- (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (set! item-path "")))
- ;; (let ((testinfo (db:get-test-info db run-id testname item-path)))
- ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED"))
- ;; (not (equal? (db:test-get-status testinfo) "KILLREQ"))
- (sqlite3:execute
- db
- "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');"
- cpuload
- diskfree
- minutes
- run-id
- testname
- item-path)))
(define (set-megatest-env-vars db run-id)
(let ((keys (db-get-keys db)))
(for-each (lambda (key)
(sqlite3:for-each-row
@@ -465,356 +82,54 @@
(debug:print 2 "setenv " (key:get-fieldname key) " " val)
(setenv (key:get-fieldname key) val))
db
(conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;")
run-id))
- keys)))
+ keys)
+ ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
+ (sqlite3:for-each-row
+ (lambda (runname)
+ (setenv "MT_RUNNAME" runname))
+ db
+ "SELECT runname FROM runs WHERE id=?;"
+ run-id)
+ ))
(define (set-item-env-vars itemdat)
(for-each (lambda (item)
(debug:print 2 "setenv " (car item) " " (cadr item))
(setenv (car item) (cadr item)))
itemdat))
-(define (get-all-legal-tests)
- (let* ((tests (glob (conc *toppath* "/tests/*")))
- (res '()))
- (debug:print 4 "INFO: Looking at tests " (string-intersperse tests ","))
- (for-each (lambda (testpath)
- (if (file-exists? (conc testpath "/testconfig"))
- (set! res (cons (last (string-split testpath "/")) res))))
- tests)
- res))
-
-(define (runs:can-run-more-tests db)
- (let ((num-running (db:get-count-tests-running db))
- (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")))
+(define (runs:can-run-more-tests db test-record)
+ (let* ((tconfig (tests:testqueue-get-testconfig test-record))
+ (jobgroup (config-lookup tconfig "requirements" "jobgroup"))
+ (num-running (db:get-count-tests-running db))
+ (num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db jobgroup))
+ (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))
+ (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup)))
(debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
(if (not (eq? 0 *globalexitstatus*))
#f
- (if (or (not max-concurrent-jobs)
- (and max-concurrent-jobs
- (string->number max-concurrent-jobs)
- (not (>= num-running (string->number max-concurrent-jobs)))))
- #t
- (begin
- (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running
- ", max_concurrent_jobs: " max-concurrent-jobs)
- #f)))))
-
-(define (test:get-testconfig test-name system-allowed)
- (let* ((test-path (conc *toppath* "/tests/" test-name))
- (test-configf (conc test-path "/testconfig"))
- (testexists (and (file-exists? test-configf)(file-read-access? test-configf))))
- (if testexists
- (read-config test-configf #f system-allowed environ-patt: (if system-allowed
- "pre-launch-env-vars"
- #f))
- #f)))
-
-;; sort tests by priority and waiton
-;; Move test specific stuff to a test unit FIXME one of these days
-(define (tests:sort-by-priority-and-waiton test-names)
- (let ((testdetails (make-hash-table))
- (mungepriority (lambda (priority)
- (if priority
- (let ((tmp (any->number priority)))
- (if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0)))
- 0))))
- (for-each (lambda (test-name)
- (let ((test-config (test:get-testconfig test-name #f)))
- (if test-config (hash-table-set! testdetails test-name test-config))))
- test-names)
- (sort
- (hash-table-keys testdetails) ;; avoid dealing with deleted tests, look at the hash table
- (lambda (a b)
- (let* ((tconf-a (hash-table-ref testdetails a))
- (tconf-b (hash-table-ref testdetails b))
- (a-waiton (config-lookup tconf-a "requirements" "waiton"))
- (b-waiton (config-lookup tconf-b "requirements" "waiton"))
- (a-priority (mungepriority (config-lookup tconf-a "requirements" "priority")))
- (b-priority (mungepriority (config-lookup tconf-b "requirements" "priority"))))
- (if (and a-waiton (equal? a-waiton b))
- #f ;; cannot have a which is waiting on b happening before b
- (if (and b-waiton (equal? b-waiton a))
- #t ;; this is the correct order, b is waiting on a and b is before a
- (if (> a-priority b-priority)
- #t ;; if a is a higher priority than b then we are good to go
- #f))))))))
-
-;; This is original run-tests, this routine is deprecated and we will transition to using runs:run-tests (see below)
-;;
-(define (run-tests db test-names)
- (let* ((keys (db-get-keys db))
- (keyvallst (keys->vallist keys #t))
- (run-id (register-run db keys)) ;; test-name)))
- (deferred '()) ;; delay running these since they have a waiton clause
- (runconfigf (conc *toppath* "/runconfigs.config"))
- (required-tests '()))
-
- ;; now add non-directly referenced dependencies (i.e. waiton)
- ;; could cache all these since they need to be read again ...
- ;; FIXME SOMEDAY
- (if (not (null? test-names))
- (let loop ((hed (car test-names))
- (tal (cdr test-names)))
- (let* ((config (test:get-testconfig hed #f))
- (waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
- (if w w "")))))
- (for-each
- (lambda (waiton)
- (if (and waiton (not (member waiton test-names)))
- (begin
- (set! required-tests (cons waiton required-tests))
- (set! test-names (append test-names (list waiton))))))
- waitons)
- (let ((remtests (delete-duplicates (append waitons tal))))
- (if (not (null? remtests))
- (loop (car remtests)(cdr remtests)))))))
-
- (if (not (null? required-tests))
- (debug:print 1 "INFO: Adding " required-tests " to the run queue")
- (debug:print 1 "INFO: No prerequisites added"))
-
- ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
- ;; -keepgoing is specified
-
- (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
-
- (if (file-exists? runconfigf)
- (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* environ-patt: ".*")
- (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
-
- (if (and (eq? *passnum* 0)
- (args:get-arg "-keepgoing"))
- (begin
- ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to
- ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends
- ;; on test A but test B reached the point on being registered as NOT_STARTED and test
- ;; A failed for some reason then on re-run using -keepgoing the run can never complete.
- (db:delete-tests-in-state db run-id "NOT_STARTED")
- (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
- (set! *passnum* (+ *passnum* 1))
- (let loop ((numtimes 0))
- (for-each
- (lambda (test-name)
- (if (runs:can-run-more-tests db)
- (run-one-test db run-id test-name keyvallst)
- ;; add some delay
- ;(sleep 2)
- ))
- (tests:sort-by-priority-and-waiton test-names))
- ;; (run-waiting-tests db)
- (if (args:get-arg "-keepgoing")
- (let ((estrem (db:estimated-tests-remaining db run-id)))
- (if (and (> estrem 0)
- (eq? *globalexitstatus* 0))
- (begin
- (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...")
- (thread-sleep! 3)
- (run-waiting-tests db)
- (loop (+ numtimes 1)))))))))
-
-;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc
-(define (run-one-test db run-id test-name keyvallst)
- (debug:print 1 "Launching test " test-name)
- ;; All these vars might be referenced by the testconfig file reader
- (setenv "MT_TEST_NAME" test-name) ;;
- (setenv "MT_RUNNAME" (args:get-arg ":runname"))
-
- ;; (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
-
- (change-directory *toppath*)
- (let* ((test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
- (test-configf (conc test-path "/testconfig"))
- (testexists (and (file-exists? test-configf)(file-read-access? test-configf)))
- (test-conf (if testexists (read-config test-configf #f #t) (make-hash-table)))
- (waiton (let ((w (config-lookup test-conf "requirements" "waiton")))
- (if (string? w)(string-split w)'())))
- (tags (let ((t (config-lookup test-conf "setup" "tags")))
- ;; we want our tags to be separated by commas and fully delimited by commas
- ;; so that queries with "like" can tie to the commas at either end of each tag
- ;; while also allowing the end user to freely use spaces and commas to separate tags
- (if (string? t)(string-substitute (regexp "[,\\s]+") "," (conc "," t ",") #t)
- '()))))
- (if (not testexists)
- (begin
- (debug:print 0 "ERROR: Can't find config file " test-configf)
- (exit 2))
- ;; put top vars into convenient variables and open the db
- (let* (;; db is always at *toppath*/db/megatest.db
- (items (hash-table-ref/default test-conf "items" '()))
- (itemstable (hash-table-ref/default test-conf "itemstable" '()))
- (allitems (if (or (not (null? items))(not (null? itemstable)))
- (append (item-assoc->item-list items)
- (item-table->item-list itemstable))
- '(())))) ;; a list with one null list is a test with no items
-;; (runconfigf (conc *toppath* "/runconfigs.config")))
- (debug:print 1 "items: ")
- (if (>= *verbosity* 1)(pp allitems))
- (if (>= *verbosity* 5)
- (begin
- (print "items: ")(pp (item-assoc->item-list items))
- (print "itestable: ")(pp (item-table->item-list itemstable))))
- (if (args:get-arg "-m")
- (db:set-comment-for-run db run-id (args:get-arg "-m")))
-
- ;; Here is where the test_meta table is best updated
- (runs:update-test_meta db test-name test-conf)
-
- ;; braindead work-around for poorly specified allitems list BUG!!! FIXME
- (if (null? allitems)(set! allitems '(())))
- (let loop ((itemdat (car allitems))
- (tal (cdr allitems)))
- ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
- ;; Handle lists of items
- (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
- (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
- (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
- (testdat #f)
- (num-running (db:get-count-tests-running db))
- (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))
- (parent-test (and (not (null? items))(equal? item-path "")))
- (single-test (and (null? items) (equal? item-path "")))
- (item-test (not (equal? item-path "")))
- (item-patt (args:get-arg "-itempatt"))
- (patt-match (if item-patt
- (string-search (glob->regexp
- (string-translate item-patt "%" "*"))
- item-path)
- #t)))
- (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
- (if (and patt-match (runs:can-run-more-tests db))
- (begin
- (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f)
- (ct 0))
- (if (and (not ts)
- (< ct 10))
- (begin
- (register-test db run-id test-name item-path)
- (db:test-set-comment db run-id test-name item-path "")
- (loop2 (db:get-test-info db run-id test-name item-path)
- (+ ct 1)))
- (if ts
- (set! testdat ts)
- (begin
- (debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
- (if (not (null? tal))
- (loop (car tal)(cdr tal)))))))
- (change-directory test-path)
- ;; this block is here only to inform the user early on
-
- ;; NB// Moving the setting of runconfig.config vars to *before* the
- ;; the calling of each test.
- ;; (if (file-exists? runconfigf)
- ;; (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*)
- ;; (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
- (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat))
- (case (if (args:get-arg "-force")
- 'NOT_STARTED
- (if testdat
- (string->symbol (test:get-state testdat))
- 'failed-to-insert))
- ((failed-to-insert)
- (debug:print 0 "ERROR: Failed to insert the record into the db"))
- ((NOT_STARTED COMPLETED)
- (debug:print 6 "Got here, " (test:get-state testdat))
- (let ((runflag #f))
- (cond
- ;; i.e. this is the parent test to a suite of items, never "run" it
- (parent-test
- (set! runflag #f))
- ;; -force, run no matter what
- ((args:get-arg "-force")(set! runflag #t))
- ;; NOT_STARTED, run no matter what
- ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t))
- ;; not -rerun and PASS, WARN or CHECK, do no run
- ((and (or (not (args:get-arg "-rerun"))
- (args:get-arg "-keepgoing"))
- (member (test:get-status testdat) '("PASS" "WARN" "CHECK")))
- (set! runflag #f))
- ;; -rerun and status is one of the specifed, run it
- ((and (args:get-arg "-rerun")
- (let ((rerunlst (string-split (args:get-arg "-rerun") ","))) ;; FAIL,
- (member (test:get-status testdat) rerunlst)))
- (set! runflag #t))
- ;; -keepgoing, do not rerun FAIL
- ((and (args:get-arg "-keepgoing")
- (member (test:get-status testdat) '("FAIL")))
- (set! runflag #f))
- ((and (not (args:get-arg "-rerun"))
- (member (test:get-status testdat) '("FAIL" "n/a")))
- (set! runflag #t))
- (else (set! runflag #f)))
- (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
- (if (not runflag)
- (if (not parent-test)
- (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override"))
- (let* ((get-prereqs-cmd (lambda ()
- (db-get-prereqs-not-met db run-id waiton))) ;; check before running ....
- (launch-cmd (lambda ()
- (launch-test db run-id (args:get-arg ":runname") test-conf keyvallst test-name test-path itemdat args:arg-hash)))
- (testrundat (list get-prereqs-cmd launch-cmd)))
- (if (or (args:get-arg "-force")
- (let ((preqs-not-yet-met ((car testrundat))))
- (debug:print 2 "Preqrequesites for " test-name ": " preqs-not-yet-met)
- (null? preqs-not-yet-met))) ;; are there any tests that must be run before this one...
- (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host
- (begin
- (print "ERROR: Failed to launch the test. Exiting as soon as possible")
- (set! *globalexitstatus* 1) ;;
- (process-signal (current-process-id) signal/kill)
- ;(exit 1)
- ))
- (if (not (args:get-arg "-keepgoing"))
- (hash-table-set! *waiting-queue* new-test-name testrundat)))))))
- ((KILLED)
- (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
- ((LAUNCHED REMOTEHOSTSTART RUNNING)
- (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
- (db:test-get-run_duration testdat)))
- 100) ;; i.e. no update for more than 100 seconds
- (begin
- (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
- (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead" #f))
- (debug:print 2 "NOTE: " test-name " is already running")))
- (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))
- (if (not (null? tal))
- (loop (car tal)(cdr tal)))))))))
-
-(define (run-waiting-tests db)
- (let ((numtries 0)
- (last-try-time (current-seconds))
- (times (list 1))) ;; minutes to wait before trying again to kick off runs
- ;; BUG this hack of brute force retrying works quite well for many cases but
- ;; what is needed is to check the db for tests that have failed less than
- ;; N times or never been started and kick them off again
- (let loop ((waiting-test-names (hash-table-keys *waiting-queue*)))
- (cond
- ((not (runs:can-run-more-tests db))
- (thread-sleep! 2)
- (loop waiting-test-names))
- ((null? waiting-test-names)
- (debug:print 1 "All tests launched"))
- (else
- (set! numtries (+ numtries 1))
- (for-each (lambda (testname)
- (if (runs:can-run-more-tests db)
- (let* ((testdat (hash-table-ref *waiting-queue* testname))
- (prereqs ((car testdat)))
- (ldb (if db db (open-db))))
- (debug:print 2 "prereqs remaining: " prereqs)
- (if (null? prereqs)
- (begin
- (debug:print 2 "Prerequisites met, launching " testname)
- ((cadr testdat))
- (hash-table-delete! *waiting-queue* testname)))
- (if (not db)
- (sqlite3:finalize! ldb)))))
- waiting-test-names)
- ;; (sleep 10) ;; no point in rushing things at this stage?
- (loop (hash-table-keys *waiting-queue*)))))))
+ (let ((can-not-run-more (cond
+ ;; if max-concurrent-jobs is set and the number running is greater
+ ;; than it than cannot run more jobs
+ ((and max-concurrent-jobs
+ (string->number max-concurrent-jobs)
+ (>= num-running (string->number max-concurrent-jobs)))
+ (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running
+ ", max_concurrent_jobs: " max-concurrent-jobs)
+ #t)
+ ;; if job-group-limit is set and number of jobs in the group is greater
+ ;; than the limit then cannot run more jobs of this kind
+ ((and job-group-limit
+ (>= num-running-in-jobgroup job-group-limit))
+ (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup
+ " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record))
+ #t)
+ (else #f))))
+ (not can-not-run-more)))))
;;======================================================================
;; New methodology. These routines will replace the above in time. For
;; now the code is duplicated. This stuff is initially used in the monitor
;; based code.
@@ -856,14 +171,16 @@
(define (runs:run-tests db target runname test-patts item-patts user flags)
(let* ((keys (db-get-keys db))
(keyvallst (keys:target->keyval keys target))
(run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
- (keepgoing (hash-table-ref/default flags "-keepgoing" #f))
+ ;; keepgoing is the defacto modality now, will add hit-n-run a bit later
+ ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f))
(test-names '())
(runconfigf (conc *toppath* "/runconfigs.config"))
- (required-tests '()))
+ (required-tests '())
+ (test-records (make-hash-table)))
(set-megatest-env-vars db run-id) ;; these may be needed by the launching process
(if (file-exists? runconfigf)
(setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars")
@@ -877,246 +194,286 @@
(set! tests (filter (lambda (test)(file-exists? (conc test "/testconfig"))) tests))
(set! test-names (append test-names
(map (lambda (testp)
(last (string-split testp "/")))
tests)))))
- (string-split test-patts ","))
+ (if test-patts (string-split test-patts ",")(list "%")))
;; now remove duplicates
(set! test-names (delete-duplicates test-names))
(debug:print 0 "INFO: test names " test-names)
- ;; now add non-directly referenced dependencies (i.e. waiton)
- ;; could cache all these since they need to be read again ...
- ;; FIXME SOMEDAY
- (if (not (null? test-names))
- (let loop ((hed (car test-names))
- (tal (cdr test-names)))
- (let* ((config (test:get-testconfig hed #f))
- (waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
- (if w w "")))))
- (for-each
- (lambda (waiton)
- (if (and waiton (not (member waiton test-names)))
- (begin
- (set! required-tests (cons waiton required-tests))
- (set! test-names (append test-names (list waiton))))))
- waitons)
- (let ((remtests (delete-duplicates (append waitons tal))))
- (if (not (null? remtests))
- (loop (car remtests)(cdr remtests)))))))
-
- (if (not (null? required-tests))
- (debug:print 1 "INFO: Adding " required-tests " to the run queue"))
-
;; on the first pass or call to run-tests set FAILS to NOT_STARTED if
;; -keepgoing is specified
- (if (and (eq? *passnum* 0)
- keepgoing)
+ (if (eq? *passnum* 0)
(begin
;; have to delete test records where NOT_STARTED since they can cause -keepgoing to
;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends
;; on test A but test B reached the point on being registered as NOT_STARTED and test
;; A failed for some reason then on re-run using -keepgoing the run can never complete.
(db:delete-tests-in-state db run-id "NOT_STARTED")
(db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL")))
- (set! *passnum* (+ *passnum* 1))
- (let loop ((numtimes 0))
- (for-each
- (lambda (test-name)
- (if (runs:can-run-more-tests db)
- (run:test db run-id runname test-name keyvallst item-patts flags)
- ))
- (tests:sort-by-priority-and-waiton test-names))
- ;; (run-waiting-tests db)
- (if keepgoing
- (let ((estrem (db:estimated-tests-remaining db run-id)))
- (if (and (> estrem 0)
- (eq? *globalexitstatus* 0))
- (begin
- (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...")
- (thread-sleep! 3)
- (run-waiting-tests db)
- (loop (+ numtimes 1)))))))))
-
-(define (run:test db run-id runname test-name keyvallst item-patts flags)
- (debug:print 1 "Launching test " test-name)
+
+ ;; now add non-directly referenced dependencies (i.e. waiton)
+ (if (not (null? test-names))
+ (let loop ((hed (car test-names))
+ (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
+ (let* ((config (test:get-testconfig hed 'return-procs))
+ (waitons (string-split (let ((w (config-lookup config "requirements" "waiton")))
+ (if w w "")))))
+ ;; (items (items:get-items-from-config config)))
+ (if (not (hash-table-ref/default test-records hed #f))
+ (hash-table-set! test-records
+ hed (vector hed ;; 0
+ config ;; 1
+ waitons ;; 2
+ (config-lookup config "requirements" "priority") ;; priority 3
+ (let ((items (hash-table-ref/default config "items" #f)) ;; items 4
+ (itemstable (hash-table-ref/default config "itemstable" #f)))
+ ;; if either items or items table is a proc return it so test running
+ ;; process can know to call items:get-items-from-config
+ ;; if either is a list and none is a proc go ahead and call get-items
+ ;; otherwise return #f - this is not an iterated test
+ (cond
+ ((procedure? items)
+ (debug:print 4 "INFO: items is a procedure, will calc later")
+ items) ;; calc later
+ ((procedure? itemstable)
+ (debug:print 4 "INFO: itemstable is a procedure, will calc later")
+ itemstable) ;; calc later
+ ((filter (lambda (x)
+ (let ((val (car x)))
+ (if (procedure? val) val #f)))
+ (append (if (list? items) items '())
+ (if (list? itemstable) itemstable '())))
+ 'have-procedure)
+ ((or (list? items)(list? itemstable)) ;; calc now
+ (debug:print 4 "INFO: items and itemstable are lists, calc now\n"
+ " items: " items " itemstable: " itemstable)
+ (items:get-items-from-config config))
+ (else #f))) ;; not iterated
+ #f ;; itemsdat 5
+ ;; #f ;; spare
+ )))
+ (for-each
+ (lambda (waiton)
+ (if (and waiton (not (member waiton test-names)))
+ (begin
+ (set! required-tests (cons waiton required-tests))
+ (set! test-names (cons waiton test-names))))) ;; was an append, now a cons
+ waitons)
+ (let ((remtests (delete-duplicates (append waitons tal))))
+ (if (not (null? remtests))
+ (loop (car remtests)(cdr remtests)))))))
+
+ (if (not (null? required-tests))
+ (debug:print 1 "INFO: Adding " required-tests " to the run queue"))
+ ;; NOTE: these are all parent tests, items are not expanded yet.
+ (runs:run-tests-queue db run-id runname test-records keyvallst flags)
+ (debug:print 4 "INFO: All done by here")))
+
+(define (runs:run-tests-queue db run-id runname test-records keyvallst flags)
+ ;; At this point the list of parent tests is expanded
+ ;; NB// Should expand items here and then insert into the run queue.
+ (debug:print 5 "test-records: " test-records ", keyvallst: " keyvallst)
+ (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records))
+ (item-patts (hash-table-ref/default flags "-itempatt" #f)))
+ (let loop (; (numtimes 0) ;; shouldn't need this
+ (hed (car sorted-test-names))
+ (tal (cdr sorted-test-names)))
+ (let* ((test-record (hash-table-ref test-records hed))
+ (tconfig (tests:testqueue-get-testconfig test-record))
+ (waitons (tests:testqueue-get-waitons test-record))
+ (priority (tests:testqueue-get-priority test-record))
+ (itemdat (tests:testqueue-get-itemdat test-record))
+ (items (tests:testqueue-get-items test-record))
+ (item-path (item-list->path itemdat)))
+ (debug:print 6
+ "itemdat: " itemdat
+ "\n items: " items
+ "\n item-path: " item-path)
+ (cond
+ ((not items) ;; when false the test is ok to be handed off to launch (but not before)
+ (let ((have-resources (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running
+ (prereqs-not-met (db:get-prereqs-not-met db run-id waitons item-path)))
+ ;; Don't know at this time if the test have been launched at some time in the past
+ ;; i.e. is this a re-launch?
+ (if (and have-resources
+ (null? prereqs-not-met))
+ ;; no loop - drop though and use the loop at the bottom
+ (run:test db run-id runname keyvallst test-record flags #f)
+ ;; else the run is stuck, temporarily or permanently
+ (let ((newtal (append tal (list hed))))
+ ;; couldn't run, take a breather
+ (thread-sleep! 4)
+ (loop (car newtal)(cdr newtal))))))
+
+ ;; case where an items came in as a list been processed
+ ((and (list? items) ;; thus we know our items are already calculated
+ (not itemdat)) ;; and not yet expanded into the list of things to be done
+ (if (>= *verbosity* 1)(pp items))
+ ;; (if (>= *verbosity* 5)
+ ;; (begin
+ ;; (print "items: ") (pp (item-assoc->item-list items))
+ ;; (print "itemstable: ")(pp (item-table->item-list itemstable))))
+ (for-each
+ (lambda (my-itemdat)
+ (let* ((new-test-record (let ((newrec (make-tests:testqueue)))
+ (vector-copy! test-record newrec)
+ newrec))
+ (my-item-path (item-list->path my-itemdat))
+ (item-matches (if item-patts ;; here we are filtering for matches with -itempatt
+ (let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
+ (for-each
+ (lambda (patt)
+ (if (string-search (glob->regexp
+ (string-translate patt "%" "*"))
+ item-path)
+ (set! res #t)))
+ (string-split item-patts ","))
+ res)
+ #t)))
+ (if item-matches ;; yes, we want to process this item
+ (let ((newtestname (conc hed "/" my-item-path)))
+ (tests:testqueue-set-items! new-test-record #f)
+ (tests:testqueue-set-itemdat! new-test-record my-itemdat)
+ (hash-table-set! test-records newtestname new-test-record)
+ (set! tal (cons newtestname tal)))))) ;; since these are itemized create new test names testname/itempath
+ items)
+ (loop (car tal)(cdr tal)))
+
+ ;; if items is a proc then need to run items:get-items-from-config, get the list and loop
+ ;; - but only do that if resources exist to kick off the job
+ ((or (procedure? items)(eq? items 'have-procedure))
+ (if (and (runs:can-run-more-tests db test-record)
+ (null? (db:get-prereqs-not-met db run-id waitons item-path)))
+ (let ((test-name (tests:testqueue-get-testname test-record)))
+ (setenv "MT_TEST_NAME" test-name) ;;
+ (setenv "MT_RUNNAME" runname)
+ (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
+ (let ((items-list (items:get-items-from-config tconfig)))
+ (if (list? items-list)
+ (begin
+ (tests:testqueue-set-items! test-record items-list)
+ (loop hed tal))
+ (begin
+ (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
+ (exit 1)))))
+ (let ((newtal (append tal (list hed))))
+ ;; if can't run more tests, lets take a breather
+ (thread-sleep! 1)
+ (loop (car newtal)(cdr newtal)))))
+
+ ;; this case should not happen, added to help catch any bugs
+ ((and (list? items) itemdat)
+ (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this")
+ (exit 1))))
+
+ ;; we get here on "drop through" - loop for next test in queue
+ (if (null? tal)
+ (begin
+ ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!!
+ (debug:print 1 "INFO: All tests launched, exiting")
+ (exit 0))
+ (loop (car tal)(cdr tal))))))
+
+;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
+(define (run:test db run-id runname keyvallst test-record flags parent-test)
;; All these vars might be referenced by the testconfig file reader
- (setenv "MT_TEST_NAME" test-name) ;;
- (setenv "MT_RUNNAME" runname)
- (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
- (change-directory *toppath*)
- (let* ((test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ...
- (test-configf (conc test-path "/testconfig"))
- (testexists (and (file-exists? test-configf)(file-read-access? test-configf)))
- (test-conf (if testexists (read-config test-configf #f #t) (make-hash-table)))
- (waiton (let ((w (config-lookup test-conf "requirements" "waiton")))
- (if (string? w)(string-split w)'())))
+ (let* ((test-name (tests:testqueue-get-testname test-record))
+ (test-waitons (tests:testqueue-get-waitons test-record))
+ (test-conf (tests:testqueue-get-testconfig test-record))
+ (itemdat (tests:testqueue-get-itemdat test-record))
+ (test-path (conc *toppath* "/tests/" test-name)) ;; could use test: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))
- ;; Are these tags still used? I don't think so...
- ;;(tags (let ((t (config-lookup test-conf "setup" "tags")))
- ;; ;; we want our tags to be separated by commas and fully delimited by commas
- ;; ;; so that queries with "like" can tie to the commas at either end of each tag
- ;; ;; while also allowing the end user to freely use spaces and commas to separate tags
- ;; (if (string? t)(string-substitute (regexp "[,\\s]+") "," (conc "," t ",") #t)
- ;; '()))))
- )
- (if (not testexists)
- ;; if the test is ill defined spit out an error but keep going (different from how done previously
- (debug:print 0 "ERROR: Can't find config file " test-configf)
- ;; put top vars into convenient variables and open the db
- (let* (;; db is always at *toppath*/db/megatest.db
- (items (hash-table-ref/default test-conf "items" '()))
- (itemstable (hash-table-ref/default test-conf "itemstable" '()))
- (allitems (if (or (not (null? items))(not (null? itemstable)))
- (append (item-assoc->item-list items)
- (item-table->item-list itemstable))
- '(())))) ;; a list with one null list is a test with no items
- ;; (runconfigf (conc *toppath* "/runconfigs.config")))
- (debug:print 1 "items: ")
- (if (>= *verbosity* 1)(pp allitems))
- (if (>= *verbosity* 5)
- (begin
- (print "items: ")(pp (item-assoc->item-list items))
- (print "itemstable: ")(pp (item-table->item-list itemstable))))
-
- ;; Comments are loaded by the test run, not at launch time (in general)
- ;;(if (args:get-arg "-m")
- ;; (db:set-comment-for-run db run-id (args:get-arg "-m")))
-
- ;; Here is where the test_meta table is best updated
- (runs:update-test_meta db test-name test-conf)
-
- ;; braindead work-around for poorly specified allitems list BUG!!! FIXME
- (if (null? allitems)(set! allitems '(())))
- (let loop ((itemdat (car allitems))
- (tal (cdr allitems)))
- ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
- ;; Handle lists of items
- (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/"))
- (new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
- (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
- (testdat #f)
- (num-running (db:get-count-tests-running db))
- (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))
- (parent-test (and (not (null? items))(equal? item-path "")))
- (single-test (and (null? items) (equal? item-path "")))
- (item-test (not (equal? item-path "")))
- ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is %
- (item-matches (if item-patts
- (let ((res #f))
- (for-each
- (lambda (patt)
- (if (string-search (glob->regexp
- (string-translate patt "%" "*"))
- item-path)
- (set! res #t)))
- (string-split item-patts ","))
- res)
- #t)))
- (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
- (if (and item-matches (runs:can-run-more-tests db))
- (begin
- (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f)
- (ct 0))
- (if (and (not ts)
- (< ct 10))
- (begin
- (register-test db run-id test-name item-path)
- ;; Why did I set the comment here?!? POSSIBLE BUG BUT I'M REMOVING IT FOR NOW 10/23/2011
- ;; (db:test-set-comment db run-id test-name item-path "")
- (loop2 (db:get-test-info db run-id test-name item-path)
- (+ ct 1)))
- (if ts
- (set! testdat ts)
- (begin
- (debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping")
- (if (not (null? tal))
- (loop (car tal)(cdr tal)))))))
- (change-directory test-path)
- ;; this block is here only to inform the user early on
-
- ;; Moving this to the run calling block
-
- ;; (if (file-exists? runconfigf)
- ;; (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*)
- ;; (debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
- (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat))
- (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 0 "ERROR: Failed to insert the record into the db"))
- ((NOT_STARTED COMPLETED)
- (debug:print 6 "Got here, " (test:get-state testdat))
- (let ((runflag #f))
- (cond
- ;; i.e. this is the parent test to a suite of items, never "run" it
- (parent-test
- (set! runflag #f))
- ;; -force, run no matter what
- (force (set! runflag #t))
- ;; NOT_STARTED, run no matter what
- ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t))
- ;; not -rerun and PASS, WARN or CHECK, do no run
- ((and (or (not rerun)
- keepgoing)
- (member (test:get-status testdat) '("PASS" "WARN" "CHECK")))
- (set! runflag #f))
- ;; -rerun and status is one of the specifed, run it
- ((and rerun
- (let ((rerunlst (string-split rerun ","))) ;; FAIL,
- (member (test:get-status testdat) rerunlst)))
- (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 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
- (if (not runflag)
- (if (not parent-test)
- (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override"))
- (let* ((get-prereqs-cmd (lambda ()
- (db-get-prereqs-not-met db run-id waiton))) ;; check before running ....
- (launch-cmd (lambda ()
- (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags)))
- (testrundat (list get-prereqs-cmd launch-cmd)))
- (if (or force
- (let ((preqs-not-yet-met ((car testrundat))))
- (debug:print 2 "Preqrequesites for " test-name ": " preqs-not-yet-met)
- (null? preqs-not-yet-met))) ;; are there any tests that must be run before this one...
- (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host
- (begin
- (print "ERROR: Failed to launch the test. Exiting as soon as possible")
- (set! *globalexitstatus* 1) ;;
- (process-signal (current-process-id) signal/kill)
- ;(exit 1)
- ))
- (if (not keepgoing)
- (hash-table-set! *waiting-queue* new-test-name testrundat)))))))
- ((KILLED)
- (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
- ((LAUNCHED REMOTEHOSTSTART RUNNING)
- (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
- (db:test-get-run_duration testdat)))
- 100) ;; i.e. no update for more than 100 seconds
- (begin
- (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
- (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead" #f))
- (debug:print 2 "NOTE: " test-name " is already running")))
- (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))
- (if (not (null? tal))
- (loop (car tal)(cdr tal)))))))))
+ (item-path ""))
+ (debug:print 5
+ "test-config: " (hash-table->alist test-conf)
+ "\n itemdat: " itemdat
+ )
+ ;; setting itemdat to a list if it is #f
+ (if (not itemdat)(set! itemdat '()))
+ (set! item-path (item-list->path itemdat))
+ (debug:print 2 "Attempting to launch test " test-name "/" item-path)
+ (setenv "MT_TEST_NAME" test-name) ;;
+ (setenv "MT_RUNNAME" runname)
+ (set-megatest-env-vars db run-id) ;; these may be needed by the launching process
+ (change-directory *toppath*)
+
+ ;; Here is where the test_meta table is best updated
+ (runs:update-test_meta db test-name test-conf)
+
+ ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer"))
+ (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/"))
+ (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique
+ (testdat (db:get-test-info db run-id test-name item-path)))
+ (if (not testdat)
+ (begin
+ (register-test db run-id test-name item-path)
+ (set! testdat (db:get-test-info db run-id test-name item-path))))
+ (change-directory test-path)
+ (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 0 "ERROR: Failed to insert the record into the db"))
+ ((NOT_STARTED COMPLETED)
+ (debug:print 6 "Got here, " (test:get-state testdat))
+ (let ((runflag #f))
+ (cond
+ ;; -force, run no matter what
+ (force (set! runflag #t))
+ ;; NOT_STARTED, run no matter what
+ ((equal? (test:get-state testdat) "NOT_STARTED")(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"))
+ (member (test:get-state testdat) '("COMPLETED"))))
+ (set! runflag #f))
+ ;; -rerun and status is one of the specifed, run it
+ ((and rerun
+ (let ((rerunlst (string-split rerun ","))) ;; FAIL,
+ (member (test:get-status testdat) rerunlst)))
+ (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 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat))
+ (if (not runflag)
+ (if (not parent-test)
+ (debug:print 1 "NOTE: Not starting test " new-test-name " as it is state \"" (test:get-state testdat)
+ "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-state testdat) "\" or -force to override"))
+ ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are
+ ;; already met.
+ (if (not (launch-test db run-id runname test-conf keyvallst 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 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it."))
+ ((LAUNCHED REMOTEHOSTSTART RUNNING)
+ (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
+ (db:test-get-run_duration testdat)))
+ 600) ;; i.e. no update for more than 600 seconds
+ (begin
+ (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
+ (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead" #f))
+ (debug:print 2 "NOTE: " test-name " is already running")))
+ (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat)))))))
;;======================================================================
;; END OF NEW STUFF
;;======================================================================
@@ -1213,14 +570,22 @@
;;======================================================================
;; Since many calls to a run require pretty much the same setup
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
- (if (not (args:get-arg ":runname"))
- (begin
- (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname")
- (exit 2))
+ (let ((runname (args:get-arg ":runname"))
+ (target (if (args:get-arg "-target")
+ (args:get-arg "-target")
+ (args:get-arg "-reqtarg"))))
+ (cond
+ ((not target)
+ (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target")
+ (exit 3))
+ ((not runname)
+ (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the run name with :runname runname")
+ (exit 3))
+ (else
(let ((db #f)
(keys #f))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
@@ -1245,13 +610,13 @@
(exit 1))
;; Extract out stuff needed in most or many calls
;; here then call proc
(let* ((keynames (map key:get-fieldname keys))
(keyvallst (keys->vallist keys #t)))
- (proc db keys keynames keyvallst)))
+ (proc db target runname keys keynames keyvallst)))
(sqlite3:finalize! db)
- (set! *didsomething* #t))))
+ (set! *didsomething* #t))))))
;;======================================================================
;; Rollup runs
;;======================================================================
@@ -1265,10 +630,11 @@
(for-each
(lambda (key)
(let* ((idx (cadr key))
(fld (car key))
(val (config-lookup test-conf "test_meta" fld)))
+ ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val)
(if (and val (not (equal? (vector-ref currrecord idx) val)))
(begin
(print "Updating " test-name " " fld " to " val)
(db:testmeta-update-field db test-name fld val)))))
'(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)))))
@@ -1293,11 +659,11 @@
(new-run-id (runs:register-run db keys keyvallst runname "new" "n/a" user))
(prev-tests (test:get-matching-previous-test-run-records db new-run-id "%" "%"))
(curr-tests (db-get-tests-for-run db new-run-id "%" "%" '() '()))
(curr-tests-hash (make-hash-table)))
(db:update-run-event_time db new-run-id)
- ;; index the already saved tests by testname and itempath in curr-tests-hash
+ ;; index the already saved tests by testname and itemdat in curr-tests-hash
(for-each
(lambda (testdat)
(let* ((testname (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
(full-name (conc testname "/" item-path)))
ADDED test_records.scm
Index: test_records.scm
==================================================================
--- /dev/null
+++ test_records.scm
@@ -0,0 +1,16 @@
+;; make-vector-record tests testqueue testname testconfig waitons priority items
+(define (make-tests:testqueue)(make-vector 6 #f))
+(define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0))
+(define-inline (tests:testqueue-get-testconfig vec) (vector-ref vec 1))
+(define-inline (tests:testqueue-get-waitons vec) (vector-ref vec 2))
+(define-inline (tests:testqueue-get-priority vec) (vector-ref vec 3))
+;; items: #f=no items, list=list of items remaining, proc=need to call to get items
+(define-inline (tests:testqueue-get-items vec) (vector-ref vec 4))
+(define-inline (tests:testqueue-get-itemdat vec) (vector-ref vec 5))
+
+(define-inline (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val))
+(define-inline (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val))
+(define-inline (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val))
+(define-inline (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val))
+(define-inline (tests:testqueue-set-items! vec val)(vector-set! vec 4 val))
+(define-inline (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))
ADDED tests.scm
Index: tests.scm
==================================================================
--- /dev/null
+++ tests.scm
@@ -0,0 +1,430 @@
+(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (unit tests))
+(declare (uses db))
+(declare (uses common))
+(declare (uses items))
+(declare (uses runconfig))
+
+(include "common_records.scm")
+(include "key_records.scm")
+(include "db_records.scm")
+(include "run_records.scm")
+(include "test_records.scm")
+
+
+(define (register-test db run-id test-name item-path)
+ (let ((item-paths (if (equal? item-path "")
+ (list item-path)
+ (list item-path ""))))
+ (for-each
+ (lambda (pth)
+ (sqlite3:execute db "INSERT OR IGNORE INTO tests (run_id,testname,event_time,item_path,state,status) VALUES (?,?,strftime('%s','now'),?,'NOT_STARTED','n/a');"
+ run-id
+ test-name
+ pth
+ ;; (conc "," (string-intersperse tags ",") ",")
+ ))
+ item-paths )))
+
+;; get the previous record for when this test was run where all keys match but runname
+;; returns #f if no such test found, returns a single test record if found
+(define (test:get-previous-test-run-record db run-id test-name item-path)
+ (let* ((keys (db:get-keys db))
+ (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
+ (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
+ (keyvals #f))
+ ;; first look up the key values from the run selected by run-id
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! keyvals (cons a b)))
+ db
+ (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
+ (if (not keyvals)
+ #f
+ (let ((prev-run-ids '()))
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! prev-run-ids (cons id prev-run-ids)))
+ db
+ (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
+ ;; for each run starting with the most recent look to see if there is a matching test
+ ;; if found then return that matching test record
+ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals ", previous run ids found: " prev-run-ids)
+ (if (null? prev-run-ids) #f
+ (let loop ((hed (car prev-run-ids))
+ (tal (cdr prev-run-ids)))
+ (let ((results (db-get-tests-for-run db hed test-name item-path '() '())))
+ (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name ", item-path " item-path ": " results)
+ (if (and (null? results)
+ (not (null? tal)))
+ (loop (car tal)(cdr tal))
+ (if (null? results) #f
+ (car results))))))))))
+
+;; get the previous records for when these tests were run where all keys match but runname
+;; NB// Merge this with test:get-previous-test-run-records? This one looks for all matching tests
+;; can use wildcards.
+(define (test:get-matching-previous-test-run-records db run-id test-name item-path)
+ (let* ((keys (db:get-keys db))
+ (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ","))
+ (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND "))
+ (keyvals #f)
+ (tests-hash (make-hash-table)))
+ ;; first look up the key values from the run selected by run-id
+ (sqlite3:for-each-row
+ (lambda (a . b)
+ (set! keyvals (cons a b)))
+ db
+ (conc "SELECT " selstr " FROM runs WHERE id=? ORDER BY event_time DESC;") run-id)
+ (if (not keyvals)
+ '()
+ (let ((prev-run-ids '()))
+ (apply sqlite3:for-each-row
+ (lambda (id)
+ (set! prev-run-ids (cons id prev-run-ids)))
+ db
+ (conc "SELECT id FROM runs WHERE " qrystr " AND id != ?;") (append keyvals (list run-id)))
+ ;; collect all matching tests for the runs then
+ ;; extract the most recent test and return that.
+ (debug:print 4 "selstr: " selstr ", qrystr: " qrystr ", keyvals: " keyvals
+ ", previous run ids found: " prev-run-ids)
+ (if (null? prev-run-ids) '() ;; no previous runs? return null
+ (let loop ((hed (car prev-run-ids))
+ (tal (cdr prev-run-ids)))
+ (let ((results (db-get-tests-for-run db hed test-name item-path '() '())))
+ (debug:print 4 "Got tests for run-id " run-id ", test-name " test-name
+ ", item-path " item-path " results: " (intersperse results "\n"))
+ ;; Keep only the youngest of any test/item combination
+ (for-each
+ (lambda (testdat)
+ (let* ((full-testname (conc (db:test-get-testname testdat) "/" (db:test-get-item-path testdat)))
+ (stored-test (hash-table-ref/default tests-hash full-testname #f)))
+ (if (or (not stored-test)
+ (and stored-test
+ (> (db:test-get-event_time testdat)(db:test-get-event_time stored-test))))
+ ;; this test is younger, store it in the hash
+ (hash-table-set! tests-hash full-testname testdat))))
+ results)
+ (if (null? tal)
+ (map cdr (hash-table->alist tests-hash)) ;; return a list of the most recent tests
+ (loop (car tal)(cdr tal))))))))))
+
+(define (test-set-status! db run-id test-name state status itemdat-or-path comment dat)
+ (let* ((real-status status)
+ (item-path (if (string? itemdat-or-path) itemdat-or-path (item-list->path itemdat-or-path)))
+ (testdat (db:get-test-info db run-id test-name item-path))
+ (test-id (if testdat (db:test-get-id testdat) #f))
+ (otherdat (if dat dat (make-hash-table)))
+ ;; before proceeding we must find out if the previous test (where all keys matched except runname)
+ ;; was WAIVED if this test is FAIL
+ (waived (if (equal? status "FAIL")
+ (let ((prev-test (test:get-previous-test-run-record db run-id test-name item-path)))
+ (if prev-test ;; true if we found a previous test in this run series
+ (let ((prev-status (db:test-get-status prev-test))
+ (prev-state (db:test-get-state prev-test))
+ (prev-comment (db:test-get-comment prev-test)))
+ (debug:print 4 "prev-status " prev-status ", prev-state " prev-state ", prev-comment " prev-comment)
+ (if (and (equal? prev-state "COMPLETED")
+ (equal? prev-status "WAIVED"))
+ prev-comment ;; waived is either the comment or #f
+ #f))
+ #f))
+ #f)))
+ (if waived (set! real-status "WAIVED"))
+ (debug:print 4 "real-status " real-status ", waived " waived ", status " status)
+
+ ;; update the primary record IF state AND status are defined
+ (if (and state status)
+ (sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;"
+ state real-status run-id test-name item-path))
+
+ ;; if status is "AUTO" then call rollup
+ (if (and test-id state status (equal? status "AUTO"))
+ (db:test-data-rollup db test-id status))
+
+ ;; add metadata (need to do this way to avoid SQL injection issues)
+
+ ;; :first_err
+ ;; (let ((val (hash-table-ref/default otherdat ":first_err" #f)))
+ ;; (if val
+ ;; (sqlite3:execute db "UPDATE tests SET first_err=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))
+ ;;
+ ;; ;; :first_warn
+ ;; (let ((val (hash-table-ref/default otherdat ":first_warn" #f)))
+ ;; (if val
+ ;; (sqlite3:execute db "UPDATE tests SET first_warn=? WHERE run_id=? AND testname=? AND item_path=?;" val run-id test-name item-path)))
+
+ (let ((category (hash-table-ref/default otherdat ":category" ""))
+ (variable (hash-table-ref/default otherdat ":variable" ""))
+ (value (hash-table-ref/default otherdat ":value" #f))
+ (expected (hash-table-ref/default otherdat ":expected" #f))
+ (tol (hash-table-ref/default otherdat ":tol" #f))
+ (units (hash-table-ref/default otherdat ":units" ""))
+ (type (hash-table-ref/default otherdat ":type" ""))
+ (dcomment (hash-table-ref/default otherdat ":comment" "")))
+ (debug:print 4
+ "category: " category ", variable: " variable ", value: " value
+ ", expected: " expected ", tol: " tol ", units: " units)
+ (if (and value expected tol) ;; all three required
+ (db:csv->test-data db test-id
+ (conc category ","
+ variable ","
+ value ","
+ expected ","
+ tol ","
+ units ","
+ dcomment ",," ;; extra comma for status
+ type ))))
+
+ ;; need to update the top test record if PASS or FAIL and this is a subtest
+ (if (and (not (equal? item-path ""))
+ (or (equal? status "PASS")
+ (equal? status "WARN")
+ (equal? status "FAIL")
+ (equal? status "WAIVED")
+ (equal? status "RUNNING")))
+ (begin
+ (sqlite3:execute
+ db
+ "UPDATE tests
+ SET fail_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND status='FAIL'),
+ pass_count=(SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND (status='PASS' OR status='WARN' OR status='WAIVED'))
+ WHERE run_id=? AND testname=? AND item_path='';"
+ run-id test-name run-id test-name run-id test-name)
+ (if (equal? status "RUNNING") ;; running takes priority over all other states, force the test state to RUNNING
+ (sqlite3:execute db "UPDATE tests SET state=? WHERE run_id=? AND testname=? AND item_path='';" "RUNNING" run-id test-name)
+ (sqlite3:execute
+ db
+ "UPDATE tests
+ SET state=CASE WHEN (SELECT count(id) FROM tests WHERE run_id=? AND testname=? AND item_path != '' AND state in ('RUNNING','NOT_STARTED')) > 0 THEN
+ 'RUNNING'
+ ELSE 'COMPLETED' END,
+ status=CASE WHEN fail_count > 0 THEN 'FAIL' WHEN pass_count > 0 AND fail_count=0 THEN 'PASS' ELSE 'UNKNOWN' END
+ WHERE run_id=? AND testname=? AND item_path='';"
+ run-id test-name run-id test-name))))
+ (if (or (and (string? comment)
+ (string-match (regexp "\\S+") comment))
+ waived)
+ (sqlite3:execute db "UPDATE tests SET comment=? WHERE run_id=? AND testname=? AND item_path=?;"
+ (if waived waived comment) run-id test-name item-path))
+ ))
+
+(define (test-set-log! db run-id test-name itemdat logf)
+ (let ((item-path (item-list->path itemdat)))
+ (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path=?;"
+ logf run-id test-name item-path)))
+
+(define (test-set-toplog! db run-id test-name logf)
+ (sqlite3:execute db "UPDATE tests SET final_logf=? WHERE run_id=? AND testname=? AND item_path='';"
+ logf run-id test-name))
+
+(define (tests:summarize-items db run-id test-name force)
+ ;; if not force then only update the record if one of these is true:
+ ;; 1. logf is "log/final.log
+ ;; 2. logf is same as outputfilename
+ (let ((outputfilename (conc "megatest-rollup-" test-name ".html"))
+ (orig-dir (current-directory))
+ (logf #f))
+ (sqlite3:for-each-row
+ (lambda (path final_logf)
+ (set! logf final_logf)
+ (if (directory? path)
+ (begin
+ (print "Found path: " path)
+ (change-directory path))
+ ;; (set! outputfilename (conc path "/" outputfilename)))
+ (print "No such path: " path)))
+ db
+ "SELECT rundir,final_logf FROM tests WHERE run_id=? AND testname=? AND item_path='';"
+ run-id test-name)
+ (print "summarize-items with logf " logf)
+ (if (or (equal? logf "logs/final.log")
+ (equal? logf outputfilename)
+ force)
+ (begin
+ (if (obtain-dot-lock outputfilename 1 20 30) ;; retry every second for 20 seconds, call it dead after 30 seconds and steal the lock
+ (print "Obtained lock for " outputfilename)
+ (print "Failed to obtain lock for " outputfilename))
+ (let ((oup (open-output-file outputfilename))
+ (counts (make-hash-table))
+ (statecounts (make-hash-table))
+ (outtxt "")
+ (tot 0))
+ (with-output-to-port
+ oup
+ (lambda ()
+ (set! outtxt (conc outtxt "Summary: " test-name
+ "
Summary for " test-name "
"))
+ (sqlite3:for-each-row
+ (lambda (id itempath state status run_duration logf comment)
+ (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0)))
+ (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0)))
+ (set! outtxt (conc outtxt "
")))
+ db
+ "SELECT id,item_path,state,status,run_duration,final_logf,comment FROM tests WHERE run_id=? AND testname=? AND item_path != '';"
+ run-id test-name)
+
+ (print "
")
+ ;; Print out stats for status
+ (set! tot 0)
+ (print "
State stats
")
+ (for-each (lambda (state)
+ (set! tot (+ tot (hash-table-ref statecounts state)))
+ (print "
" state "
" (hash-table-ref statecounts state) "
"))
+ (hash-table-keys statecounts))
+ (print "
Total
" tot "
")
+ (print "
")
+ ;; Print out stats for state
+ (set! tot 0)
+ (print "
Status stats
")
+ (for-each (lambda (status)
+ (set! tot (+ tot (hash-table-ref counts status)))
+ (print "
" status
+ "
" (hash-table-ref counts status) "
"))
+ (hash-table-keys counts))
+ (print "
Total
" tot "
")
+ (print "
")
+
+ (print "
"
+ "
Item
State
Status
Comment
"
+ outtxt "
")
+ (release-dot-lock outputfilename)))
+ (close-output-port oup)
+ (change-directory orig-dir)
+ (test-set-toplog! db run-id test-name outputfilename)
+ )))))
+
+(define (get-all-legal-tests)
+ (let* ((tests (glob (conc *toppath* "/tests/*")))
+ (res '()))
+ (debug:print 4 "INFO: Looking at tests " (string-intersperse tests ","))
+ (for-each (lambda (testpath)
+ (if (file-exists? (conc testpath "/testconfig"))
+ (set! res (cons (last (string-split testpath "/")) res))))
+ tests)
+ res))
+
+(define (test:get-testconfig test-name system-allowed)
+ (let* ((test-path (conc *toppath* "/tests/" test-name))
+ (test-configf (conc test-path "/testconfig"))
+ (testexists (and (file-exists? test-configf)(file-read-access? test-configf))))
+ (if testexists
+ (read-config test-configf #f system-allowed environ-patt: (if system-allowed
+ "pre-launch-env-vars"
+ #f))
+ #f)))
+
+;; sort tests by priority and waiton
+;; Move test specific stuff to a test unit FIXME one of these days
+(define (tests:sort-by-priority-and-waiton test-records)
+ (let ((mungepriority (lambda (priority)
+ (if priority
+ (let ((tmp (any->number priority)))
+ (if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0)))
+ 0))))
+ (sort
+ (hash-table-keys test-records) ;; avoid dealing with deleted tests, look at the hash table
+ (lambda (a b)
+ (let* ((a-record (hash-table-ref test-records a))
+ (b-record (hash-table-ref test-records b))
+ (a-waitons (tests:testqueue-get-waitons a-record))
+ (b-waitons (tests:testqueue-get-waitons b-record))
+ (a-config (tests:testqueue-get-testconfig a-record))
+ (b-config (tests:testqueue-get-testconfig b-record))
+ (a-raw-pri (config-lookup a-config "requirements" "priority"))
+ (b-raw-pri (config-lookup b-config "requirements" "priority"))
+ (a-priority (mungepriority a-raw-pri))
+ (b-priority (mungepriority b-raw-pri)))
+ ;; (debug:print 5 "sort-by-priority-and-waiton, a: " a " b: " b
+ ;; "\n a-record: " a-record
+ ;; "\n b-record: " b-record
+ ;; "\n a-waitons: " a-waitons
+ ;; "\n b-waitons: " b-waitons
+ ;; "\n a-config: " (hash-table->alist a-config)
+ ;; "\n b-config: " (hash-table->alist b-config)
+ ;; "\n a-raw-pri: " a-raw-pri
+ ;; "\n b-raw-pri: " b-raw-pri
+ ;; "\n a-priority: " a-priority
+ ;; "\n b-priority: " b-priority)
+ (tests:testqueue-set-priority! a-record a-priority)
+ (tests:testqueue-set-priority! b-record b-priority)
+ (if (and a-waitons (member (tests:testqueue-get-testname b-record) a-waitons))
+ #f ;; cannot have a which is waiting on b happening before b
+ (if (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons))
+ #t ;; this is the correct order, b is waiting on a and b is before a
+ (if (> a-priority b-priority)
+ #t ;; if a is a higher priority than b then we are good to go
+ #f))))))))
+
+
+;;======================================================================
+;; test steps
+;;======================================================================
+
+(define (teststep-set-status! db run-id test-name teststep-name state-in status-in itemdat comment logfile)
+ (debug:print 4 "run-id: " run-id " test-name: " test-name)
+ (let* ((state (check-valid-items "state" state-in))
+ (status (check-valid-items "status" status-in))
+ (item-path (item-list->path itemdat))
+ (testdat (db:get-test-info db run-id test-name item-path)))
+ (debug:print 5 "testdat: " testdat)
+ (if (and testdat ;; if the section exists then force specification BUG, I don't like how this works.
+ (or (not state)(not status)))
+ (debug:print 0 "WARNING: Invalid " (if status "status" "state")
+ " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
+ (if testdat
+ (let ((test-id (test:get-id testdat)))
+ ;; FIXME - this should not update the logfile unless it is specified.
+ (sqlite3:execute db
+ "INSERT OR REPLACE into test_steps (test_id,stepname,state,status,event_time,comment,logfile) VALUES(?,?,?,?,strftime('%s','now'),?,?);"
+ test-id teststep-name state-in status-in (if comment comment "") (if logfile logfile "")))
+ (debug:print 0 "ERROR: Can't update " test-name " for run " run-id " -> no such test in db"))))
+
+(define (test-get-kill-request db run-id test-name itemdat)
+ (let* ((item-path (item-list->path itemdat))
+ (testdat (db:get-test-info db run-id test-name item-path)))
+ (equal? (test:get-state testdat) "KILLREQ")))
+
+(define (test-set-meta-info db run-id testname itemdat)
+ (let ((item-path (item-list->path itemdat))
+ (cpuload (get-cpu-load))
+ (hostname (get-host-name))
+ (diskfree (get-df (current-directory)))
+ (uname (get-uname "-srvpio"))
+ (runpath (current-directory)))
+ (sqlite3:execute db "UPDATE tests SET host=?,cpuload=?,diskfree=?,uname=?,rundir=? WHERE run_id=? AND testname=? AND item_path=?;"
+ hostname
+ cpuload
+ diskfree
+ uname
+ runpath
+ run-id
+ testname
+ item-path)))
+
+(define (test-update-meta-info db run-id testname itemdat minutes cpuload diskfree tmpfree)
+ (let ((item-path (item-list->path itemdat)))
+ (if (not item-path)(begin (debug:print 0 "WARNING: ITEMPATH not set.") (set! item-path "")))
+ ;; (let ((testinfo (db:get-test-info db run-id testname item-path)))
+ ;; (if (and (not (equal? (db:test-get-status testinfo) "COMPLETED"))
+ ;; (not (equal? (db:test-get-status testinfo) "KILLREQ"))
+ (sqlite3:execute
+ db
+ "UPDATE tests SET cpuload=?,diskfree=?,run_duration=?,state='RUNNING' WHERE run_id=? AND testname=? AND item_path=? AND state NOT IN ('COMPLETED','KILLREQ','KILLED');"
+ cpuload
+ diskfree
+ minutes
+ run-id
+ testname
+ item-path)))
+
Index: tests/Makefile
==================================================================
--- tests/Makefile
+++ tests/Makefile
@@ -4,15 +4,15 @@
MEGATEST=$(BINPATH)/megatest
PATH := $(BINPATH):$(PATH)
runall :
cd ../;make install
- $(BINPATH)/dboard &
- $(MEGATEST) -keepgoing -runall :sysname ubuntu :fsname nfs :datapath none :runname `date +w%V.%u.%H` -m "This is a comment specific to a run" -v
+ $(BINPATH)/dboard -rows 15 &
+ $(MEGATEST) -keepgoing -runall -target ubuntu/nfs/none :runname `date +w%V.%u.%H` -m "This is a comment specific to a run" -v
test :
- csi -b -I .. ../megatest.scm -- -runall :sysname ubuntu :fsname afs :datapath tmp :runname blah
+ csi -b -I .. ../megatest.scm -- -runall -target ubuntu/afs/tmp :runname blah
cd ../;make test
make runall
dashboard :
cd ../;make dboard
@@ -20,6 +20,6 @@
remove :
(cd ../;make);$(MEGATEST) -remove-runs :runname $(RUN) -testpatt % -itempatt % :sysname % :fsname % :datapath %
runforever :
- while(ls); do runname=`date +%F-%R:%S`;$(MEGATEST) -runall :sysname ubuntu :fsname nfs :datapath none :runname $$runname;/home/matt/data/megatest/megatest -runall :sysname ubuntu :fsname nfs :datapath none :runname $$runname;/home/matt/data/megatest/megatest -runall :sysname ubuntu :fsname nfs :datapath none :runname $$runname;done
+ while(ls); do runname=`date +%F-%R:%S`;$(MEGATEST) -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname;/home/matt/data/megatest/megatest -runall -target ubuntu/nfs/none :runname $$runname;done
Index: tests/megatest.config
==================================================================
--- tests/megatest.config
+++ tests/megatest.config
@@ -4,11 +4,11 @@
datapath TEXT
[setup]
# exectutable /path/to/megatest
max_concurrent_jobs 50
-runsdir /tmp/runs
+linktree /tmp/runs
[jobtools]
# useshell yes
# ## launcher launches jobs, the job is managed on the target host
## by megatest, comment out launcher to run local
ADDED tests/tests/ez_exit2_fail/testconfig
Index: tests/tests/ez_exit2_fail/testconfig
==================================================================
--- /dev/null
+++ tests/tests/ez_exit2_fail/testconfig
@@ -0,0 +1,15 @@
+[setup]
+
+[ezsteps]
+exit2 exit 2
+lookithome ls /home
+
+[test_meta]
+author matt
+owner bob
+description This test runs two steps; the first exits with
+ code 2 (a fail because not using logpro) and the second
+ is a pass
+
+tags first,single
+reviewed 09/10/2011, by Matt
Index: tests/tests/ez_fail/testconfig
==================================================================
--- tests/tests/ez_fail/testconfig
+++ tests/tests/ez_fail/testconfig
@@ -2,14 +2,15 @@
[requirements]
priority 10
[ezsteps]
-lookittmp ls /tmp
-lookithome ls /home
-lookitnada ls /nada
-lookitusr ls /usr
+lookittmp sleep 5s;ls /tmp
+lookithome sleep 2;ls /home
+# should fail on next step
+lookitnada sleep 3;ls /nada
+lookitusr sleep 2;ls /usr
[test_meta]
author matt
owner bob
description This test runs a single ezstep which is expected to pass, no logpro file.
DELETED tests/tests/ez_warn/testconfig
Index: tests/tests/ez_warn/testconfig
==================================================================
--- tests/tests/ez_warn/testconfig
+++ /dev/null
@@ -1,15 +0,0 @@
-[setup]
-
-[ezsteps]
-exit2 exit 2
-lookithome ls /home
-
-[test_meta]
-author matt
-owner bob
-description This test runs two steps; the first exits with
- code 2 (a fail because not using logpro) and the second
- is a pass
-
-tags first,single
-reviewed 09/10/2011, by Matt
Index: tests/tests/ezlog_fail/lookittmp.logpro
==================================================================
--- tests/tests/ezlog_fail/lookittmp.logpro
+++ tests/tests/ezlog_fail/lookittmp.logpro
@@ -1,8 +1,6 @@
;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com
;;
;; License GPL.
-
-(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/)
(expect:warning in "LogFileBody" = 0 "Any warning" #/WARNING/)
(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/.*/)) ;; force an error
Index: tests/tests/ezlog_warn/lookittmp.logpro
==================================================================
--- tests/tests/ezlog_warn/lookittmp.logpro
+++ tests/tests/ezlog_warn/lookittmp.logpro
@@ -2,9 +2,11 @@
;;
;; License GPL.
(expect:warning in "LogFileBody" = 0 "Any warning" #/.*/)
-(expect:required in "LogFileBody" > 0 "Must be some files in the dir" #/.*/)
+;; Can't have a required since it will mask the warns! Could make the warn non-overlapping with the
+;; required I suppose...
+;; (expect:required in "LogFileBody" > 0 "Must be some files in the dir" #/.*/)
(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/)
(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors
ADDED tests/tests/logpro_required_fail/lookittmp.logpro
Index: tests/tests/logpro_required_fail/lookittmp.logpro
==================================================================
--- /dev/null
+++ tests/tests/logpro_required_fail/lookittmp.logpro
@@ -0,0 +1,8 @@
+;; (c) 2006,2007,2008,2009 Matthew Welland matt@kiatoa.com
+;;
+;; License GPL.
+
+(expect:required in "LogFileBody" > 0 "A file name that should never exist!" #/This is a awfully stupid file name that should never be found in the temp dir/)
+
+;; (expect:warning in "LogFileBody" = 0 "Any warning" #/WARNING/)
+;; (expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/.*/)) ;; force an error
ADDED tests/tests/logpro_required_fail/testconfig
Index: tests/tests/logpro_required_fail/testconfig
==================================================================
--- /dev/null
+++ tests/tests/logpro_required_fail/testconfig
@@ -0,0 +1,12 @@
+[setup]
+
+[ezsteps]
+lookittmp ls /tmp
+
+[test_meta]
+author matt
+owner bob
+description This test runs two ezstep, the first of which is expected to fail using a simple logpro file.
+
+tags logpro
+reviewed 09/10/2011, by Matt
Index: tests/tests/runfirst/main.sh
==================================================================
--- tests/tests/runfirst/main.sh
+++ tests/tests/runfirst/main.sh
@@ -3,10 +3,12 @@
# megatest -step wasting_time :state start :status n/a -m "This is a test step comment"
# sleep 20
# megatest -step wasting_time :state end :status $?
touch ../I_was_here
+mkdir -p $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME
+echo 1 2 3 4 5 > $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME/the_ans
$MT_MEGATEST -runstep wasting_time -logpro wasting_time.logpro "sleep 8;echo all done eh?" -m "This is a test step comment"
$MT_MEGATEST -load-test-data << EOF
foo,bar,1.2,1.9,>
@@ -16,9 +18,14 @@
foo,alb,1.2,1.2,<=,Amps,This is the high power circuit test
foo,abl,1.2,1.3,0.1
foo,bra,1.2,pass,silly stuff
faz,bar,10,8mA,,,"this is a comment"
EOF
+
+$MT_MEGATEST -load-test-data << EOF
+cat, var, val, exp, comp, units, comment, status, type
+ameas,iout,1.2,1.9,>,Amps,Comment,,meas
+EOF
$MT_MEGATEST -test-status :state COMPLETED :status $? -m "This is a test level comment" :value 10e6 :expected_value 1.1e6 :tol 100e3 :category nada :variable sillyvar :units mFarks :comment "This is the value/expected comment"
# $MT_MEGATEST -test-status :state COMPLETED :status FAIL
ADDED tests/tests/test_mt_vars/testconfig
Index: tests/tests/test_mt_vars/testconfig
==================================================================
--- /dev/null
+++ tests/tests/test_mt_vars/testconfig
@@ -0,0 +1,20 @@
+[setup]
+
+[ezsteps]
+lookittmp ls /tmp
+lookithome ls /home
+
+[requirements]
+waiton runfirst
+priority 0
+
+[items]
+NUMNUM [system cat $MT_RUN_AREA_HOME/tmp/$USER/$sysname/$fsname/$datapath/$MT_RUNNAME/the_ans]
+
+[test_meta]
+author matt
+owner bob
+description This test runs a single ezstep which is expected to pass, no logpro file.
+
+tags first,single
+reviewed 09/10/2011, by Matt
DELETED tree.scm
Index: tree.scm
==================================================================
--- tree.scm
+++ /dev/null
@@ -1,28 +0,0 @@
-
-(use iup canvas-draw canvas-draw-iup)
-
-(define t #f)
-
-(define tree-dialog
- (dialog
- #:title "Tree Test"
- (let ((t1 (treebox
- #:selection_cb (lambda (obj id state)
- (print "selection_db with id=" id " state=" state)
- (print "SPECIALDATA: " (attribute obj "SPECIALDATA"))
- ))))
- (set! t t1)
- t1)))
-
-(show tree-dialog)
-(map (lambda (elname el)
- (print "Adding " elname " with value " el)
- (attribute-set! t elname el)
- (attribute-set! t "SPECIALDATA" el))
- '("VALUE" "NAME" "ADDLEAF" "ADDBRANCH1" "ADDLEAF2" "VALUE")
- '("0" "Figures" "Other" "triangle" "equilateral" "4")
- )
-(map (lambda (attr)
- (print attr " is " (attribute t attr)))
- '("KIND1" "PARENT2" "STATE1"))
-(main-loop)
Index: utils/mt_ezstep
==================================================================
--- utils/mt_ezstep
+++ utils/mt_ezstep
@@ -7,18 +7,25 @@
# Purpose: This is for the [ezsteps] secton in your testconfig file.
# DO NOT USE IN YOUR SCRIPTS!
#
# Call like this:
-# mt_ezstep stepname command ....
+# mt_ezstep stepname prevstepname command ....
#
stepname=$1;shift
+prevstepname=$1;shift
+
command=$*
allstatus=99
runstatus=99
logpropstatus=99
+
+prev_env=.ezsteps/${prevstepname}.sh
+if [ -e $prev_env ];then
+ source $prev_env
+fi
# source the environment from the previous step if it exists
# if a logpro file exists then use it otherwise just run the command, nb// was using 2>&1
if [ -e ${stepname}.logpro ];then
+
+
+
+