Megatest

Diff
Login

Differences From Artifact [f71da7508c]:

To Artifact [e2f38ea970]:


122
123
124
125
126
127
128

129
130
131
132
133
134
135
    ("-contour"    . c)
    ("-test-patt"  . p)  ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
    ("-mode-patt"  . o)
    ("-tag-expr"   . x)
    ("-item-patt"  . i)
    ;; misc
    ("-start-dir"  . S)

    ("-set-vars"   . v)
    ("-debug"      . #f)  ;; for *verbosity* > 2
    ("-load"       . #f)  ;; load and exectute a scheme file
    ("-log"        . #f)
    ))
(define *switch-keys*
  '(("-h"          . #f)







>







122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
    ("-contour"    . c)
    ("-test-patt"  . p)  ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt"
    ("-mode-patt"  . o)
    ("-tag-expr"   . x)
    ("-item-patt"  . i)
    ;; misc
    ("-start-dir"  . S)
    ("-msg"        . M)
    ("-set-vars"   . v)
    ("-debug"      . #f)  ;; for *verbosity* > 2
    ("-load"       . #f)  ;; load and exectute a scheme file
    ("-log"        . #f)
    ))
(define *switch-keys*
  '(("-h"          . #f)
153
154
155
156
157
158
159
160

161
162
163
164
165
166
167
;; 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")
		   (-run-name  . "-runname")
		   (-test-patt . "-testpatt")))

      param))

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







|
>







154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
;; 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")
		   (-run-name  . "-runname")
		   (-test-patt . "-testpatt")
		   (-msg       . "-m")))
      param))

;; Card types:
;;
;; a action
;; u username (Unix)
;; D timestamp
290
291
292
293
294
295
296


























297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331



332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348


349
350
351

352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367


368
369
370
371
372
373
374
375
376
377
378





















379
380
381
382
383
384
385
	 (mtconf    (if mtconfdat (car mtconfdat) #f)))
    ;; 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     (map car (configf:get-section mtconf "areas")))
	    (contours  (configf:get-section mtconf "contours"))
	    (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)))
		      (runstarts (find-pkts pdb '(runstart) `((o . ,contour)
							      (t . ,runkey))))
		      (rspkts    (map (lambda (x)
					(alist-ref 'pkta x))
				      runstarts))



		      (starttimes (map string->number (map (lambda (x)
							     (alist-ref 'D x))
							   rspkts)))
		      )

		 ;; (print "rspkts: " rspkts " starttimes: " starttimes)
		 
		 ;; look in runstarts for matching runs by target and contour
		 ;; get the timestamp for when that run started and pass it
		 ;; to the rule logic here where "ruletype" will be applied
		 ;; if it comes back "changed" then proceed to register the runs
		 
		 ;; 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
		 (if (null? starttimes) ;; primitive, have a previous run? skip for now!

		     (for-each
		      (lambda (area)
			(let ((area-path (configf:lookup mtconf "areas" area)))
			  (print "area: " area " path: " area-path)
			  (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






















(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)







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
















|


|
|
|
|
|
|
|
|
<
<
<
|
|
|
|
|
>
>
>
|
|
|
|
|
<
|




|
|
|
<
<
|
>
>
|
<
|
>
|
|
<
<
<
<
<
<
<
<
<
|
<
|
<
<
>
>
|
<
<
|
<
<
<
<
<

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351



352
353
354
355
356
357
358
359
360
361
362
363
364

365
366
367
368
369
370
371
372


373
374
375
376

377
378
379
380









381

382


383
384
385


386





387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
	 (mtconf    (if mtconfdat (car mtconfdat) #f)))
    ;; 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))

;; make a run request pkt from basic data
;;
(define (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason)
  (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)
		      ("-msg"        . ,reason))
		    (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))))))

;; 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     (map car (configf:get-section mtconf "areas")))
	    (contours  (configf:get-section mtconf "contours"))
	    (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))



		      (runstarts  (find-pkts pdb '(runstart) `((o . ,contour)
							       (t . ,runkey))))
		      (rspkts     (map (lambda (x)
					 (alist-ref 'pkta x))
				       runstarts))
		      (starttimes ;; sort by age (youngest first) and delete duplicates by target
		       (delete-duplicates
			(sort 
			 (map (lambda (x)
				`(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
			      rspkts)
			 (lambda (a b)(> (cdr a)(cdr b))))      ;; sort descending
			(lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target

		      )
		 ;; look in runstarts for matching runs by target and contour
		 ;; get the timestamp for when that run started and pass it
		 ;; to the rule logic here where "ruletype" will be applied
		 ;; if it comes back "changed" then proceed to register the runs

		 (case (string->symbol ruletype)
		   ((file)


		    (let* ((file-globs  (cdr valparts))
			   (youngestdat (common:get-youngest file-globs))
			   (youngestmod (car youngestdat)))
		      ;; (print "youngestmod: " youngestmod " starttimes: " starttimes)

		      (if (null? starttimes) ;; this target has never been run
			  (configf:section-var-set! torun contour runkey `("file:neverrun" ,runname))
			  (for-each
			   (lambda (starttime) ;; look at the time the last run was kicked off for this contour









			     (if (> youngestmod (cdr starttime))

				 (begin


				   (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
				   (configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (cadr youngestdat)) ,runname)))))
			   starttimes))


		      )))))





	     keydats)))
	(hash-table-keys rgconf))
       
       ;; now have torun populated
       (for-each
	(lambda (contour)
	  (let* ((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))))
	    (for-each
	     (lambda (runkeydat)
	       (let* ((runkey (car runkeydat))
		      (info   (cadr runkeydat)))
		 (for-each
		  (lambda (area)
		    (let ((runname (cadr info))
			  (reason  (car  info)))
		      (print "runkey: " runkey " contour: " contour " info: " info " area: " area  " tag-expr: " tag-expr " mode-patt: " mode-patt)
		      (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason)))
		  areas)))
	     (configf:get-section torun contour))))
	(hash-table-keys torun))))))


(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)