Megatest

Check-in [405e0970e6]
Login
Overview
Comment:Fixed debug issue on invalid debug setting. Fixed show-config bug. Added -start-dir
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.55 | v1.5515
Files: files | file ages | folders
SHA1: 405e0970e62177d85b3b3aa2e739a4eb75d5e2f4
User & Date: mrwellan on 2014-02-24 14:42:32
Other Links: branch diff | manifest | tags
Context
2014-02-25
09:35
Back-ported improvement to -debug check-in: 2b94cc24b4 user: mrwellan tags: v1.55, v1.5515
2014-02-24
23:17
Merged in last few changes to v1.55 check-in: c5c6fa7396 user: matt tags: v1.60
14:42
Fixed debug issue on invalid debug setting. Fixed show-config bug. Added -start-dir check-in: 405e0970e6 user: mrwellan tags: v1.55, v1.5515
2014-02-21
13:45
Added ability to add message to -set-run-status check-in: 998265e2aa user: mrwellan tags: v1.55, v1.5515
Changes

Modified common_records.scm from [7793eb36cc] to [d56a2bbf0b].

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
36
37
38
39
40
41
42


43
44
45
46
47
48
49
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
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54










+
+



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








-
+














+
+







;;======================================================================
;; Copyright 2006-2012, 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.
;;======================================================================

(use trace)

(define (debug:calc-verbosity vstr)
  (cond
   (vstr
    (let ((debugvals (string-split vstr ",")))
      (if (> (length debugvals) 1)
	  (map string->number debugvals)
	  (string->number (car debugvals)))))
   ((args:get-arg "-v")    2)
   ((string-match "^\\s*$" vstr) #f)
   (vstr (let ((debugvals (string-split vstr ",")))
	   (cond
	    ((> (length debugvals) 1)(map string->number debugvals))
	    ((> (length debugvals) 0)(string->number (car debugvals)))
	    (else #f))))
    ((args:get-arg "-v")   2)
   ((args:get-arg "-q")    0)
   (else                   1)))

;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
	       (list?   verbosity)))
      (begin
	(print "ERROR: Invalid debug value " vstr)
	(print "ERROR: Invalid debug value \"" vstr "\"")
	#f)
      #t))

(define (debug:debug-mode n)
  (or (and (number? *verbosity*)
	   (<= n *verbosity*))
      (and (list? *verbosity*)
	   (member n *verbosity*))))

(define (debug:setup)
  (let ((debugstr (or (args:get-arg "-debug")
		      (getenv "MT_DEBUG_MODE"))))
    (set! *verbosity* (debug:calc-verbosity debugstr))
    (debug:check-verbosity *verbosity* debugstr)
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (not *verbosity*)(set! *verbosity* 1))
    (if (or (args:get-arg "-debug")
	    (not (getenv "MT_DEBUG_MODE")))
	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
				    (string-intersperse (map conc *verbosity*) ",")
				    (conc *verbosity*))))))
  

Modified megatest.scm from [0866bc0857] to [094dda6a97].

1
2
3
4
5
6
7
8
9
10
11
12
13

14
15
16
17
18
19
20
1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16
17
18
19
20












-
+







;; Copyright 2006-2012, 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")

(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client) ;; (srfi 18) extras)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos json http-client directory-utils) ;; (srfi 18) extras)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

;; (use zmq)

(declare (uses common))
(declare (uses megatest-version))
108
109
110
111
112
113
114

115
116
117
118
119
120
121
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122







+







  -list-db-targets        : list the target combinations used in the db
  -show-config            : dump the internal representation of the megatest.config file
  -show-runconfig         : dump the internal representation of the runconfigs.config file
  -dumpmode json          : dump in json format instead of sexpr
  -show-cmdinfo           : dump the command info for a test (run in test environment)

Misc 
  -start-dir path         : switch to this directory before running megatest
  -rebuild-db             : bring the database schema up to date
  -cleanup-db             : remove any orphan records, vacuum the db
  -update-meta            : update the tests metadata for all tests
  -env2file fname         : write the environment to fname.csh and fname.sh
  -setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
                                 overwritten by values set in config files.
  -server -|hostname      : start the server (reduces contention on megatest.db), use
182
183
184
185
186
187
188

189
190
191
192
193
194
195
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197







+







			":category"
			":variable"
			":value"
			":expected"
			":tol"
			":units"
			;; misc
			"-start-dir"
			"-server"
			"-transport"
			"-stop-server"
			"-port"
			"-extract-ods"
			"-pathmod"
			"-env2file"
251
252
253
254
255
256
257







258
259
260
261
262
263
264
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273







+
+
+
+
+
+
+







		 args:arg-hash
		 0))

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

(if (args:get-arg "-start-dir")
    (if (file-exists? (args:get-arg "-start-dir"))
	(change-directory (args:get-arg "-start-dir"))
	(begin
	  (debug:print 0 "ERROR: non-existant start dir " (args:get-arg "-start-dir") " specified, exiting.")
	  (exit 1))))

(if (args:get-arg "-version")
    (begin
      (print megatest-version)
      (exit)))

(define *didsomething* #f)