1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
|
(let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname")
(if (> (length dat) 1)
(cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname"
dat)))
(string-split fields-spec "+")))
(define (get-value-by-fieldname datavec test-field-index fieldname)
(let ((indx (hash-table-ref/default test-field-index fieldname #f)))
(if indx
(if (>= indx (vector-length datavec))
#f ;; index to high, should raise an error I suppose
(vector-ref datavec indx))
#f)))
;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
(args:get-arg "-list-db-targets"))
|
>
>
>
|
|
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
|
(let ((dat (string-split table-spec ":"))) ;; ("runs" "id,target,runname")
(if (> (length dat) 1)
(cons (car dat)(string-split (cadr dat) ",")) ;; "id,target,runname"
dat)))
(string-split fields-spec "+")))
(define (get-value-by-fieldname datavec test-field-index fieldname)
(if (db:test-rec? datavec)
(let ((test-rec-alist (db:test-rec->alist datavec)))
(alist-ref (string->symbol fieldname) test-rec-alist))
(let ((indx (hash-table-ref/default test-field-index fieldname #f)))
(if indx
(if (>= indx (vector-length datavec))
#f ;; index to high, should raise an error I suppose
(vector-ref datavec indx))
#f))))
;; NOTE: list-runs and list-db-targets operate on local db!!!
;;
;; IDEA: megatest list -runname blah% ...
;;
(if (or (args:get-arg "-list-runs")
(args:get-arg "-list-db-targets"))
|
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
|
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Bad data in test record? " test)
(print "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port)))
(let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
(testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
(itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
(comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test))
(tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test))
(tstatus (if (member "status" tests-spec)(get-value-by-fieldname test test-field-index "status" ) #f)) ;; (db:test-get-status test))
(event-time (if (member "event_time" tests-spec)(get-value-by-fieldname test test-field-index "event_time" ) #f)) ;; (db:test-get-event_time test))
(rundir (if (member "rundir" tests-spec)(get-value-by-fieldname test test-field-index "rundir" ) #f)) ;; (db:test-get-rundir test))
(final_logf (if (member "final_logf" tests-spec)(get-value-by-fieldname test test-field-index "final_logf" ) #f)) ;; (db:test-get-final_logf test))
(run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test))
(fullname (conc testname
(if (equal? itempath "")
""
(conc "(" itempath ")")))))
(case dmode
((json ods)
(if tests-spec
|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
|
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Bad data in test record? " test)
(print "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port)))
(let* (
(test-id (db:test-rec-id test))
(testname (db:test-rec-testname test))
(itempath (db:test-rec-item_path test))
(comment (db:test-rec-comment test))
(tstate (db:test-rec-state test))
(tstatus (db:test-rec-status test))
(event-time (db:test-rec-event_time test))
(rundir (db:test-rec-rundir test))
(final_logf (db:test-rec-final_logf test))
(run_duration (db:test-rec-run_duration test))
(fullname (db:test-rec-testname test))
;;(test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
;;(testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
;;(itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
;;(comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test))
;;(tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test))
;;(tstatus (if (member "status" tests-spec)(get-value-by-fieldname test test-field-index "status" ) #f)) ;; (db:test-get-status test))
;;(event-time (if (member "event_time" tests-spec)(get-value-by-fieldname test test-field-index "event_time" ) #f)) ;; (db:test-get-event_time test))
;;(rundir (if (member "rundir" tests-spec)(get-value-by-fieldname test test-field-index "rundir" ) #f)) ;; (db:test-get-rundir test))
;;(final_logf (if (member "final_logf" tests-spec)(get-value-by-fieldname test test-field-index "final_logf" ) #f)) ;; (db:test-get-final_logf test))
;;(run_duration (if (member "run_duration" tests-spec)(get-value-by-fieldname test test-field-index "run_duration") #f)) ;; (db:test-get-run_duration test))
(fullname (conc testname
(if (equal? itempath "")
""
(conc "(" itempath ")")))))
(case dmode
((json ods)
(if tests-spec
|