Index: .mtutil.scm
==================================================================
--- .mtutil.scm
+++ .mtutil.scm
@@ -1,11 +1,39 @@
+(use json)
+(use ducttape-lib)
+
+(define (get-last-runname area-path target)
+ (let* ((run-data (with-input-from-pipe (conc "megatest -list-runs % -target " target " -fields runs:runname,event_time -dumpmode sexpr -start-dir " area-path)
+ read)))
+ (if (or (not run-data)
+ (null? run-data))
+ #f
+ (let* ((name-time (let ((dat (map cdadr (alist-ref target run-data equal?)))) ;; (("runname" . "2017w07.0-0047") ("event_time" . "1487490424"))
+ ;; (print "dat=" dat)
+ (map (lambda (item)
+ (cons (alist-ref "runname" item equal?)
+ (string->number (alist-ref "event_time" item equal?))))
+ dat)))
+ (sorted (sort name-time (lambda (a b)(> (cdr a)(cdr b)))))
+ (last-name (if (null? sorted)
+ #f
+ (caar sorted))))
+ last-name))))
+
;; example of how to set up and write target mappers
;;
(define *target-mappers*
`((prefix-contour . ,(lambda (target run-name area area-path reason contour mode-patt)
(conc contour "/" target)))
(prefix-area-contour . ,(lambda (target run-name area area-path reason contour mode-patt)
(conc area "/" contour "/" target)))))
-
-;; (print "Yep, got here!")
+(define *runname-mappers*
+ `((corporate-ww . ,(lambda (target run-name area area-path reason contour mode-patt)
+ (let* ((last-name (get-last-runname area-path target))
+ (last-letter (if (string? last-name)
+ (let ((len (string-length last-name)))
+ (substring last-name (- len 1) len))
+ "a"))
+ (next-letter (list->string (list (integer->char (+ (char->integer (string-ref last-letter 0)) 1)))))) ;; surely there is an easier way?
+ (conc (seconds->wwdate (current-seconds)) next-letter))))))
Index: megatest.config
==================================================================
--- megatest.config
+++ megatest.config
@@ -7,9 +7,9 @@
# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run
ext-tests path=ext-tests; targtrans=prefix-contour
[contours]
# mode-patt/tag-expr
-quick selector=quick/QUICKPATT
-full areas=fullrun,ext-tests; selector=all/MAXPATT
+quick selector=QUICKPATT/quick
+full areas=fullrun,ext-tests; selector=MAXPATT/all
all areas=fullrun,ext-tests
-snazy areas=%; selector=/QUICKPATT
+snazy areas=%; selector=QUICKPATT/
Index: megatest.scm
==================================================================
--- megatest.scm
+++ megatest.scm
@@ -1090,11 +1090,11 @@
;; (reverse new-res)
;; (loop (car tal)(cdr tal) new-res)))))
;; runstmp))
(db-targets (args:get-arg "-list-db-targets"))
(seen (make-hash-table))
- (dmode (let ((d (args:get-arg "-dumpmode")))
+ (dmode (let ((d (args:get-arg "-dumpmode"))) ;; json, sexpr
(if d (string->symbol d) #f)))
(data (make-hash-table))
(fields-spec (if (args:get-arg "-fields")
(extract-fields-constraints (args:get-arg "-fields"))
(list (cons "runs" (append keys (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")))
@@ -1149,11 +1149,11 @@
#f)
#f
'normal)
'())))
(case dmode
- ((json ods)
+ ((json ods sexpr)
(if runs-spec
(for-each
(lambda (field-name)
(mutils:hierhash-set! data (conc (db:get-value-by-header run header field-name)) targetstr runname "meta" field-name))
runs-spec)))
@@ -1204,11 +1204,11 @@
(fullname (conc testname
(if (equal? itempath "")
""
(conc "(" itempath ")")))))
(case dmode
- ((json ods)
+ ((json ods sexpr)
(if tests-spec
(for-each
(lambda (field-name)
(mutils:hierhash-set! data (get-value-by-fieldname test test-field-index field-name) targetstr runname "data" (conc test-id) field-name))
tests-spec)))
@@ -1287,11 +1287,13 @@
((and (string? first)(string? second)) string<=?)
(else equal?))
first second))))
tests))))))
runs)
- (if (eq? dmode 'json)(json-write data))
+ (case dmode
+ ((json) (json-write data))
+ ((sexpr) (pp (common:to-alist data))))
(let* ((metadat-fields (delete-duplicates
(append keys '( "runname" "time" "owner" "pass_count" "fail_count" "state" "status" "comment" "id"))))
(run-fields '(
"testname"
"item_path"
@@ -1360,11 +1362,11 @@
(cons (conc target "/" runname)
(cons (list (conc target "/" runname))
(cons '()
(cons run-fields tests)))))
(begin
- (debug:print 0 *default-log-port* "WARNING: run " target "/" runname " appears to have no data")
+ (debug:print 4 *default-log-port* "WARNING: run " target "/" runname " appears to have no data")
;; (pp rundat)
'()))))
runsdat)
'())))
newdat)) ;; we use newdat to get target
Index: mtut.scm
==================================================================
--- mtut.scm
+++ mtut.scm
@@ -25,11 +25,12 @@
(include "megatest-fossil-hash.scm")
(require-library stml)
-(define *target-mappers* '())
+(define *target-mappers* '())
+(define *runname-mappers* '())
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
@@ -256,10 +257,11 @@
(print "ERROR: fossil timeline returned unrecognisable junk \"" inl "\"")
(loop (get-line) date node time))))
(else ;; no more datat and last node on branch not found
(close-input-port timeline-port)
(values (common:date-time->seconds (conc date " " time)) node))))))
+
;;======================================================================
;; GLOBALS
;;======================================================================
Index: runconfigs.config
==================================================================
--- runconfigs.config
+++ runconfigs.config
@@ -17,10 +17,11 @@
# file: files changes since last run trigger new run
# script: script is called with unix seconds as last parameter (other parameters are preserved)
#
# contour:sensetype:action params data
quick:file:run run-name=auto;glob=/home/matt/data/megatest/*.scm
+snazy:file:run run-name=auto;glob=/home/matt/data/megatest/*.scm
# script returns change-time (unix epoch), new-target-name, run-name
#
# quick:script:run checkfossil = http://www.kiatoa.com/fossils/megatest v1.63;\
# checkfossil = http://www.kiatoa.com/fossils/megatest_qa trunk