Megatest

Check-in [649822464b]
Login
Overview
Comment:Added -rerun-clean and -rerun-all. Added -list-pkt-keys
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65-matt-misc
Files: files | file ages | folders
SHA1: 649822464b92911db5733c5a6cd604d27f691387
User & Date: mrwellan on 2018-03-05 17:13:26
Other Links: branch diff | manifest | tags
Context
2018-03-05
21:11
Fix few minor issues with mtutil updates Leaf check-in: e99d630f55 user: matt tags: v1.65-matt-misc
17:13
Added -rerun-clean and -rerun-all. Added -list-pkt-keys check-in: 649822464b user: mrwellan tags: v1.65-matt-misc
08:14
Updated manual with license header check-in: 93e4191ac5 user: mrwellan tags: v1.65
Changes

Modified Makefile from [7c99a1da4e] to [187b076113].

287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
	mkdir -p ext-tests
	cd ext-tests;fossil open --nested $(MTQA_FOSSIL)

$(MTQA_FOSSIL) :
	fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)

clean : 
	rm -f $(OFILES) $(GOFILES)$(MOFILES) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm

#======================================================================
# Make the records files
#======================================================================

# vg_records.scm : records.sh
#	./records.sh







|







287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
	mkdir -p ext-tests
	cd ext-tests;fossil open --nested $(MTQA_FOSSIL)

$(MTQA_FOSSIL) :
	fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)

clean : 
	rm -f $(OFILES) $(GOFILES)$(MOFILES) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o

#======================================================================
# Make the records files
#======================================================================

# vg_records.scm : records.sh
#	./records.sh

Modified dashboard.scm from [27048ed2fa] to [0829612ed4].

83
84
85
86
87
88
89

90
91
92
93
94
95
96
			"-cols"
			"-run"
			"-test"
                        "-xterm"
			"-debug"
			"-host" 
			"-transport"

			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"







>







83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
			"-cols"
			"-run"
			"-test"
                        "-xterm"
			"-debug"
			"-host" 
			"-transport"
                        "-start-dir"
			) 
		 (list  "-h"
			"-use-server"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
107
108
109
110
111
112
113









114
115
116
117
118
119
120
      (print "Unrecognised arguments: " (string-intersperse remargs " "))
      (exit)))

(if (args:get-arg "-h")
    (begin
      (print help)
      (exit)))










;; TODO: Move this inside (main)
;;
(if (not (launch:setup))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))







>
>
>
>
>
>
>
>
>







108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
      (print "Unrecognised arguments: " (string-intersperse remargs " "))
      (exit)))

(if (args:get-arg "-h")
    (begin
      (print help)
      (exit)))

(if (args:get-arg "-start-dir")
    (if (directory-exists? (args:get-arg "-start-dir"))
        (let ((fullpath (common:real-path (args:get-arg "-start-dir"))))
          (setenv "PWD" fullpath)
          (change-directory fullpath))
	(begin
	  (debug:print-error 0 *default-log-port* "non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
	  (exit 1))))

;; TODO: Move this inside (main)
;;
(if (not (launch:setup))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

Modified mtut.scm from [785749fa0e] to [a18d19941b].

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
;;
(if (common:file-exists? "megatest.config")
    (if (common:file-exists? ".mtutil.so")
	(load ".mtutil.so")
	(if (common:file-exists? ".mtutil.scm")
            (load ".mtutil.scm"))))










;; Disabled help items
;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;;                            from prior runs with same keys
;; 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

(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
   db                        : database utilities


   areas, contours, setup    : show areas, contours or setup section from megatest.config
   gendot                    : generate a graphviz dot file from pkts.

Contour actions:
   process                   : runs import, rungen and dispatch 
			     
Trigger propagation actions:







>
>
>
>
>
>
>
>
>


















|
|
>
>
>

<




>
>







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 (common:file-exists? "megatest.config")
    (if (common:file-exists? ".mtutil.so")
	(load ".mtutil.so")
	(if (common:file-exists? ".mtutil.scm")
            (load ".mtutil.scm"))))

;; main three types of run
;;  "-run"         => initiate a run
;;  "-rerun-clean" => set failed, aborted, killed, etc. (not pass/fail) to NOT_STARTED and kick off run
;;  "-rerun-all"   => set all tests NOT_STARTED and kick off run again

;; deprecated/do not use
;;  "-runall"      => synonym for run, do not use
;;  "-runtests"    => synonym for run, do not use

;; Disabled help items
;;  -rollup                 : (currently disabled) fill run (set by :runname)  with latest test(s)
;;                            from prior runs with same keys
;; 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

(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 ")
			     
Run management:		     
   run                       : initiate or resume a run, already completed and in-progress
                               tests are not affected.
   rerun-clean               : clean and rerun all not completed pass/fail tests
   rerun-all                 : clean and rerun entire run
   remove                    : remove runs

   set-ss                    : set state/status
   archive                   : compress and move test data to archive disk
   kill                      : stop tests or entire runs
   db                        : database utilities

Queries:
   areas, contours, setup    : show areas, contours or setup section from megatest.config
   gendot                    : generate a graphviz dot file from pkts.

Contour actions:
   process                   : runs import, rungen and dispatch 
			     
Trigger propagation actions:
152
153
154
155
156
157
158

159
160
161
162
163
164
165
  -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 ...

			     
Utility			     
 db pgschema                 : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"

Examples:

# Start a megatest run in the area \"mytests\"







>







165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
  -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 ...
  -list-pkt-keys             : list all pkt keys
			     
Utility			     
 db pgschema                 : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"

Examples:

# Start a megatest run in the area \"mytests\"
207
208
209
210
211
212
213
214
215

216
217
218
219
220


221
222
223
224
225
226
227
    ("--help"           . #f)
    ("-manual"          . #f)
    ("-version"         . #f)
    ;; misc	        
    ("-repl"            . #f)
    ("-immediate"       . I)
    ("-preclean"        . r)
    ("-rerun-all"       . u)
    ("-prepend-contour" . w)

    ))

;; alist to map actions to old megatest commands
(define *action-keys*
  '((run         . "-run")


    (sync        . "")
    (archive     . "-archive")
    (set-ss      . "-set-state-status")
    (remove      . "-remove-runs")))

;; Card types:
;;







<

>





>
>







221
222
223
224
225
226
227

228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
    ("--help"           . #f)
    ("-manual"          . #f)
    ("-version"         . #f)
    ;; misc	        
    ("-repl"            . #f)
    ("-immediate"       . I)
    ("-preclean"        . r)

    ("-prepend-contour" . w)
    ("-list-pkt-keys"   . #f)
    ))

;; alist to map actions to old megatest commands
(define *action-keys*
  '((run         . "-run")
    (rerun-clean . "-rerun-clean")
    (rerun-all   . "-rerun-all")
    (sync        . "")
    (archive     . "-archive")
    (set-ss      . "-set-state-status")
    (remove      . "-remove-runs")))

;; Card types:
;;
262
263
264
265
266
267
268



269
270
271
272
273
274
275
	      res))
	#f
	(or inlst *arg-keys*)))

(define (lookup-action-by-key key)
  (alist-ref (string->symbol key) *action-keys*))




;;======================================================================
;;  U T I L S
;;======================================================================

;; given a mtutil param, return the old megatest equivalent
;;
(define (megatest-param->mtutil-param param)







>
>
>







278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
	      res))
	#f
	(or inlst *arg-keys*)))

(define (lookup-action-by-key key)
  (alist-ref (string->symbol key) *action-keys*))

(define (swizzle-alist lst)
  (map (lambda (x)(cons (cdr x)(car x))) lst))

;;======================================================================
;;  U T I L S
;;======================================================================

;; given a mtutil param, return the old megatest equivalent
;;
(define (megatest-param->mtutil-param param)
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
	(close-input-port timeline-port)
	(values  (common:date-time->seconds (conc date " " time)) node))))))

;;======================================================================
;; GLOBALS
;;======================================================================

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







|
|
>


>
>







>
>






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

>







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
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
	(close-input-port timeline-port)
	(values  (common:date-time->seconds (conc date " " time)) node))))))

;;======================================================================
;; GLOBALS
;;======================================================================

;; first token is our action, but only if no leading dash
(define *action* (if (and (> (length (argv)) 1)
                          (not (string-match "^\\-.*" (cadr (argv)))))
		     (cadr (argv))
		     #f))

;; process arguments, extract switches and parameters first
(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))

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

(define (print-pkt-keys inlst)
  (for-each
   (lambda (p)
     (let ((sw (car p))
           (c  (cdr p)))
       (print (or c "n/a") "\t" sw)))
   inlst))

(define (print-duplicate-keys . all)
  (let ((card-hash (make-hash-table)))
    (for-each
     (lambda (lst)
       (for-each
        (lambda (card-spec)
          (let ((k (cdr card-spec)))
            ;; (print "card-spec: " card-spec ", k: " k)
            (if k (hash-table-set! card-hash k (+ (hash-table-ref/default card-hash k 0) 1)))))
        lst))
     all)
    (for-each
     (lambda (k)
       (if (> (hash-table-ref card-hash k) 1)
           (print k "\t" (hash-table-ref card-hash k))))
     (sort (hash-table-keys card-hash) (lambda (a b)(>= (hash-table-ref card-hash a)(hash-table-ref card-hash b)))))
    ))

(define (print-pkt-key-info)
  (print "Argument keys")
  (print-pkt-keys *arg-keys*)
  (print "\nSwitch keys")
  (print-pkt-keys *switch-keys*)
  (print "\nAction keys")
  (print-pkt-keys *action-keys*)
  (print "\nAdditional cards")
  (print-pkt-keys (swizzle-alist *additional-cards*))
  (print "\nDuplicate keys")
  (print-duplicate-keys *arg-keys* *switch-keys* *action-keys* (swizzle-alist *additional-cards*))
  (print "\nEnd of report.")
  )

;; list packet keys
;;
(if (args:get-arg "-list-pkt-keys")
    (begin (print-pkt-key-info)(exit 0)))

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