Megatest

Check-in [83aea4b059]
Login
Overview
Comment:Split sensing out to new config file rungen.config
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | run-mgr
Files: files | file ages | folders
SHA1: 83aea4b05914d4c858de0a72e856a8abf1f521a4
User & Date: matt on 2017-02-12 11:48:49
Other Links: branch diff | manifest | tags
Context
2017-02-12
14:32
Progress snapshot check-in: 00aca6f09e user: matt tags: run-mgr
11:48
Split sensing out to new config file rungen.config check-in: 83aea4b059 user: matt tags: run-mgr
03:07
Added megatest.config in top dir for developing mtutil. check-in: e8b9f87644 user: matt tags: run-mgr
Changes

Modified common.scm from [ef963426c3] to [a2dcc7ec73].

745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
745
746
747
748
749
750
751















752
753
754
755
756
757
758







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-







	     (debug:print-info 10 *default-log-port* "patt " patt " modpatt " modpatt)
	     (if (string-match (regexp modpatt) item)
		 (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<?))
	(target-patt (args:get-arg "-target")))
    (if target-patt
	(filter (lambda (x)
		  (patt-list-match x target-patt))
		targs)
	targs)))

;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))'
(define (common:get-disks #!key (configf #f))
  (hash-table-ref/default 
   (or configf (read-config "megatest.config" #f #t))
   "disks" '("none" "")))

;; return first command that exists, else #f
817
818
819
820
821
822
823
824
















825

826
827
828
829
830
831
832
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+







		  #f
		  (loop (car tal)(cdr tal))))))))
  
;;======================================================================
;; 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))))
			   string<?))
	(target-patt (args:get-arg "-target")))
    (if target-patt
	(filter (lambda (x)
		  (patt-list-match x target-patt))
		targs)
	targs)))

;; Lookup a value in runconfigs based on -reqtarg or -target
;; 
(define (runconfigs-get config var)
  (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
    (if targ
	(or (configf:lookup config targ var)
	    (configf:lookup config "default" var))
	(configf:lookup config "default" var))))

Modified megatest.config from [c92e6b4a06] to [b40ed6ff61].

1
2

3
4
5
6
7




1

2
3
4
5
6
7
8
9
10
11

-
+





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

[areas]
fullrun tests/fullrun
ext-tests ext-tests

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

Modified mtut.scm from [4b4f3840c4] to [5bb4365b55].

67
68
69
70
71
72
73
74



75
76
77
78
79
80
81

82

83
84
85
86
87
88
89
90
91
92
67
68
69
70
71
72
73

74
75
76
77
78
79
80
81
82
83
84
85
86
87
88

89
90
91
92
93
94
95







-
+
+
+







+

+


-







Actions include:
   run                     : initial 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
   process                 : master area only, process pkts, manage run jobs
   import                  : master area only, import pkts
   process                 : process imported pkts, manage run jobs
   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
  -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 <key> in runconfigs instead of default TESTPATT
                             if -testpatt and -tagexpr are not specified
  -tag-expr tag1,tag2%,..  : select tests with tags matching expression
  -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
107
108
109
110
111
112
113

114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137

138
139
140
141
142
143
144







+




















-







(define *arg-keys*
  '(("-run"        . r)
    ("-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"  . #f)
    ("-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)
    ("-process"    . #f) ;; read any new actions, process actions as needed, archive action pkts when appropriate
    ))

;; a action
;; u username (Unix)
;; D timestamp

;; process args
166
167
168
169
170
171
172
173
174
175
176





177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195





















196
197
198
199
200
201
202
169
170
171
172
173
174
175




176
177
178
179
180
181
182
183
184















185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212







-
-
-
-
+
+
+
+
+




-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







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

;;======================================================================
;; Process pkts
;;======================================================================

(define (load-pkts-to-db mtconf)
  (let* ((pktsdir (configf:lookup mtconf "setup"  "pktsdir"))
	 (toppath (configf:lookup mtconf "dyndat" "toppath"))
	 (pdbpath (or (configf:lookup mtconf "setup"  "pdbpath") pktsdir)))
    (if (not (and pktsdir toppath pdbpath))
  (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));")))
	       (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")))
		     (add-to-queue pdb pktdat uuid 'cmd #f 0)
		     (print "Added " uuid " to queue"))
		   (print "pkt: " uuid " exists, skipping...")
		   )))
	   pkts)
				    schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
	  (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")))
			      (add-to-queue pdb pktdat uuid 'cmd #f 0)
			      (print "Added " uuid " to queue"))
			    (print "pkt: " uuid " exists, skipping...")
			    )))
		    pkts))))
	   (string-split pktsdirs))
	  (dbi:close pdb)))))

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

;; collect, translate, collate and assemble a pkt from the command-line
240
241
242
243
244
245
246
247


248
249
250
251
252
253
254
255
256
257
258
259
260
261
262

263
264

265

266
267
268
269
270
271
272
250
251
252
253
254
255
256

257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272

273
274
275
276

277
278
279
280
281
282
283
284







-
+
+














-
+


+
-
+







    mtconfdat))

(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))
	      (pktsdir   (configf:lookup mtconf "setup" "pktsdir"))
	      (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 #f adjargs)))
	   (if pktsdir
	       (with-output-to-file
		   (conc pktsdir "/" uuid ".pkt")
		 (lambda ()
		   (print pkt)))
	       (print "ERROR: cannot process commands without a pkts directory")))))
      ((process)
      ((process import rungen)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat)))
	 (case (string->symbol *action*)
	 (load-pkts-to-db mtconf)))))
	   ((import)(load-pkts-to-db mtconf)))))))

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

Modified runconfig.scm from [6cd6ed4572] to [84192ee0cf].

78
79
80
81
82
83
84
85































































78
79
80
81
82
83
84

85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147







-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
    (if (file-exists? runconfigf)
	(setup-env-defaults runconfigf run-id #t keyvals
			    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 version [1240de112d].








1
2
3
4
5
6
7
+
+
+
+
+
+
+
[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