@@ -27,11 +27,11 @@
 (declare (unit mtmod))
 (declare (uses debugprint))
 (declare (uses mtargs))
 (declare (uses commonmod))
 (declare (uses configfmod))
-(declare (uses tcp-transportmod))
+;; (declare (uses tcp-transportmod)) ;; we don't want mtmod depending on tcp
 
 (use srfi-69)
 
 (module mtmod
 	*
@@ -44,10 +44,11 @@
 	  ports
 	  (prefix base64 base64:)
 
 	  (prefix sqlite3 sqlite3:)
 	  data-structures 
+	  directory-utils
 	  extras
 	  files
 	  matchable
 	  md5
 	  message-digest
@@ -64,11 +65,11 @@
 	  z3
 	  
 	  debugprint
 	  commonmod
 	  configfmod
-	  tcp-transportmod
+	  ;; tcp-transportmod
 	  (prefix mtargs args:)
 	  )
   (use srfi-69))
  (chicken-5
   (import (prefix sqlite3 sqlite3:)
@@ -104,10 +105,15 @@
 	  typed-records
 	  system-information
 
 	  debugprint
   )))
+
+;; imports common to chk5 and ck4
+(import srfi-13)
+
+(include "db_records.scm")
 
 (define (common:get-fields cfgdat)
   (let ((fields (hash-table-ref/default cfgdat "fields" '())))
     (map car fields)))
 
@@ -211,7 +217,270 @@
 		(let ((dbarea (conc dbpath "/.mtdb")))
 		  (if (not (file-exists? dbarea))
 		      (create-directory dbarea)))
 		dbpath))
 	  #f)))
+
+;======================================================================
+;;  T R I G G E R S
+;;======================================================================
+
+(define (mt:run-trigger cmd test-id test-rundir trigger logname test-name item-path event-time actual-state actual-status target runname)
+  ;; Putting the commandline into ( )'s means no control over the shell. 
+  ;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
+  ;; or equivalent. No need to do this. Just run it?
+  (let* ((new-trigger-format (configf:lookup *configdat* "setup" "new-trigger-format"))
+         (fullcmd 
+          (if (and new-trigger-format (string=? new-trigger-format "yes"))
+            (conc "nbfake "
+			cmd           " "
+			test-id       " "
+			test-rundir   " "
+			trigger       " "
+			actual-state  " "
+			actual-status " "
+			event-time    " "
+                        target        " "
+                        runname       " "
+			test-name     " "
+			item-path
+			)
+            (conc "nbfake "
+			cmd           " "
+			test-id       " "
+			test-rundir   " "
+			trigger       " "
+			test-name     " "
+			item-path     " " 
+			actual-state  " "
+			actual-status " "
+			event-time
+			)
+          ))
+	 (prev-nbfake-log (get-environment-variable "NBFAKE_LOG")))
+    (setenv "NBFAKE_LOG" (conc (cond
+				((and (directory-exists? test-rundir)
+				      (file-write-access? test-rundir))
+				 test-rundir)
+				((and (directory-exists? *toppath*)
+				      (file-write-access? *toppath*))
+				 *toppath*)
+				(else (conc "/tmp/" (current-user-name))))
+			       "/" logname))
+    (debug:print-info 0 *default-log-port* "TRIGGERED on " trigger ", running command " fullcmd " output at " (get-environment-variable "NBFAKE_LOG"))
+    (process-run fullcmd)
+    (if prev-nbfake-log
+	(setenv "NBFAKE_LOG" prev-nbfake-log)
+	(unsetenv "NBFAKE_LOG"))
+    ))
+
+
+(define (mt:discard-blocked-tests run-id failed-test tests test-records)
+  (if (null? tests)
+      tests
+      (begin
+	(debug:print-info 1 *default-log-port* "Discarding tests from " tests " that are waiting on " failed-test)
+	(let loop ((testn (car tests))
+		   (remt  (cdr tests))
+		   (res   '()))
+	  (let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '())))
+		 (waitons  (vector-ref test-dat 2)))
+	    ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons)
+	    (if (null? remt)
+		(let ((new-res (reverse res)))
+		  ;; (print "       new-res: " new-res)
+		  new-res)
+		(loop (car remt)
+		      (cdr remt)
+		      (if (member failed-test waitons)
+			  (begin
+			    (debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
+			    res)
+			  (cons testn res)))))))))
+
+
+;; Puts out all combinations
+(define (process-itemlist hierdepth curritemkey itemlist)
+  (let ((res '()))
+    (if (not hierdepth)
+	(set! hierdepth (length itemlist)))
+    (let loop ((hed (car itemlist))
+	       (tal (cdr itemlist)))
+      (if (null? tal)
+	  (for-each (lambda (item)
+		      (if (> (length curritemkey) (- hierdepth 2))
+			  (set! res (append res (list (append curritemkey (list (list (car hed) item))))))))
+		    (cadr hed))
+	  (begin
+	    (for-each (lambda (item)
+			(set! res (append res (process-itemlist hierdepth (append curritemkey (list (list (car hed) item))) tal))))
+		      (cadr hed))
+	    (loop (car tal)(cdr tal)))))
+    res))
+
+;; (item-assoc->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Fall")))
+;;   => ((("ANIMAL" "Elephant") ("SEASON" "Spring")) 
+;;       (("ANIMAL" "Elephant") ("SEASON" "Fall")) 
+;;       (("ANIMAL" "Lion")     ("SEASON" "Spring"))
+;;       (("ANIMAL" "Lion")     ("SEASON" "Fall")))
+(define (item-assoc->item-list itemsdat)
+  (if (and itemsdat (not (null? itemsdat)))
+      (let ((itemlst (filter (lambda (x)
+			       (list? x))
+			     (map (lambda (x)
+				    (debug:print 6 *default-log-port* "item-assoc->item-list x: " x)
+				    (if (< (length x) 2)
+					(begin
+					  (debug:print-error 0 *default-log-port* "malformed items spec " (string-intersperse x " "))
+					  (list (car x)'()))
+					(let* ((name (car x))
+					       (items (cadr x))
+					       (ilist (list name (if (string? items)
+								     (string-split items)
+								     '()))))
+					  (if (null? ilist)
+					      (debug:print-error 0 *default-log-port* "No items specified for " name))
+					  ilist)))
+				  itemsdat))))
+	(let ((debuglevel 5))
+	  (debug:print 5 *default-log-port* "item-assoc->item-list: itemsdat => itemlst ")
+	  (if (debug:debug-mode 5)
+	      (begin
+		(pp itemsdat)
+		(print " => ")
+		(pp itemlst))))
+	(if (> (length itemlst) 0)
+	    (process-itemlist #f '() itemlst)
+	    '()))
+      '())) ;; return a list consisting on a single null list for non-item runs
+            ;; Nope, not now, return null as of 6/6/2011
+
+;; (item-table->item-list '(("ANIMAL" "Elephant Lion")("SEASON" "Spring Winter")))
+;;   => ((("ANIMAL" "Elephant")("SEASON" "Spring"))
+;;       (("ANIMAL" "Lion")    ("SEASON" "Winter")))
+(define (item-table->item-list itemtable)
+  (let ((newlst (map (lambda (x)
+		       (if (> (length x) 1)
+			   (list (car x)
+				 (string-split (cadr x)))
+			   (list x '())))
+		     itemtable))
+	(res     '())) ;; a list of items
+    (let loop ((indx    0)
+	       (item   '()) ;; an item will be ((KEYNAME1 VAL1)(KEYNAME2 VAL2) ...)
+	       (elflag  #f))
+      (for-each (lambda (row)
+		  (let ((rowname (car row))
+			(rowdat  (cadr row)))
+		    (set! item (append item 
+				       (list 
+					(if (< indx (length rowdat))
+					    (let ((new (list rowname (list-ref rowdat indx))))
+					      ;; (debug:print 0 *default-log-port* "New: " new)
+					      (set! elflag #t)
+					      new
+					      ) ;; i.e. had at least on legit value to use
+					    (list rowname "-")))))))
+		newlst)
+      (if elflag
+	  (begin
+	    (set! res (append res (list item)))
+	    (loop (+ indx 1)
+		  '()
+		  #f)))
+      res)))
+            ;; Nope, not now, return null as of 6/6/2011
+		
+(define (items:check-valid-items class item)
+  (let ((valid-values (let ((s (configf:lookup *configdat* "validvalues" class)))
+			(if s (string-split s) #f))))
+    (if valid-values
+	(if (member item valid-values)
+	    item #f)
+	item)))
+
+;;  '(("k1" "k2" "k3")
+;;    ("a" "b" "c")
+;;    ("d" "e" "f"))
+;;
+;;    => '((("k1" "a")("k2" "b")("k3" "c"))
+;;         (("k1" "d")("k2" "e")("k3" "f")))
+;;
+(define (items:first-row-intersperse data)
+  (if (< (length data) 2)
+      '()
+      (let ((header (car data))
+	    (rows   (cdr data)))
+	(map (lambda (row)
+	       (map list header row))
+	     rows))))
+
+;; k1/k2/k3
+;; a/b/c
+;; d/e/f
+;;    => '(("k1" "k2" "k3")
+;;         ("a" "b" "c")
+;;         ("d" "e" "f"))
+;;
+;;    => '((("k1" "a")("k2" "b")("k3" "c"))
+;;         (("k1" "d")("k2" "e")("k3" "f")))
+;;
+(define (items:read-items-file fname ftype) ;; 'sxml 'slash 'space 
+  (if (and fname (file-exists? fname))
+      (items:first-row-intersperse (case ftype
+				     ((slash space)
+				      (let ((splitter (case ftype
+							((slash) (lambda (x)(string-split x "/")))
+							(else    string-split))))
+					(debug:print 0 *default-log-port* "Reading " fname " of type " ftype)
+					(with-input-from-file fname
+					  (lambda ()
+					    (let loop ((inl (read-line))
+						       (res '()))
+					      (if (eof-object? inl)
+						  res
+						  (loop (read-line)(cons (splitter inl) res))))))))
+				     ((sxml)(with-input-from-file fname read))
+				     (else (debug:print 0 *default-log-port* "items file type " ftype " not recognised"))))
+      (begin
+	(if fname (debug:print 0 *default-log-port* "no items file " fname " found"))
+	'())))
+
+(define (items:get-items-from-config tconfig)
+  (let* ((slashf      (configf:lookup tconfig "itemopts" "slash")) ;; a/b/c\nd/e/f\n ...
+	 (sxmlf       (configf:lookup tconfig "itemopts" "sxml"))  ;; '(("a" "b" "c")("d" "e" "f") ...)
+	 (spacef      (configf:lookup tconfig "itemopts" "space")) ;; a b c\nd e f\n ...
+	 (have-items  (hash-table-ref/default tconfig "items"      #f))
+	 (have-itable (hash-table-ref/default tconfig "itemstable" #f))
+	 (items       (hash-table-ref/default tconfig "items"      '()))
+	 (itemstable  (hash-table-ref/default tconfig "itemstable" '())))
+    (debug:print 5 *default-log-port* "items: " items " itemstable: " itemstable)
+    (set! items (map (lambda (item)
+		       (if (procedure? (cadr item))
+			   (list (car item)((cadr item)))  ;; evaluate the proc
+			   item))
+		     items))
+    (set! itemstable (map (lambda (item)
+			    (if (procedure? (cadr item))
+				(list (car item)((cadr item)))  ;; evaluate the proc
+				item))
+			  itemstable))
+    (if (and have-items  (null? items))     (debug:print 0 *default-log-port* "WARNING:[items] section in testconfig but no entries defined"))
+    (if (and have-itable (null? itemstable))(debug:print 0 *default-log-port* "WARNNG:[itemstable] section in testconfig but no entries defined"))
+    (if (or (not (null? items))
+	    (not (null? itemstable))
+	    slashf
+	    sxmlf
+	    spacef)
+	(append (item-assoc->item-list items)
+		(item-table->item-list itemstable)
+		(items:read-items-file slashf 'slash)
+		(items:read-items-file sxmlf  'sxml)
+		(items:read-items-file spacef 'space))
+	'(()))))
+
+;; (pp (item-assoc->item-list itemdat))
+
+
+	
 
 )