Megatest

Check-in [17f63f989a]
Login
Overview
Comment:Merged from v1.64 into v1.65
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.65
Files: files | file ages | folders
SHA1: 17f63f989af77ffcca34d142b8ef5c210323e098
User & Date: matt on 2017-06-17 09:34:02
Other Links: branch diff | manifest | tags
Context
2017-06-18
22:24
Minor cleanup check-in: edc83414c9 user: matt tags: v1.65
2017-06-17
09:34
Merged from v1.64 into v1.65 check-in: 17f63f989a user: matt tags: v1.65
09:09
Side fix to mtutil check-in: 06a1cb9d9b user: matt tags: v1.64
2017-06-16
14:23
committed latest changes, fixed issue where pkts aren't created check-in: 958206e68a user: srehman tags: v1.65
Changes

cgisetup/cgi-bin/models became a symlink with target [39c07627cc].

cgisetup/cgi-bin/pages became a symlink with target [e2b5ed002d].

Modified common.scm from [716d930486] to [9e020393b8].

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
(define (common:api-changed?)
  (not (equal? (substring (->string megatest-version) 0 4)
               (substring (conc (common:get-last-run-version)) 0 4))))
  
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct)
  (db:multi-db-sync 
   dbstruct
   'schema
   ;; 'new2old
   'killservers
   'dejunk
   'adj-target
   ;; 'old2new
   'new2old


   )
  (if (common:api-changed?)
      (common:set-last-run-version)))

;; Rotate logs, logic: 
;;                 if > 500k and older than 1 week:
;;                     remove previous compressed log and compress this log
;; WARNING: This proc operates assuming that it is in the directory above the







|
|




<



>
>
|







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
(define (common:api-changed?)
  (not (equal? (substring (->string megatest-version) 0 4)
               (substring (conc (common:get-last-run-version)) 0 4))))
  
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct #!key (full #f))
  (apply db:multi-db-sync 
   dbstruct
   'schema
   ;; 'new2old
   'killservers

   'adj-target
   ;; 'old2new
   'new2old
   (if full
       '(dejunk)
       '()))
  (if (common:api-changed?)
      (common:set-last-run-version)))

;; Rotate logs, logic: 
;;                 if > 500k and older than 1 week:
;;                     remove previous compressed log and compress this log
;; WARNING: This proc operates assuming that it is in the directory above the

Modified megatest.config from [78a0dc8a42] to [eaac1879ba].



1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35


# [fields]
# a text
# b text
# c text

# control over usercode location not implemented, for now must be .mtutil.scm
usercode    .mtutil.scm
areafilter  area-to-run
targtrans   generic-target-translator
runtrans    generic-runname-translator

[setup]
pktsdirs /tmp/mt_pkts /some/other/source

[areas]
#         path-to-area   map-target-script(future, optional)
# someqa     path=../megatestqa/someqa; targtrans=somefunc; areafilter=area-to-run
fullrun   path=tests/fullrun; 
# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run
#           the target translator can return: a/target OR (list/of targets/to apply/run) OR #f i.e. run nothing
# ext-tests path=ext-tests; targtrans=prefix-contour;
ext-tests path=ext-tests

[contours]
#     mode-patt/tag-expr
quick areas=ext-tests;    selector=/QUICKPATT
quick2 areafn=check-area; selector=/QUICKPATT
# quick areas=fullrun,ext-tests; selector=QUICKPATT/quick
# full  areas=fullrun,ext-tests; selector=MAXPATT/
# short areas=fullrun,ext-tests; selector=MAXPATT/
# all   areas=fullrun,ext-tests
# snazy selector=QUICKPATT/

[nopurpose]

>
>
|
|
|
|
<
<















|













1
2
3
4
5
6


7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

## commented out due to a bug in v1.6501 in mtutil
## [fields]
## a text
## b text
## c text


usercode    .mtutil.scm
areafilter  area-to-run
targtrans   generic-target-translator
runtrans    generic-runname-translator

[setup]
pktsdirs /tmp/mt_pkts /some/other/source

[areas]
#         path-to-area   map-target-script(future, optional)
# someqa     path=../megatestqa/someqa; targtrans=somefunc; areafilter=area-to-run
fullrun   path=tests/fullrun; 
# targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run
#           the target translator can return: a/target OR (list/of targets/to apply/run) OR #f i.e. run nothing
# ext-tests path=ext-tests; targtrans=prefix-contour;
ext       path=ext-tests

[contours]
#     mode-patt/tag-expr
quick areas=ext-tests;    selector=/QUICKPATT
quick2 areafn=check-area; selector=/QUICKPATT
# quick areas=fullrun,ext-tests; selector=QUICKPATT/quick
# full  areas=fullrun,ext-tests; selector=MAXPATT/
# short areas=fullrun,ext-tests; selector=MAXPATT/
# all   areas=fullrun,ext-tests
# snazy selector=QUICKPATT/

[nopurpose]

Modified megatest.scm from [2f99b20149] to [68be015aa0].

1986
1987
1988
1989
1990
1991
1992
1993


1994
1995
1996
1997
1998
1999
2000
(if (args:get-arg "-rebuild-db")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      (open-run-close patch-db #f)


      (set! *didsomething* #t)))

(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 







|
>
>







1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
(if (args:get-arg "-rebuild-db")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 
	    (exit 1)))
      ;; keep this one local
      ;; (open-run-close patch-db #f)
      (let ((dbstruct (db:setup #f areapath: *toppath*)))
        (common:cleanup-db dbstruct full: #t))
      (set! *didsomething* #t)))

(if (args:get-arg "-cleanup-db")
    (begin
      (if (not (launch:setup))
	  (begin
	    (debug:print 0 *default-log-port* "Failed to setup, exiting") 

Modified mtut.scm from [d0eb7f2c84] to [104c5d0ca1].

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
;; (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 regex-case
     (prefix dbi dbi:))
     ;;(prefix nanomsg nmsg:))

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))








|
|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
;; (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 regex-case
     (prefix dbi dbi:)
     (prefix nanomsg nmsg:))

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))

156
157
158
159
160
161
162


163
164
165
166
167
168
169

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
    ("-contour"         . c)
    ("-append-config"   . d)
    ("-state"           . e)
    ("-item-patt"       . i)
    ("-sync-to"         . k)







>
>







156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171

Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))

;; args and pkt key specs
;;
(define *arg-keys*
  ;; used keys
  ;;    a  - action
  '(
    ("-area"            . G) ;; maps to group
    ("-contour"         . c)
    ("-append-config"   . d)
    ("-state"           . e)
    ("-item-patt"       . i)
    ("-sync-to"         . k)
197
198
199
200
201
202
203
204

205
206
207
208
209
210
211
    ))

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


;; Card types:
;;
;; A action
;; U username (Unix)
;; D timestamp
;; T card type







|
>







199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
    ))

;; 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
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
(if (or (args:any? "-h" "help" "-help" "--help")
	(member *action* '("-h" "-help" "--help" "help")))
    (begin
      (print help)
      (exit 1)))

;;======================================================================


;; 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
;;
;; sched => force the run start time to be recorded as sched Unix
;; epoch. This aligns times properly for triggers in some cases.
;;


(define (command-line->pkt action args-alist sched-in #!key (extra-dat '()))
  (let* ((sched     (cond
		     ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
		     ((number? sched-in) sched-in)
		     (else     (current-seconds))))
	 (args-data (if args-alist
			(if (hash-table? args-alist) ;; seriously?
			    (hash-table->alist args-alist)
			    args-alist)
			(hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline
	 (alldat    (apply append (list 'T "cmd"
					'A action
					'U (current-user-name)
					'D sched)




                           extra-dat



			   (map (lambda (x)
				  (let* ((param (car x))
					 (value (cdr x))
					 (pmeta (assoc param *arg-keys*))    ;; translate the card key to a megatest switch or parameter
					 (smeta (assoc param *switch-keys*)) ;; first lookup the key in arg-keys or switch-keys
					 (meta  (if (or pmeta smeta)
						    (cdr (or pmeta smeta))   ;; found it?







>
>














>
>
|









|
|
|
|
>
>
>
>
|
>
>
>







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
(if (or (args:any? "-h" "help" "-help" "--help")
	(member *action* '("-h" "-help" "--help" "help")))
    (begin
      (print help)
      (exit 1)))

;;======================================================================


;; 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
;;
;; sched => force the run start time to be recorded as sched Unix
;; epoch. This aligns times properly for triggers in some cases.
;;
;;  extra-dat format is ( 'x xval 'y yval .... )
;;
(define (command-line->pkt action args-alist sched-in #!key (extra-dat '())(area-path #f))
  (let* ((sched     (cond
		     ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
		     ((number? sched-in) sched-in)
		     (else     (current-seconds))))
	 (args-data (if args-alist
			(if (hash-table? args-alist) ;; seriously?
			    (hash-table->alist args-alist)
			    args-alist)
			(hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline
	 (alldat    (apply append
			   (list 'A action
				 'U (current-user-name)
				 'D sched)
			   (if area-path
			       (list 'S area-path) ;; the area-path is mapped to the start-dir
			       '())
                           (if (list? extra-dat)
			       extra-dat
			       (begin
				 (debug:print 0 *default-log-port* "ERROR: command-line->pkt received bad extra-dat " extra-dat)
				 '()))
			   (map (lambda (x)
				  (let* ((param (car x))
					 (value (cdr x))
					 (pmeta (assoc param *arg-keys*))    ;; translate the card key to a megatest switch or parameter
					 (smeta (assoc param *switch-keys*)) ;; first lookup the key in arg-keys or switch-keys
					 (meta  (if (or pmeta smeta)
						    (cdr (or pmeta smeta))   ;; found it?
958
959
960
961
962
963
964




965
966
967






968
969
970
971
972
973
974
975
976
977
978
979
980
981
      (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))




	      (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 #f)))
	   (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 "scratchdat" "toppath")))
	 (case (string->symbol *action*)
	   ((process)  (begin







>
>
>
>



>
>
>
>
>
>






|







972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
      (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 (val->alist areasec) #f))
	      (area-path (if areadat (alist-ref 'path areadat) #f))
	      (pktsdirs  (configf:lookup mtconf "setup" "pktsdirs"))
	      (pktsdir   (if pktsdirs (car (string-split pktsdirs " ")) #f))
	      (adjargs   (hash-table-copy args:arg-hash)))
	 ;; check a few things
	 (if (and area
		  (not area-path))
	     (begin
	       (print "ERROR: the specified area was not found in the [areas] table. Area name=" area)
	       (exit 1)))
	 ;; (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 #f area-path: area-path)))
	   (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 "scratchdat" "toppath")))
	 (case (string->symbol *action*)
	   ((process)  (begin

Modified runconfigs.config from [e71c2b9c78] to [e2b75d4c3c].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# To get emacs font highlighing in the various megatest configs do this:
#
# Install emacs-goodies-el:
#    sudo apt install emacs-goodies-el
# Add to your ~/.emacs file:
#    (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode))
#

# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config
#
[a/b/c]
all:scheduled:sync          cron=  0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
#  quick:scheduled:sync        cron=  0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config
# fast:scheduled:sync-prepend cron=  0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config

[scriptinc ./gentargets.sh #{getenv USER}]
# [v1.23/45/67]

# tip will be replaced with hashkey?












|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# To get emacs font highlighing in the various megatest configs do this:
#
# Install emacs-goodies-el:
#    sudo apt install emacs-goodies-el
# Add to your ~/.emacs file:
#    (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode))
#

# example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config
#
[a/b/c]
all:scheduled:sync     cron=  0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config
# quick:scheduled:sync   cron=  0/5 * * * *;dbdest=pgdb;appendconf=/nfs/phoebe/disk1/home/mfs/matt/.sysmaint/local.config
# fast:scheduled:sync-prepend cron=  0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config

[scriptinc ./gentargets.sh #{getenv USER}]
# [v1.23/45/67]

# tip will be replaced with hashkey?

Modified utils/mk_wrapper from [1616e71ca3] to [3b78e9fde2].

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
  fi
fi
EOF

fi

cat >> $target << EOF 
if [[ \$(ulimit -a | grep 'open files' | awk '{print \$4}') -gt 5000 ]];then ulimit -n 5000;fi
EOF

# echo "#!/bin/bash" > $target
# echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target

echo "lsbr=\$(lsb_release -sr)" >> $target
if [ "$LD_LIBRARY_PATH" != "" ];then
  echo "source $prefix/bin/.\$lsbr/cfg.sh" >> $target
fi

# echo "if [[ -e \$lsbr ]];then source \$lsbr;fi" >> $target
echo "exec $prefix/bin/.\$lsbr/$cmd \"\$@\"" >> $target







|












51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
  fi
fi
EOF

fi

cat >> $target << EOF 
if [[ \$(ulimit -a | grep 'open files' | awk '{print \$4}') -gt 10000 ]];then ulimit -n 10000;fi
EOF

# echo "#!/bin/bash" > $target
# echo "exec $prefix/bin/.\$(lsb_release -sr)/$cmd \"\$@\"" >> $target

echo "lsbr=\$(lsb_release -sr)" >> $target
if [ "$LD_LIBRARY_PATH" != "" ];then
  echo "source $prefix/bin/.\$lsbr/cfg.sh" >> $target
fi

# echo "if [[ -e \$lsbr ]];then source \$lsbr;fi" >> $target
echo "exec $prefix/bin/.\$lsbr/$cmd \"\$@\"" >> $target