45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
typed-records
matchable
files)
(declare (unit db))
(declare (uses common))
(declare (uses dbmod))
;; (declare (uses debugprint))
(import dbmod)
(import dbfile)
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
(state #f)
(status #f)
|
|
|
|
>
|
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
typed-records
matchable
files)
(declare (unit db))
(declare (uses common))
(declare (uses dbmod))
(declare (uses debugprint))
(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
;; (declare (uses client))
(declare (uses mt))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
(define *number-of-writes* 0)
(define *number-non-write-queries* 0)
(import dbmod
dbfile
debugprint)
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
(state #f)
(status #f)
|
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
|
testname)
res))))
;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================
;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj #!key (transport 'http))
(case transport
;; ((fs) obj)
((http fs)
(string-substitute
(regexp "=") "_"
(base64:base64-encode
(z3:encode-buffer
(with-output-to-string
(lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
#t))
((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
(else obj))) ;; rpc
(define (db:string->obj msg #!key (transport 'http))
(case transport
;; ((fs) msg)
((http fs)
(if (string? msg)
(with-input-from-string
(z3:decode-buffer
(base64:base64-decode
(string-substitute
(regexp "_") "=" msg #t)))
(lambda ()(deserialize)))
(begin
(debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
(print-call-chain (current-error-port))
msg))) ;; crude reply for when things go awry
((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
(else msg))) ;; rpc
;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;; (let ((dbdat (db:get-subdb dbstruct run-id)))
;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; (db:general-call dbdat 'set-test-start-time (list test-id)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
|
testname)
res))))
;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================
;; ;; NOTE: Can remove the regex and base64 encoding for zmq
;; (define (db:obj->string obj #!key (transport 'http))
;; (case transport
;; ;; ((fs) obj)
;; ((http fs)
;; (string-substitute
;; (regexp "=") "_"
;; (base64:base64-encode
;; (z3:encode-buffer
;; (with-output-to-string
;; (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating. serialize is sensitive to binary image of mtest.
;; #t))
;; ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
;; (else obj))) ;; rpc
;;
;; (define (db:string->obj msg #!key (transport 'http))
;; (case transport
;; ;; ((fs) msg)
;; ((http fs)
;; (if (string? msg)
;; (with-input-from-string
;; (z3:decode-buffer
;; (base64:base64-decode
;; (string-substitute
;; (regexp "_") "=" msg #t)))
;; (lambda ()(deserialize)))
;; (begin
;; (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
;; (print-call-chain (current-error-port))
;; msg))) ;; crude reply for when things go awry
;; ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
;; (else msg))) ;; rpc
;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;; (let ((dbdat (db:get-subdb dbstruct run-id)))
;; (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; (db:general-call dbdat 'set-test-start-time (list test-id)))
|