Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -38,11 +38,11 @@ ARCHSTR=$(shell lsb_release -sr) # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut mtest: $(OFILES) readline-fix.scm megatest.o csc $(CSCOPTS) $(OFILES) megatest.o -o mtest dboard : $(OFILES) $(GOFILES) dashboard.scm @@ -49,10 +49,13 @@ csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) -o dboard ndboard : newdashboard.scm $(OFILES) $(GOFILES) csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard +mtut: $(OFILES) mtut.scm + csc $(CSCOPTS) $(OFILES) mtut.scm -o mtut + # install documentation to $(PREFIX)/docs # DOES NOT REBUILD DOCS # $(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html mkdir -p $(PREFIX)/share/docs @@ -100,10 +103,17 @@ $(INSTALL) ndboard $(PREFIX)/bin/.$(ARCHSTR)/ndboard $(PREFIX)/bin/newdashboard : $(PREFIX)/bin/.$(ARCHSTR)/ndboard utils/mk_wrapper utils/mk_wrapper $(PREFIX) ndboard $(PREFIX)/bin/newdashboard chmod a+x $(PREFIX)/bin/newdashboard + +$(PREFIX)/bin/.$(ARCHSTR)/mtut : mtut + $(INSTALL) mtut $(PREFIX)/bin/.$(ARCHSTR)/mtut + +$(PREFIX)/bin/mtutil : $(PREFIX)/bin/.$(ARCHSTR)/mtut utils/mk_wrapper + utils/mk_wrapper $(PREFIX) mtut $(PREFIX)/bin/mtutil + chmod a+x $(PREFIX)/bin/mtutil #$(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard # $(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard # $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard utils/mk_wrapper @@ -178,11 +188,11 @@ $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ - $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun + $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil $(PREFIX)/bin/.$(ARCHSTR) : mkdir -p $(PREFIX)/bin/.$(ARCHSTR) mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -7,11 +7,12 @@ ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== -(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack) +(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack + matchable) (require-extension regex posix) (require-extension (srfi 18) extras tcp rpc) (import (prefix sqlite3 sqlite3:)) @@ -712,19 +713,10 @@ ;;====================================================================== ;; M I S C U T I L S ;;====================================================================== -;; one-of args defined -(define (args-defined? . param) - (let ((res #f)) - (for-each - (lambda (arg) - (if (args:get-arg arg)(set! res #t))) - param) - res)) - ;; convert stuff to a number if possible (define (any->number val) (cond ((number? val) val) ((string? val) (string->number val)) @@ -747,25 +739,10 @@ (set! res #t)))) (string-split patts ",")) res) #t)) -;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) -(define (common:get-runconfig-targets #!key (configf #f)) - (let ((targs (sort (map car (hash-table->alist - (or configf ;; NOTE: There is no value in using runconfig:read here. - (read-config (conc *toppath* "/runconfigs.config") - #f #t) - (make-hash-table)))) - string curmod last-mod) + (list curmod fname) + res))) + '(0 "n/a") + all-files))) + ;;====================================================================== ;; T A R G E T S , S T A T E , S T A T U S , ;; R U N N A M E A N D T E S T P A T T ;;====================================================================== + +;; (map print (map car (hash-table->alist (read-config "runconfigs.config" #f #t)))) +;; +(define (common:get-runconfig-targets #!key (configf #f)) + (let ((targs (sort (map car (hash-table->alist + (or configf ;; NOTE: There is no value in using runconfig:read here. + (read-config (conc *toppath* "/runconfigs.config") + #f #t) + (make-hash-table)))) + stringkeystr keys)) + (keystr (keys->keystr keys)) + (contour (or contour-in "")) ;; empty string to force no hierarcy and be backwards compatible. (comma (if (> (length keys) 0) "," "")) (andstr (if (> (length keys) 0) " AND " "")) (valslots (keys->valslots keys)) ;; ?,?,? ... - (allvals (append (list runname state status user) (map cadr keyvals))) + (allvals (append (list runname state status user contour) (map cadr keyvals))) (qryvals (append (list runname) (map cadr keyvals))) (key=?str (string-intersperse (map (lambda (k)(conc k "=?")) keys) " AND "))) (debug:print 3 *default-log-port* "keys: " keys " allvals: " allvals " keyvals: " keyvals " key=?str is " key=?str) (debug:print 2 *default-log-port* "NOTE: using target " (string-intersperse (map cadr keyvals) "/") " for this run") (if (and runname (null? (filter (lambda (x)(not x)) keyvals))) ;; there must be a better way to "apply and" (db:with-db dbstruct #f #f (lambda (db) (let ((res #f)) - (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time" comma keystr ") VALUES (?,?,?,?,strftime('%s','now')" comma valslots ");") + (apply sqlite3:execute db (conc "INSERT OR IGNORE INTO runs (runname,state,status,owner,event_time,contour" comma keystr ") VALUES (?,?,?,?,strftime('%s','now'),?" comma valslots ");") allvals) (apply sqlite3:for-each-row (lambda (id) (set! res id)) db Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -425,10 +425,11 @@ (env-ovrd (assoc/default 'env-ovrd cmdinfo)) (set-vars (assoc/default 'set-vars cmdinfo)) ;; pre-overrides from -setvar (runname (assoc/default 'runname cmdinfo)) (megatest (assoc/default 'megatest cmdinfo)) (runtlim (assoc/default 'runtlim cmdinfo)) + (contour (assoc/default 'contour cmdinfo)) (item-path (item-list->path itemdat)) (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo)) (keys #f) (keyvals #f) (fullrunscript (if (not runscript) @@ -440,10 +441,12 @@ (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path ) ;; (rollup-status 0) + (if contour (setenv "MT_CONTOUR" contour)) + ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? top-path) (> count 10)) (change-directory top-path) @@ -738,13 +741,14 @@ (define (launch:setup-body #!key (force #f)) (let* ((toppath (or *toppath* (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath (runname (common:args-get-runname)) (target (common:args-get-target)) (linktree (common:get-linktree)) + (contour (args:get-arg "-contour")) (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config - (rundir (if (and runname target linktree)(conc linktree "/" target "/" runname) #f)) + (rundir (if (and runname target linktree)(conc linktree (if contour (conc "/" contour) "") "/" target "/" runname) #f)) (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) (cancreate (and rundir (file-exists? rundir)(file-write-access? rundir))) (cxt (hash-table-ref/default *contexts* toppath #f))) @@ -907,10 +911,11 @@ (runname (if (string? run-info) ;; if we pass in a string as run-info use it as run-name. run-info (db:get-value-by-header (db:get-rows run-info) (db:get-header run-info) "runname"))) + (contour (args:get-arg "-contour")) ;; convert back to db: from rdb: - this is always run at server end (target (string-intersperse (map cadr keyvals) "/")) (not-iterated (equal? "" item-path)) @@ -917,18 +922,18 @@ ;; all tests are found at /test-base or /test-base (testtop-base (conc target "/" runname "/" testname)) (test-base (conc testtop-base (if not-iterated "" "/") item-path)) ;; nb// if itempath is not "" then it is prefixed with "/" - (toptest-path (conc disk-path "/" testtop-base)) - (test-path (conc disk-path "/" test-base)) + (toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base)) + (test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base)) ;; ensure this exists first as links to subtests must be created there (linktree (let ((rd (config-lookup *configdat* "setup" "linktree"))) (if rd rd (conc *toppath* "/runs")))) - (lnkbase (conc linktree "/" target "/" runname)) + (lnkbase (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname)) (lnkpath (conc lnkbase "/" testname)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)) (lnktarget (conc lnkpath "/" item-path))) ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical @@ -1076,11 +1081,12 @@ ;; - could be ssh to host from hosts table (update regularly with load) ;; - could be netbatch ;; (launch-test db (cadr status) test-conf)) (define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params) (mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex - (let* ((item-path (item-list->path itemdat))) + (let* ((item-path (item-list->path itemdat)) + (contour (args:get-arg "-contour"))) (let loop ((delta (- (current-seconds) *last-launch*)) (launch-delay (string->number (or (configf:lookup *configdat* "setup" "launch-delay") "5")))) (if (> launch-delay delta) (begin (debug:print-info 0 *default-log-port* "Delaying launch of " test-name " for " (- launch-delay delta) " seconds") @@ -1092,10 +1098,11 @@ (list (list "MT_RUN_AREA_HOME" *toppath*) (list "MT_TEST_NAME" test-name) (list "MT_RUNNAME" runname) (list "MT_ITEMPATH" item-path) + (list "MT_CONTOUR" contour) ) itemdat)) (let* ((tregistry (tests:get-all)) ;; third param (below) is system-allowed ;; for tconfig, why do we allow fallback to test-conf? (tconfig (or (tests:get-testconfig test-name item-path tregistry #t force-create: #t) @@ -1185,10 +1192,11 @@ ;; (list 'item-path item-path ) (list 'itemdat itemdat ) (list 'megatest remote-megatest) (list 'ezsteps ezsteps) (list 'target mt_target) + (list 'contour contour) (list 'runtlim (if run-time-limit (common:hms-string->seconds run-time-limit) #f)) (list 'env-ovrd (hash-table-ref/default *configdat* "env-override" '())) (list 'set-vars (if params (hash-table-ref/default params "-setvars" #f))) (list 'runname runname) (list 'mt-bindir-path mt-bindir-path)))))))) Index: margs.scm ================================================================== --- margs.scm +++ margs.scm @@ -15,10 +15,14 @@ (define (args:get-arg arg . default) (if (null? default) (hash-table-ref/default args:arg-hash arg #f) (hash-table-ref/default args:arg-hash arg (car default)))) +(define (args:any? . args) + (not (null? (filter (lambda (x) x) + (map args:get-arg args))))) + (define (args:get-arg-from ht arg . default) (if (null? default) (hash-table-ref/default ht arg #f) (hash-table-ref/default ht arg (car default)))) @@ -27,10 +31,19 @@ (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))) ADDED megatest.config Index: megatest.config ================================================================== --- /dev/null +++ megatest.config @@ -0,0 +1,13 @@ +[setup] +pktsdirs /tmp/pkts /some/other/source + +[areas] +# path-to-area map-target-script(future, optional) +fullrun tests/fullrun +ext-tests ext-tests + +[contours] +# mode-patt/tag-expr +quick quick/QUICKPATT +full all/MAXPATT quick/QUICKPATT + Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -1,6 +1,6 @@ -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2017, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -141,10 +141,11 @@ -fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps -sort fieldname : in -list-runs sort tests by this field Misc -start-dir path : switch to this directory before running megatest + -contour cname : add a level of hierarcy to the linktree and run paths -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db -import-megatest.db : migrate a database from v1.55 series to v1.60 series -sync-to-megatest.db : migrate data back to megatest.db -use-db-cache : use cached access to db to reduce load @@ -243,10 +244,11 @@ ":expected" ":tol" ":units" ;; misc "-start-dir" + "-contour" "-server" "-stop-server" "-transport" "-kill-server" "-port" ADDED mtut.scm Index: mtut.scm ================================================================== --- /dev/null +++ mtut.scm @@ -0,0 +1,539 @@ +;; Copyright 2006-2017, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;; (include "common.scm") +;; (include "megatest-version.scm") + +;; fake out readline usage of toplevel-command +(define (toplevel-command . a) #f) + +(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) + srfi-18 extras format pkts regex + (prefix dbi dbi:)) ;; zmq extras) + +(declare (uses common)) +(declare (uses megatest-version)) +(declare (uses margs)) +(declare (uses configf)) +;; (declare (uses runs)) +;; (declare (uses launch)) +;; (declare (uses server)) +;; (declare (uses client)) +;; (declare (uses tests)) +;; (declare (uses genexample)) +;; (declare (uses daemon)) +;; (declare (uses db)) +;; ;; (declare (uses dcommon)) +;; +;; (declare (uses tdb)) +;; (declare (uses mt)) +;; (declare (uses api)) +;; (declare (uses tasks)) ;; only used for debugging. +;; (declare (uses env)) +;; (declare (uses diff-report)) +;; +;; (define *db* #f) ;; this is only for the repl, do not use in general!!!! + +;; (include "common_records.scm") +;; (include "key_records.scm") +;; (include "db_records.scm") +;; (include "run_records.scm") +(include "megatest-fossil-hash.scm") + +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + +;; Disabled help items +;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) +;; from prior runs with same keys + +(define help (conc " +mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest + version " megatest-version " + 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 + process : runs import, rungen and dispatch + +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 + -run-name : required, name for this particular test run + -contour contourname : run all targets for contourname, requires -run-name, -target + -state-status c/p,c/f : Specify a list of state and status patterns + -tag-expr tag1,tag2%,.. : select tests with tags matching expression + -mode-patt key : load testpatt from in runconfigs instead of default TESTPATT + if -testpatt and -tagexpr are not specified + -new state/status : specify new state/status for set-ss + +Misc + -start-dir path : switch to this directory before running mtutil + -set-vars V1=1,V2=2 : Add environment variables to a run NB// these are + overwritten by values set in config files. + -log logfile : send stdout and stderr to logfile + -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* + '(("-area" . G) ;; maps to group + ("-target" . t) + ("-run-name" . n) + ("-state" . e) + ("-status" . s) + ("-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) + ("-help" . #f) + ("--help" . #f) + ("-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*))) + +;; 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 +;; 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)) " "))) + +(if (or (args:any? "-h" "help" "-help" "--help") + (member *action* '("-h" "-help" "--help" "help"))) + (begin + (print help) + (exit 1))) + +;;====================================================================== +;; pkts +;;====================================================================== + +(define (with-queue-db mtconf proc) + (let* ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) + (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) + (toppath (configf:lookup mtconf "dyndat" "toppath")) + (pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir))) + (if (not (and pktsdir toppath pdbpath)) + (begin + (print "ERROR: settings are missing in your megatest.config for area management.") + (print " you need to have pktsdir in the [setup] section.")) + (let* ((pdb (open-queue-db pdbpath "pkts.db" + schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) + (proc pktsdirs pktsdir pdb) + (dbi:close pdb))))) + +(define (load-pkts-to-db mtconf) + (with-queue-db + mtconf + (lambda (pktsdirs pktsdir pdb) + (for-each + (lambda (pktsdir) ;; look at all + (if (and (file-exists? pktsdir) + (directory? pktsdir) + (file-read-access? pktsdir)) + (let ((pkts (glob (conc pktsdir "/*.pkt")))) + (for-each + (lambda (pkt) + (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) + (exists (lookup-by-uuid pdb uuid #f))) + (if (not exists) + (let* ((pktdat (string-intersperse + (with-input-from-file pkt read-lines) + "\n")) + (apkt (convert-pkt->alist pktdat)) + (ptype (alist-ref 'T apkt))) + (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) + (print "Added " uuid " of type " ptype " to queue")) + (print "pkt: " uuid " exists, skipping...") + ))) + pkts)))) + (string-split pktsdirs))))) + +;;====================================================================== +;; Runs +;;====================================================================== + +;; make a runname +;; +(define (make-runname pre post) + (time->string + (seconds->local-time (current-seconds)) "%Yw%V.%w-%H%M")) + +;; 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) + (cdr (or pmeta smeta)) + #f))) + (if (or pmeta smeta) + (list meta value) + '()))) + (filter cdr args-data))))) +;; (print "Alldat: " alldat +;; " args-data: " args-data) + (add-z-card + (apply construct-sdat alldat)))) + +(define (simple-setup start-dir-in) + (let* ((start-dir (or start-dir-in ".")) + (mtconfig (or (args:get-arg "-config") "megatest.config")) + (mtconfdat (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect + mtconfig + ;; environ-patt: "env-override" + given-toppath: start-dir + ;; pathenvvar: "MT_RUN_AREA_HOME" + )) + (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)) + + +;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db. + + +;; make a run request pkt from basic data +;; +(define (create-run-pkt mtconf area runkey runname mode-patt tag-expr pktsdir reason contour) + (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) + ("-contour" . ,contour)) + (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 "" "")) + (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 file-or) ;; one or more files must be newer than the reference + (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)) + )) + ((file-and) ;; all files must be newer than the reference + (let* ((file-globs (cdr valparts)) + (youngestdat (common:get-youngest file-globs)) + (youngestmod (car youngestdat)) + (success #t)) ;; any cases of not true, set flag to #f for AND + ;; (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)) + (set! success #f))) + starttimes)) + (if success + (begin + (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod) + (configf:section-var-set! torun contour runkey `(,(conc ruletype ":" (cadr youngestdat)) ,runname)))))) + ))) + 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 contour))) + 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) + (if par + (conc res " " (param-translate par) " " val) + res))) + "megatest -run" + pkta)) + +(define (write-pkt pktsdir uuid pkt) + (if pktsdir + (with-output-to-file + (conc pktsdir "/" uuid ".pkt") + (lambda () + (print pkt))) + (print "ERROR: cannot process commands without a pkts directory"))) + +;; 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)) + (uuid (alist-ref 'Z pkta)) + (logf (conc "logs/" uuid "-run.log"))) + (system (conc "NBFAKE_LOG=" logf " nbfake " cmdline)) + (mark-processed pdb (list (alist-ref 'id pktdat))) + (let-values (((ack-uuid ack-pkt) + (add-z-card + (construct-sdat 'P uuid + 'T "runstart" + 'c (alist-ref 'o pkta) ;; THIS IS WRONG! SHOULD BE 'c + 't (alist-ref 't pkta))))) + (write-pkt pktsdir ack-uuid ack-pkt)))) + 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))) + (write-pkt pktsdir uuid pkt)))) + ((dispatch import rungen process) + (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) + (mtconf (car mtconfdat)) + (toppath (configf:lookup mtconf "dyndat" "toppath"))) + (case (string->symbol *action*) + ((process) (begin + (load-pkts-to-db mtconf) + (generate-run-pkts mtconf toppath) + (load-pkts-to-db mtconf) + (dispatch-commands mtconf toppath))) + ((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) + (import apropos) + ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... + + (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines]) + (current-input-port (make-readline-port "mtutil> ")) + (if (args:get-arg "-repl") + (repl) + (load (args:get-arg "-load"))))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -563,12 +563,12 @@ (define (rmt:get-num-runs runpatt) (rmt:send-receive 'get-num-runs #f (list runpatt))) ;; Use the special run-id == #f scenario here since there is no run yet -(define (rmt:register-run keyvals runname state status user) - (rmt:send-receive 'register-run #f (list keyvals runname state status user))) +(define (rmt:register-run keyvals runname state status user contour) + (rmt:send-receive 'register-run #f (list keyvals runname state status user contour))) (define (rmt:get-run-name-from-id run-id) (rmt:send-receive 'get-run-name-from-id run-id (list run-id))) (define (rmt:delete-run run-id) Index: runconfig.scm ================================================================== --- runconfig.scm +++ runconfig.scm @@ -80,6 +80,68 @@ environ-patt: (conc "(default" (if targ (conc "|" targ ")") ")"))) (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf)))) - + +;; given (a (b c) d) return ((a b d)(a c d)) +;; NOTE: this feels like it has been done before - perhaps with items handling? +;; +(define (runconfig:combinations inlst) + (let loop ((hed (car inlst)) + (tal (cdr inlst)) + (res '())) + ;; (print "res: " res " hed: " hed) + (if (list? hed) + (let ((newres (if (null? res) ;; first time through convert incoming items to list of items + (map list hed) + (apply append + (map (lambda (r) ;; iterate over items in res + (map (lambda (h) ;; iterate over items in hed + (append r (list h))) + hed)) + res))))) + ;; (print "newres1: " newres) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres))) + (let ((newres (if (null? res) + (list (list hed)) + (map (lambda (r) + (append r (list hed))) + res)))) + ;; (print "newres2: " newres) + (if (null? tal) + newres + (loop (car tal)(cdr tal) newres)))))) + +;; multi-part expand +;; Given a/b,c,d/e,f return a/b/e a/b/f a/c/e a/c/f a/d/e a/d/f +;; +(define (runconfig:expand target) + (let* ((parts (map (lambda (x) + (string-split x ",")) + (string-split target "/")))) + (map (lambda (x) + (string-intersperse x "/")) + (runconfig:combinations parts)))) + +;; multi-target expansion +;; a/b/c/x,y,z a/b/d/x,y => a/b/c/x a/b/c/y a/b/c/z a/b/d/x a/b/d/y +;; +(define (runconfig:expand-target target-strs) + (delete-duplicates + (apply append (map runconfig:expand (string-split target-strs " "))))) + +#| + (if (null? target-strs) + '() + (let loop ((hed (car target-strs)) + (tal (cdr target-strs)) + (res '())) + ;; first break all parts into individual target patterns + (if (string-index hed " ") ;; this is a multi-target target + (let ((newres (append (string-split hed " ") res))) + (runconfig:expand-target newres)) + (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated + +|# ADDED rungen.config Index: rungen.config ================================================================== --- /dev/null +++ rungen.config @@ -0,0 +1,18 @@ +[v1.63/tip/dev] +# 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 runname params +quick:file auto *.scm +quick:script auto checkfossil.sh v1.63 + +# field allowed values +# ----- -------------- +# minute 0-59 +# hour 0-23 +# day of month 1-31 +# month 1-12 (or names, see below) +# day of week 0-7 (0 or 7 is Sun, or use names) + +# every friday at midnight run all +all:scheduled auto 0 0 0 0 5 Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -199,11 +199,11 @@ ;; FIXME: error out if /patt specified ;; (define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names (let* ((keys (keys:config-get-fields *configdat*)) (keyvals (keys:target->keyval keys target)) - (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) + (run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (test-records (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names @@ -211,11 +211,12 @@ (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) (required-tests #f) ;; Put fully qualified test/testpath names in this list to be done (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) (tdbdat (tasks:open-db)) (config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) - (if x (string->number x) #f)))) + (if x (string->number x) #f))) + (allowed-tests #f)) ;; per user request. If less than 100Meg space on dbdir partition, bail out with error ;; this will reduce issues in database corruption (common:check-db-dir-and-exit-if-insufficient) @@ -253,19 +254,26 @@ (debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf) #f))) (if (not test-patts) ;; first time in - adjust testpatt (set! test-patts (common:args-get-testpatt runconf))) + (if (args:get-arg "-tagexpr") + (set! allowed-tests (string-join (runs:get-tests-matching-tags (args:get-arg "-tagexpr")) ","))) ;; tests will be ANDed with this list ;; register this run in monitor.db (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) (rmt:tasks-set-state-given-param-key task-key "running") ;; Now generate all the tests lists (set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test (set! all-test-names (hash-table-keys all-tests-registry)) - (set! test-names (tests:filter-test-names all-test-names test-patts)) + ;; filter first for allowed-tests (from -tagexpr) then for test-patts. + (set! test-names (tests:filter-test-names + (if allowed-tests + (tests:filter-test-names all-test-names allowed-tests) + all-test-names) + test-patts)) ;; I think seeding required-tests with all test-names makes sense but lack analysis to back that up. ;; NEW STRATEGY HERE: ;; 1. fill required tests with test-patts @@ -1043,11 +1051,11 @@ ;; Do mark-and-find clean up of db before starting runing of quue ;; ;; (rmt:find-and-mark-incomplete) - (let* ((run-info (rmt:get-run-info run-id)) + (let* ((run-info (rmt:get-run-info run-id)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) (registry-mutex (make-mutex)) (num-retries 0) @@ -1968,11 +1976,11 @@ (let* ((tagdata (rmt:get-tests-tags)) (res '())) ;; list of tests that match one or more tags (for-each (lambda (tag) (if (patt-list-match tag tagpatt) - (set! res (append (hash-table-ref tagdata tag))))) + (set! res (append (hash-table-ref tagdata tag) res)))) (hash-table-keys tagdata)) res)) ;; Update test_meta for all tests @@ -1989,11 +1997,11 @@ ;; (define (runs:rollup-run keys runname user keyvals) (debug:print 4 *default-log-port* "runs:rollup-run, keys: " keys " -runname " runname " user: " user) (let* ((db #f) ;; register run operates on the main db - (new-run-id (rmt:register-run keyvals runname "new" "n/a" user)) + (new-run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour"))) (prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%")) (curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '())) (curr-tests-hash (make-hash-table))) (rmt:update-run-event_time new-run-id) ;; index the already saved tests by testname and itemdat in curr-tests-hash Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -183,11 +183,14 @@ (if (null? server-logs) '() (let loop ((hed (car server-logs)) (tal (cdr server-logs)) (res '())) - (let* ((mod-time (file-modification-time hed)) + (let* ((mod-time (handle-exceptions + exn + 0 + (file-modification-time hed))) ;; default to *very* old so log gets ignored if deleted (down-time (- (current-seconds) mod-time)) (serv-dat (if (or (< num-serv-logs 10) (< down-time day-seconds)) (server:logf-get-start-info hed) '())) ;; don't waste time processing server files not touched in the past day if there are more than ten servers to look at @@ -394,9 +397,9 @@ (let ((tmo (configf:lookup *configdat* "server" "timeout"))) (if (and (string? tmo) (string->number tmo)) (* 60 60 (string->number tmo)) ;; (* 3 24 60 60) ;; default to three days - (* 60 1) ;; default to one minute + (* 60 60 1) ;; default to one hour ;; (* 60 60 25) ;; default to 25 hours ))) Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ tests/fullrun/runconfigs.config @@ -43,6 +43,16 @@ [ubuntu/nfs/sleep60] SLEEPRUNNER 60 [ubuntu/nfs/sleep240] SLEEPRUNNER 240 + +[v1.63/tip/dev] +QUICKPATT %/desert,%/ae +# OTHER_PATT foo%/desert,%/ae + +# [v1.63/%/%] +# QUICKPATT %/desert,%/ae + +[nada/foo/bar] +junk foo Index: tests/fullrun/tests/sqlitespeed/testconfig ================================================================== --- tests/fullrun/tests/sqlitespeed/testconfig +++ tests/fullrun/tests/sqlitespeed/testconfig @@ -9,5 +9,7 @@ MANYITEMS [system (env > envfile.txt;echo aa ab ac ad ae af ag ah ai)] # BORKED [test_meta] jobgroup sqlite3 +tags quick + Index: tests/simplerun/tests/test2/testconfig ================================================================== --- tests/simplerun/tests/test2/testconfig +++ tests/simplerun/tests/test2/testconfig @@ -15,7 +15,7 @@ # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt description Yet another example test -tags tagone,tagtwo +tags tagone,tagtwo,quick reviewed never