Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,16 +7,17 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use srfi-1 data-structures posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack - matchable pkts (prefix dbi dbi:) - regex) - -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) +(use srfi-1 data-structures posix regex-case (prefix base64 base64:) + format dot-locking csv-xml z3 ;; sql-de-lite + hostinfo md5 message-digest typed-records directory-utils stack + matchable regex posix (srfi 18) extras ;; tcp + (prefix nanomsg nmsg:) + (prefix sqlite3 sqlite3:) + pkts) (declare (unit common)) (include "common_records.scm") @@ -962,11 +963,11 @@ (or (args:get-arg "-status")(args:get-arg ":status"))) (define (common:args-get-testpatt rconf) (let* (;; (tagexpr (args:get-arg "-tagexpr")) ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) - (testpatt-key (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT")) + (testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) (cond ((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig (if rconf @@ -2314,11 +2315,51 @@ ;; no match, try again (if (null? tal) fallback-launcher (loop (car tal)(cdr tal)))))))) fallback-launcher))) + +;;====================================================================== +;; NMSG AND NEW API +;;====================================================================== + +;; nm based server experiment, keep around for now. +;; +(define (nm:start-server dbconn #!key (given-host-name #f)) + (let* ((srvdat (start-raw-server given-host-name: given-host-name)) + (host-name (srvdat-host srvdat)) + (soc (srvdat-soc srvdat))) + + ;; start the queue processor (save for second round of development) + ;; + (thread-start! (make-thread! (lambda ()(queue-processor dbconn) "Queue processor"))) + ;; msg is an alist + ;; 'r host:port <== where to return the data + ;; 'p params <== data to apply the command to + ;; 'e j|s|l <== encoding of the params. default is s (sexp), if not specified is assumed to be default + ;; 'c command <== look up the function to call using this key + ;; + (let loop ((msg-in (nn-recv soc))) + (if (not (equal? msg-in "quit")) + (let* ((dat (decode msg-in)) + (host-port (alist-ref 'r dat)) ;; this is for the reverse req rep where the server is a client of the original client + (params (alist-ref 'p dat)) + (command (let ((c (alist-ref 'c dat)))(if c (string->symbol c) #f))) + (all-good (and host-port params command (hash-table-exists? *commands* command)))) + (if all-good + (let ((cmddat (make-qitem + command: command + host-port: host-port + params: params))) + (queue-push cmddat) ;; put request into the queue + (nn-send soc "queued")) ;; reply with "queued" + (print "ERROR: BAD request " dat)) + (loop (nn-recv soc))))) + (nn-close soc))) + + ;;====================================================================== ;; D A S H B O A R D U S E R V I E W S ;;====================================================================== ;; first read ~/views.config if it exists, then read $MTRAH/views.config if it exists @@ -2333,10 +2374,55 @@ (if (common:file-exists? home-cfgfile) (read-config home-cfgfile view-cfgdat #t)) view-cfgdat)) ;;====================================================================== +;; H I E R A R C H I C A L H A S H T A B L E S +;;====================================================================== + +;; Every element including top element is a vector: +;; + +(define (hh:make-hh #!key (ht #f)(value #f)) + (vector (or ht (make-hash-table)) value)) + +;; used internally +(define-inline (hh:set-ht! hh ht) (vector-set! hh 0 ht)) +(define-inline (hh:get-ht hh) (vector-ref hh 0)) +(define-inline (hh:set-value! hh value) (vector-set! hh 1 value)) +(define-inline (hh:get-value hh value) (vector-ref hh 1)) + +;; given a hierarchial hash and some keys look up the value ... +;; +(define (hh:get hh . keys) + (if (null? keys) + (vector-ref hh 1) ;; we have reached the end of the line, return the value sought + (let ((sub-ht (hh:get-ht hh))) + (if sub-ht ;; yes, there is more hierarchy + (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) + (if sub-hh + (apply hh:get sub-hh (cdr keys)) + #f)) + #f)))) + +;; given a hierarchial hash, a value and some keys, add needed hierarcy and insert the value +;; +(define (hh:set! hh value . keys) + (if (null? keys) + (hh:set-value! hh value) ;; we have reached the end of the line, store the value + (let ((sub-ht (hh:get-ht hh))) + (if sub-ht ;; yes, there is more hierarchy + (let ((sub-hh (hash-table-ref/default sub-ht (car keys) #f))) + (if (not sub-hh) ;; we'll need to add the next level of hierarchy + (let ((new-sub-hh (hh:make-hh))) + (hash-table-set! sub-ht (car keys) new-sub-hh) + (apply hh:set! new-sub-hh value (cdr keys))) + (apply hh:set! sub-hh value (cdr keys)))) ;; call the sub-hierhash with remaining keys + (begin + (hh:set-ht! hh (make-hash-table)) + (apply hh:set! hh value keys)))))) + ;; Manage pkts, used in servers, tests and likely other contexts so put ;; in common ;;====================================================================== (define common:pkts-spec Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1799,59 +1799,73 @@ complex-itemmap.png

We accomplish this by configuring the testconfigs of our tests C D and E as follows:

-
Testconfig for Test C
+
Testconfig for Test E has
[requirements]
-waiton A B
-
-[itemmap]
-A (\d+)/aa aa/\1
-B (\d+)/bb
+waiton C +itemmap (\d+)/res \1/bb
-
Testconfig for Test D
+
Testconfig for Test D has
[requirements]
 waiton C
 itemmap (\d+)/res \1/aa
-
Testconfig for Test E
+
Testconfig for Test C has
[requirements]
-waiton C
-itemmap (\d+)/res \1/bb
+waiton A B + +[itemmap] +A (\d+)/aa aa/\1 +B (\d+)/bb bb/\1 +
+
+
Testconfigs for Test B and Test A have no waiton or itemmap configured
+
+

 

-
Example from image just above, we want the following to occur:

-
    
+
    Walk through one item — we want the following to happen for testpatt D/1/res (see blue boxes in complex itemmaping figure above):
      
+
    1. 
+
      
+eg from command line megatest -run -testpatt D/1/res -target mytarget -runname myrunname
+
      
+
      2. 
+
    2. 
+
      
+Full list to be run is now: D/1/res
+
      
+
      3. 
+
    3. 
+
      
+Test D has a waiton - test C.  Test D’s itemmap rule itemmap (\d+)/res \1/aa →  causes C/1/aa to run before D/1/res
+
      
+
      4. 
 
    4. 
 
      
-We want the above to execute when we request pattern D/1/res, eg from command line megatest -run -testpatt D/1/res -target … -runname …
+Full list to be run is now: D/1/res, C/1/aa
 
      
 
      5. 
 
    5. 
 
      
-"(\d+)/res" → "\1/aa" to require C/1/aa be executed before D/1/res
-
      
-
      6. 
-
    6. 
-
      
-Full list to be run is now: D/1/res, C/1/aa
-
      
-
      7. 
-
    7. 
-
      
-"(\d+)/aa" → "aa/\1" to create item A/aa/1
+Test C was a waiton - test A. Test C’s rule A (\d+)/aa aa/\1 → causes A/aa/1 to run before C/1/aa
 
      
 
      8. 
 
    8. 
 
      
 Full list to be run is now: D/1/res, C/1/aa, A/aa/1
 
      
+
      9. 
+
    9. 
+
      
+Test A has no waitons.  All waitons of all tests in full list have been processed.  Full list is finalized.
+
      
 
      10. 
 
    
 

 

 
Dynamic Flow Dependency Tree


Index: docs/manual/reference.txt
==================================================================
--- docs/manual/reference.txt
+++ docs/manual/reference.txt
@@ -385,41 +385,47 @@
 image::complex-itemmap.png[]
 
 
 We accomplish this by configuring the testconfigs of our tests C D and E as follows:
 
-.Testconfig for Test C
+.Testconfig for Test E has
 ----------------------
 [requirements]
-waiton A B
-
-[itemmap]
-A (\d+)/aa aa/\1
-B (\d+)/bb 
+waiton C
+itemmap (\d+)/res \1/bb
 ----------------------
 
-.Testconfig for Test D
+.Testconfig for Test D has
 ----------------------
 [requirements]
 waiton C
 itemmap (\d+)/res \1/aa
 ----------------------
 
-.Testconfig for Test E
+.Testconfig for Test C has
 ----------------------
 [requirements]
-waiton C
-itemmap (\d+)/res \1/bb
+waiton A B
+
+[itemmap]
+A (\d+)/aa aa/\1
+B (\d+)/bb bb/\1
 ----------------------
 
-Example from image just above, we want the following to occur:
+.Testconfigs for Test B and Test A have no waiton or itemmap configured
+-------------------
+-------------------
 
-. We want the above to execute when we request pattern +D/1/res+, eg from command line +megatest -run -testpatt D/1/res -target ... -runname ...+
-. "(\d+)/res" -> "\1/aa" to require +C/1/aa+ be executed before +D/1/res+
-. Full list to be run is now: D/1/res, C/1/aa
-. "(\d+)/aa" -> "aa/\1" to create item +A/aa/1+
+.Walk through one item -- we want the following to happen for testpatt +D/1/res+ (see blue boxes in complex itemmaping figure above):
+
+. eg from command line +megatest -run -testpatt D/1/res -target mytarget -runname myrunname+
+. Full list to be run is now: +D/1/res+
+. Test D has a waiton - test C.  Test D's itemmap rule +itemmap (\d+)/res \1/aa+ ->  causes +C/1/aa+ to run before +D/1/res+
+. Full list to be run is now: +D/1/res+, +C/1/aa+
+. Test C was a waiton - test A. Test C's rule +A (\d+)/aa aa/\1+ -> causes +A/aa/1+ to run before +C/1/aa+
 . Full list to be run is now: +D/1/res+, +C/1/aa+, +A/aa/1+
+. Test A has no waitons.  All waitons of all tests in full list have been processed.  Full list is finalized.
 
 
 Dynamic Flow Dependency Tree
 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 

Index: megatest-version.scm
==================================================================
--- megatest-version.scm
+++ megatest-version.scm
@@ -1,7 +1,7 @@
 ;; Always use two or four digit decimal
 ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00..
 
 (declare (unit megatest-version))
 
-(define megatest-version 1.6504)
+(define megatest-version 1.6505)
 

Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -118,21 +118,21 @@
   -no-cache               : do not use the cached config files. 
   -one-pass               : launch as many tests as you can but do not wait for more to be ready
   -remove-keep N action   : remove all but N most recent runs per target
                             * Use -actions print,remove-runs,archive to specify action to take
                             * Add param -age 120d,3h,20m to apply only to runs older than the 
-                                 specified age
+                                 specified age. NB// M=month, m=minute
                             * Add -precmd to insert a wrapper command in front of the commands run
 
 Selectors (e.g. use for -runtests, -remove-runs, -set-state-status, -list-runs etc.)
   -target key1/key2/...   : run for key1, key2, etc.
   -reqtarg key1/key2/...  : run for key1, key2, etc. but key1/key2 must be in runconfigs
   -testpatt patt1/patt2,patt3/...  : % is wildcard
   -runname                : required, name for this particular test run
   -state                  : Applies to runs, tests or steps depending on context
   -status                 : Applies to runs, tests or steps depending on context
-  --modepatt key          : load testpatt from  in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
+  -modepatt key           : load testpatt from  in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
   -tagexpr tag1,tag2%,..  : select tests with tags matching expression
   
 
 Test helpers (for use inside tests)
   -step stepname
@@ -272,10 +272,11 @@
 			"-status"
 			"-list-runs"
                         "-testdata-csv"
 			"-testpatt"
                         "--modepatt"
+                        "-modepatt"
                         "-tagexpr"
 			"-itempatt"
 			"-setlog"
 			"-set-toplog"
 			"-runstep"

Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -256,11 +256,11 @@
 ;; given a mtutil param, return the old megatest equivalent
 ;;
 (define (param-translate param)
   (or (alist-ref (string->symbol param)
 		 '((-tag-expr  . "-tagexpr")
-		   (-mode-patt . "--modepatt")
+		   (-mode-patt . "-modepatt")
 		   (-run-name  . "-runname")
 		   (-test-patt . "-testpatt")
 		   (-msg       . "-m")
 		   (-new       . "-set-state-status")))
       param))