Megatest

(set-signal-handler! signal/term std-signal-handler)
;; (set-signal-handler! signal/stop std-signal-handler)  ;; ^Z NO, do NOT handle ^Z!

;;======================================================================
;; M I S C   U T I L S
;;======================================================================










;; convert stuff to a number if possible
(define (any->number val)
  (cond 
   ((number? val) val)
   ((string? val) (string->number val))
   ((symbol? val) (any->number (symbol->string val)))
   (else #f)))

(define (args:usage . args)
  (if (> (length args) 0)
      (apply print "ERROR: " args))
  (if (string? help)
      (print help)
      (print "Usage: " (car (argv)) " ... "))
  (exit 0))

 ;; one-of args defined
(define (args:any-defined? . param)
  (let ((res #f))
    (for-each 
     (lambda (arg)
       (if (args:get-arg arg)(set! res #t)))
     param)
    res))

;; args: 
(define (args:get-args args params switches arg-hash num-needed)
  (let* ((numargs (length args))
	 (adj-num-needed (if num-needed (+ num-needed 2) #f)))
    (if (< numargs (if adj-num-needed adj-num-needed 2))
	(if (>= num-needed 1)

[setup]
pktsdirs /tmp/pkts /some/other/source

[areas]
#         path-to-area   map-target-script(optional)
fullrun   tests/fullrun  cat
ext-tests ext-tests

[contours]
#     mode-patt/tag-expr
quick QUICKPATT/quick
# full  MAXPATT/long QUICKPATT/quick

  license GPL, Copyright Matt Welland 2006-2017

Usage: mtutil action [options]
  -h                       : this help
  -manual                  : show the Megatest user manual
  -version                 : print megatest version (currently " megatest-version ")

Actions:
   run                     : initiate runs
   remove                  : remove runs
   rerun                   : register action for processing
   set-ss                  : set state/status
   archive                 : compress and move test data to archive disk
   kill                    : stop tests or entire runs

Contour actions:
   import                  : import pkts
   dispatch                : dispatch queued run jobs from imported pkts
   rungen                  : look at input sense list in [rungen] and generate run pkts

Selectors 
  -immediate               : apply this action immediately, default is to queue up actions
  -area areapatt1,area2... : apply this action only to the specified areas
  -target key1/key2/...    : run for key1, key2, etc.
  -test-patt p1/p2,p3/...  : % is wildcard

  -repl                    : start a repl (useful for extending megatest)
  -load file.scm           : load and run file.scm
  -debug N|N,M,O...        : enable debug messages 0-N or N and M and O ...

Examples:

# Start a megatest run in the area \"mytests\"
mtutil -area mytests -action run -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick

# Start a contour
mtutil run -contour quick -target v1.63/aa3e 

Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))

;; args and pkt key specs
;;
(define *arg-keys*

    ("-manual"     . #f)
    ("-version"    . #f)
    ;; misc
    ("-repl"       . #f)
    ("-immediate"  . I)
    ))

(define (lookup-param-by-key key #!key (inlst #f))
  (fold (lambda (a res)
	  (if (eq? (cdr a) key)
	      (car a)
	      res))
	#f
	(or inlst *arg-keys*)))

;; Card types:
;;
;; a action
;; u username (Unix)
;; D timestamp
;; T card type

;; process args
(define *action* (if (> (length (argv)) 1)
		     (cadr (argv))
		     #f))
(define remargs (args:get-args 
		 (if *action* (cdr (argv)) (argv)) ;; args:get-args dumps first in argv list (the program name)
		 (map car *arg-keys*)
		 (map car *switch-keys*)
		 args:arg-hash
		 0))

(if (or (member *action* '("-h" "-help" "help" "--help"))
	(args:any-defined? "-h" "-help" "--help"))
    (begin
      (print help)
      (exit 1)))

;; (print "*action*: " *action*)
;; (let-values (((uuid pkt)
;; 	      (command-line->pkt #f args:arg-hash)))
;;   (print pkt))

;; Add args that use remargs here
;;
(if (and (not (null? remargs))
	 (not (or
	       (args:get-arg "-runstep")
	       (args:get-arg "-envcap")
	       (args:get-arg "-envdelta")

	       )))
    (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv))  " ")))

;;======================================================================
;; pkts
;;======================================================================

(define (with-queue-db mtconf proc)

		       )))
	       pkts))))
      (string-split pktsdirs)))))

;;======================================================================
;; Runs
;;======================================================================

;; make a runname
;;
(define (make-runname valparts)
  "ww07.1a")

;; collect, translate, collate and assemble a pkt from the command-line
;;
(define (command-line->pkt action args-alist)
  (let* ((args-data (if args-alist
			args-alist
			(hash-table->alist args:arg-hash)))
	 (alldat    (apply append (list 'a action
					'U (current-user-name))
			   (map (lambda (x)
				  (let* ((param (car x))
					 (value (cdr x))
					 (pmeta (assoc param *arg-keys*))
					 (smeta (assoc param *switch-keys*))
					 (meta  (if (or pmeta smeta)

    ;; we set some dynamic data in a section called "dyndata"
    (if mtconf
	(begin
	  (configf:section-var-set! mtconf "dyndat" "toppath" start-dir)))
    (print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath"))
    mtconfdat))

;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
  (with-queue-db
   mtconf
   (lambda (pktsdirs pktsdir pdb)
     (let* ((rgconfdat (find-and-read-config (conc toppath "/rungen.config")))
	    (rgconf    (car rgconfdat))
	    (areas     (configf:get-section mtconf "areas"))
	    (contours  (configf:get-section mtconf "contours"))
	    (runstats  (find-pkts pdb '(runstart) '()))
	    (torun     (make-hash-table)) ;; target => ( ... info ... )
	    (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
       (for-each
	(lambda (runkey)
	  (let* ((keydats (configf:get-section rgconf runkey)))
	    (for-each
	     (lambda (sense) ;; these are the sense rules
	       (let* ((key       (car sense))
		      (val       (cadr sense))
		      (keyparts  (string-split key ":"))
		      (contour   (car keyparts))
		      (ruletype  (let ((res (cdr keyparts)))
				   (if (null? res) #f (cadr keyparts))))
		      (valparts  (string-split val)) ;; runname-rule params
		      (runname   (make-runname #f))
		      (mode-tag  (string-split (or (configf:lookup mtconf "contours" contour) "") "/"))
		      (mode-patt (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))
		      (tag-expr  (if (null? mode-tag) #f (car mode-tag)))
		      )
		 ;; run the ruletype here
		 ;; if already marked to run (#t) don't unmark it.
		 (if (not (configf:lookup torun runkey contour))
		     (configf:section-var-set! torun runkey contour
					       (list valparts)))
		 (print "key: " key " val: " val)
		 ;; now create a run request packet
		 (for-each
		  (lambda (area)
		    (let ((area-path (configf:lookup mtconf "areas" area)))
		      (let-values (((uuid pkt)
				    (command-line->pkt
				     "run"
				     (append 
				      `(("-target"     . ,runkey)
					("-run-name"   . ,runname)
					("-start-dir"  . ,area-path))
				      (if mode-patt
					  `(("-mode-patt"  . ,mode-patt))
					  '())
				      (if tag-expr
					  `(("-tag-expr"   . ,tag-expr))
					  '())
				      (if (not (or mode-patt tag-expr))
					  `(("-item-patt"  . "%"))
					  '())))))
			(with-output-to-file
			    (conc pktsdir "/" uuid ".pkt")
			  (lambda ()
			    (print pkt))))))
		  areas))) ;; for each area
	     keydats)))
	(hash-table-keys rgconf)) ;; for each runkey
       ;; now we have a hash of alists with targets (runkeys), how to calc runname etc.
       (print "runstats: " runstats " rgentargs: " rgentargs)))))

(define (pkt->cmdline pkta)
  (fold (lambda (a res)
	  (let* ((key (car a)) ;; get the key name
		 (val (cdr a))
		 (par (lookup-param-by-key key)))
	    ;; (print "key: " key " val: " val " par: " par)
	    (if par
		(conc res " " par " " val)
		res)))
	""
	pkta))
	    
;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (dispatch-commands mtconf toppath)
  (with-queue-db
   mtconf
   (lambda (pktsdirs pktsdir pdb)
     (let* ((rgconfdat (find-and-read-config (conc toppath "/rungen.config")))
	    (rgconf    (car rgconfdat))
	    (areas     (configf:get-section mtconf "areas"))
	    (contours  (configf:get-section mtconf "contours"))
	    (pkts      (find-pkts pdb '(cmd) '()))
	    (torun     (make-hash-table)) ;; target => ( ... info ... )
	    (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
       (for-each
	(lambda (pktdat)
	  (let* ((pkta    (alist-ref 'pkta pktdat))
		 (cmdline (pkt->cmdline pkta)))
	    (print cmdline)))
	pkts)))))

(define (get-pkts-dir mtconf)
  (let ((pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
	(pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f)))
    pktsdir))

(if *action*
    (case (string->symbol *action*)
      ((run remove rerun set-ss archive kill)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
	      (pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f))
	      (adjargs   (hash-table-copy args:arg-hash)))
	 ;; (for-each
	 ;;  (lambda (key)
	 ;;    (if (not (member key *legal-params*))
	 ;; 	(hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
	 ;;  (hash-table-keys adjargs))
	 (let-values (((uuid pkt)
		       (command-line->pkt *action* adjargs)))
	   (if pktsdir
	       (with-output-to-file
		   (conc pktsdir "/" uuid ".pkt")
		 (lambda ()
		   (print pkt)))
	       (print "ERROR: cannot process commands without a pkts directory")))))
      ((dispatch import rungen)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (toppath   (configf:lookup mtconf "dyndat" "toppath")))
	 (case (string->symbol *action*)
	   ((import)   (load-pkts-to-db mtconf)) ;; import pkts
	   ((rungen)   (generate-run-pkts mtconf toppath))

	   ((dispatch) (dispatch-commands mtconf toppath)))))))








(if (or (args:get-arg "-repl")
	(args:get-arg "-load"))
    (begin
      (import extras) ;; might not be needed
      ;; (import csi)
      (import readline)