Megatest

Check-in [2d65cd8ad0]
Login
Overview
Comment:Merged v1.65-matt-misc into v1.65
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65
Files: files | file ages | folders
SHA1: 2d65cd8ad02de59743a61d2a04517f4b3968718b
User & Date: matt on 2018-03-05 21:11:58
Other Links: branch diff | manifest | tags
Context
2018-03-06
09:36
Added tcmt objects to make clean check-in: f5f300b27d user: jmoon18 tags: v1.65
2018-03-05
21:11
Merged v1.65-matt-misc into v1.65 check-in: 2d65cd8ad0 user: matt tags: v1.65
21:11
Fix few minor issues with mtutil updates Leaf check-in: e99d630f55 user: matt 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 megatest.config from [2f327616bb] to [3994f691c8].

47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

[nopurpose]

[access]
ext matt:admin mattw:owner

[accesstypes]
admin run rerun resume remove set-ss
owner run rerun resume remove
badguy set-ss

[setup]
maxload 1.2

[listeners]
localhost:12345  contact=matt@kiatoa.com







|
|







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

[nopurpose]

[access]
ext matt:admin mattw:owner

[accesstypes]
admin run rerun resume remove set-ss rerun-clean
owner run rerun resume remove rerun-all
badguy set-ss

[setup]
maxload 1.2

[listeners]
localhost:12345  contact=matt@kiatoa.com

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

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
228
229
230
231
    ("--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:
;;
;; A action
;; U username (Unix)
;; D timestamp
;; T card type







<

>





>
>




>
>
>
>
>
>
>







221
222
223
224
225
226
227

228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
    ("--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")))

;; manually keep this list updated from the keys to
;; the case *action* near the end of this file.
(define *other-actions*
  '(run remove rerun set-ss archive kill list
	dispatch import rungen process
	show gendot db tsend tlisten))

;; Card types:
;;
;; A action
;; U username (Unix)
;; D timestamp
;; T card type
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)







>
>
>







285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
	      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))







|
|
>


>
>







>
>






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

>







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
445
446
447
448
449
450
451
	(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))
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127

(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

(if *action*
    (case (string->symbol *action*)
      ((run remove rerun set-ss archive kill list)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (area      (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
	      (areasec   (if area (configf:lookup mtconf "areas" area) #f))
	      (areadat   (if areasec (common:val->alist areasec) #f))
	      (area-path (if areadat (alist-ref 'path areadat) #f))
	      (pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))







|







1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204

(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
  (if (common:file-exists? debugcontrolf)
      (load debugcontrolf)))

(if *action*
    (case (string->symbol *action*)
      ((run remove rerun rerun-clean rerun-all set-ss archive kill list)
       (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
	      (mtconf    (car mtconfdat))
	      (area      (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section
	      (areasec   (if area (configf:lookup mtconf "areas" area) #f))
	      (areadat   (if areasec (common:val->alist areasec) #f))
	      (area-path (if areadat (alist-ref 'path areadat) #f))
	      (pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
1256
1257
1258
1259
1260
1261
1262
1263



1264
1265
1266
1267
1268
1269
1270
														(set-signal-handler! signal/term special-signal-handler)

                            (let loop ((instr (nn-recv rep)))
                               (print "received " instr ", running \"" script " " instr "\"")
                               (system (conc script " '" instr "'"))
                               (nn-send rep "ok")
                               (loop (nn-recv rep))))
                     (print "ERROR: Port " portnum " already in use. Try another port")))))))



      
      )) ;; the end
             

;; If HTTP_HOST is defined then we must be in the cgi environment
;; so run stml and exit
;;







|
>
>
>







1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
														(set-signal-handler! signal/term special-signal-handler)

                            (let loop ((instr (nn-recv rep)))
                               (print "received " instr ", running \"" script " " instr "\"")
                               (system (conc script " '" instr "'"))
                               (nn-send rep "ok")
                               (loop (nn-recv rep))))
		       (print "ERROR: Port " portnum " already in use. Try another port")))))))
      (else
       (let ((all-actions (sort (map conc (delete-duplicates (append *other-actions* (map car *action-keys*)))) string<=?)))
	 (print "unrecognised action: \"" *action* "\", try one of; \"" (string-intersperse all-actions "\", \"") "\"")))
      
      )) ;; the end
             

;; If HTTP_HOST is defined then we must be in the cgi environment
;; so run stml and exit
;;