Megatest

Check-in [34d675ae1f]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added some safety checks
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | defstruct-srehman
Files: files | file ages | folders
SHA1: 34d675ae1f0509e3f650dc4ee8c4b44f27038e2d
User & Date: mrwellan on 2016-10-04 11:34:37
Other Links: branch diff | manifest | tags
Context
2016-10-05
13:33
hardcoded qry-string to typed record check-in: 8ba591abbd user: srehman tags: defstruct-srehman
2016-10-04
11:34
Added some safety checks check-in: 34d675ae1f user: mrwellan tags: defstruct-srehman
2016-10-03
15:40
fixed db_records to account for modifications to test datatype update check-in: 8718070900 user: srehman tags: defstruct-srehman
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified api.scm from [d744d47aad] to [0846354bc1].

︙
115
116
117
118
119
120
121

122





123
124
125
126
127
128
129

115
116
117
118
119
120
121
122

123
124
125
126
127
128
129
130
131
132
133
134








+
-
+
+
+
+
+








       (vector #f #f "remote must be called with a vector")       
       (vector                                   ;; return a vector + the returned data structure
	#t 
	(let ((cmd    (vector-ref dat 0))
	      (params (vector-ref dat 1)))
	  (case (if (symbol? cmd)
		    cmd
		    (if (string? cmd)
		    (string->symbol cmd))
			(string->symbol cmd)
			(begin
			  (debug:print 0 *default-log-port* "ERROR: received bad data in execute-requests \"" cmd "\""
				       "   and params " params)
			  (exit 1))))

	    ;;===============================================
	    ;; READ/WRITE QUERIES
	    ;;===============================================

	    ;; SERVERS
	    ((start-server)                    (apply server:kind-run params))
︙

Modified db.scm from [6d3f9a01cd] to [2c5f13a26c].

︙
2888
2889
2890
2891
2892
2893
2894











2895
2896
2897
2898
2899

2900
2901
2902
2903
2904
2905
2906
2907
2908
2909

2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909

2910



2911
2912
2913
2914
2915
2916
2917








+
+
+
+
+
+
+
+
+
+
+




-
+
-
-
-








;; foo,bal,   1.2,  1.2, <   ,     ,Check for overload
;; foo,alb,   1.2,  1.2, <=  , Amps,This is the high power circuit test
;; foo,abl,   1.2,  1.3, 0.1
;; foo,bra,   1.2, pass, silly stuff
;; faz,bar,    10,  8mA,     ,     ,"this is a comment"
;; EOF


(define (db:csv->list-safe csvdata)
  (if (string? csvdata)
      (csv->list (make-csv-reader
		  (open-input-string csvdata)
		  '((strip-leading-whitespace? #t)
		    (strip-trailing-whitespace? #t))))      
      (begin
	(debug:print 0 *default-log-port* "ERROR: received non-string data for csv")
	'())))

(define (db:csv->test-data dbstruct run-id test-id csvdata)
  (debug:print 4 *default-log-port* "test-id " test-id ", csvdata: " csvdata)
  (let* ((dbdat   (db:get-db dbstruct run-id))
	 (db      (db:dbdat-get-db dbdat))
	 (csvlist (csv->list (make-csv-reader
	 (csvlist (db:csv->list-safe csvdata)))
			      (open-input-string csvdata)
			      '((strip-leading-whitespace? #t)
				(strip-trailing-whitespace? #t)))))) ;; (csv->list csvdata)))
    (for-each
     (lambda (csvrow)
       (let* ((padded-row  (take (append csvrow (list #f #f #f #f #f #f #f #f #f)) 9))
	      (category    (list-ref padded-row 0))
	      (variable    (list-ref padded-row 1))
	      (value       (any->number-if-possible (list-ref padded-row 2)))
	      (expected    (any->number-if-possible (list-ref padded-row 3)))
︙

Modified db_records.scm from [760ea62c74] to [6e4d1adc75].

︙
65
66
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
96
97
98
99
100
101
102
103
104
105
106
107
108













109
110
111
112
113
114
115

65
66
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111








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

-
-
-
-

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








  (hash-table-ref/default (dbr:dbstruct-locdbs v) run-id #f))

(define (dbr:dbstruct-localdb-set! v run-id db)
  (hash-table-set! (dbr:dbstruct-locdbs v) run-id db))

(require-extension typed-records)
(defstruct db:test-rec ((id -1) : number)
					((run_id -1) : number) 
					((testname "") : string)
					((state "") : string)
					((status "") : string)
					((event_time -1) : number)
					((host "") : string)
					((cpuload -1) : number)
					((diskfree -1) : number)
					((uname "") : string)
					((rundir "") : string)
					((item_path "") : string)
					((run_duration -1) : number)
					((final_logf "") : string)
					((comment "") : string)
					((process-id -1) : number)
					((archived -1) : number)
					((shortdir -1) : number)
					((attemptnum -1) : number))
  ((run_id -1) : number) 
  ((testname "") : string)
  ((state "") : string)
  ((status "") : string)
  ((event_time -1) : number)
  ((host "") : string)
  ((cpuload -1) : number)
  ((diskfree -1) : number)
  ((uname "") : string)
  ((rundir "") : string)
  ((item_path "") : string)
  ((run_duration -1) : number)
  ((final_logf "") : string)
  ((comment "") : string)
  ((process-id -1) : number)
  ((archived -1) : number)
  ((shortdir -1) : number)
  ((attemptnum -1) : number))

"id"           "run_id"        "testname"  "state"      "status"      "event_time"
				"host"         "cpuload"       "diskfree"  "uname"      "rundir"      "item_path"
                                "run_duration" "final_logf"    "comment"   "shortdir"   "attemptnum"  "archived"

(define (db:qry-gen-alist qrystr listvals)
	(define listqry (string-split qrystr ","))
	(if (null? listqry)
	      '()
	      (let loop ((strhead (car listqry))
			 (strtail (cdr listqry))
			 (valhead (car listvals))
			 (valtail (cdr listvals))
			 (res '()))
		(let* ((slot-val-pair (cons (string->symbol strhead) valhead)))
		  (if (or (null? strtail)
		  		(null? valtail))
		      (cons slot-val-pair res);;(print strhead valhead));;(cons (cons (string->symbol strhead) valhead) res))
		      (loop (car strtail)(cdr strtail)(car valtail)(cdr valtail)(cons slot-val-pair res)))))))
  (define listqry (string-split qrystr ","))
  (if (null? listqry)
      '()
      (let loop ((strhead (car listqry))
		 (strtail (cdr listqry))
		 (valhead (car listvals))
		 (valtail (cdr listvals))
		 (res '()))
	(let* ((slot-val-pair (cons (string->symbol strhead) valhead)))
	  (if (or (null? strtail)
		  (null? valtail))
	      (cons slot-val-pair res);;(print strhead valhead));;(cons (cons (string->symbol strhead) valhead) res))
	      (loop (car strtail)(cdr strtail)(car valtail)(cdr valtail)(cons slot-val-pair res)))))))

(define (db:test-get-id			typed-rec)   (db:test-rec-id 		typed-rec))
(define (db:test-get-run_id 	typed-rec)	 (db:test-rec-run_id 	typed-rec))
(define (db:test-get-testname   typed-rec)   (db:test-rec-testname typed-rec))
(define (db:test-get-state      typed-rec)   (db:test-rec-state 	typed-rec))
(define (db:test-get-status     typed-rec)   (db:test-rec-status 	typed-rec))
(define (db:test-get-event_time typed-rec)   (db:test-rec-event_time typed-rec))
︙

Modified tests/fullrun/megatest.config from [73b1295a6b] to [a2007aff6f].

︙
146
147
148
149
150
151
152
153

154
155
156
157
158
159
160

146
147
148
149
150
151
152

153
154
155
156
157
158
159
160








-
+









# XTERM   [system xterm]
# RUNDEAD [system exit 56]

[server]

# force use of server always
# required yes
required yes

# Use http instead of direct filesystem access
transport http
# transport fs
# transport nmsg

synchronous 0
︙

This page was generated in about 0.149s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00