Deleted emergency-patches/emergency-patch-1.scm version [078bae8dfb].
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
55
56
57
58
59
60
61
62
63
64
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; These are called by the server on recipt of /api calls
;; - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;; - returns #( flag result )
;;
(define (api:execute-requests dbstruct dat)
(handle-exceptions
exn
(let ((call-chain (get-call-chain)))
(debug:print 0 *default-log-port* "WARNING: api:execute-requests received an exception from peer, dat=" dat)
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens
(cond
((not (vector? dat)) ;; it is an error to not receive a vector
(vector #f (vector #f "remote must be called with a vector")))
((> *api-process-request-count* 20) ;; 20)
(debug:print 0 *default-log-port* "WARNING: api:execute-requests received an overloaded message.")
(set! *server-overloaded* #t)
(vector #f (vector #f 'overloaded))) ;; the inner vector is what gets returned. nope, don't know why. please refactor!
(else
(let* ((cmd-in (vector-ref dat 0))
(cmd (if (symbol? cmd-in)
cmd-in
(string->symbol cmd-in)))
(params (vector-ref dat 1))
(start-t (current-milliseconds))
(readonly-mode (dbr:dbstruct-read-only dbstruct))
(readonly-command (member cmd api:read-only-queries))
(writecmd-in-readonly-mode (and readonly-mode (not readonly-command)))
(res
(if writecmd-in-readonly-mode
(conc "attempt to run write command "cmd" on a read-only database")
(case cmd
;;===============================================
;; READ/WRITE QUERIES
;;===============================================
((get-keys-write) (db:get-keys dbstruct)) ;; force a dummy "write" query to force server; for debug in -repl
;; SERVERS
((start-server) (apply server:kind-run params))
((kill-server) (set! *server-run* #f))
;; TESTS
;;((test-set-state-status-by-id) (apply mt:test-set-state-status-by-id dbstruct params))
;;BB - commented out above because it was calling below, eventually, incorrectly (dbstruct passed to mt:test-set-state-status-by-id, which previosly did more, but now only passes thru to db:set-state-status-and-roll-up-items.
((test-set-state-status-by-id)
;; (define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
(db:set-state-status-and-roll-up-items
dbstruct
(list-ref params 0) ; run-id
(list-ref params 1) ; test-name
#f ; item-path
(list-ref params 2) ; state
(list-ref params 3) ; status
(list-ref params 4) ; comment
))
((delete-test-records) (apply db:delete-test-records dbstruct params))
((delete-old-deleted-test-records) (apply db:delete-old-deleted-test-records dbstruct params))
((test-set-state-status) (apply db:test-set-state-status dbstruct params))
((test-set-top-process-pid) (apply db:test-set-top-process-pid dbstruct params))
((set-state-status-and-roll-up-items) (apply db:set-state-status-and-roll-up-items dbstruct params))
((top-test-set-per-pf-counts) (apply db:top-test-set-per-pf-counts dbstruct params))
((test-set-archive-block-id) (apply db:test-set-archive-block-id dbstruct params))
;; RUNS
((register-run) (apply db:register-run dbstruct params))
((set-tests-state-status) (apply db:set-tests-state-status dbstruct params))
((delete-run) (apply db:delete-run dbstruct params))
((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
((update-run-event_time) (apply db:update-run-event_time dbstruct params))
((update-run-stats) (apply db:update-run-stats dbstruct params))
((set-var) (apply db:set-var dbstruct params))
((del-var) (apply db:del-var dbstruct params))
;; STEPS
((teststep-set-status!) (apply db:teststep-set-status! dbstruct params))
;; TEST DATA
((test-data-rollup) (apply db:test-data-rollup dbstruct params))
((csv->test-data) (apply db:csv->test-data dbstruct params))
;; MISC
((sync-inmem->db) (let ((run-id (car params)))
(db:sync-touched dbstruct run-id force-sync: #t)))
((mark-incomplete) (apply db:find-and-mark-incomplete dbstruct params))
;; TESTMETA
((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
((get-tests-tags) (db:get-tests-tags dbstruct))
;; TASKS
((tasks-add) (apply tasks:add dbstruct params))
((tasks-set-state-given-param-key) (apply tasks:set-state-given-param-key dbstruct params))
((tasks-get-last) (apply tasks:get-last dbstruct params))
;; NO SYNC DB
((no-sync-set) (apply db:no-sync-set *no-sync-db* params))
((no-sync-get/default) (apply db:no-sync-get/default *no-sync-db* params))
((no-sync-del!) (apply db:no-sync-del! *no-sync-db* params))
;; ARCHIVES
;; ((archive-get-allocations)
((archive-register-disk) (apply db:archive-register-disk dbstruct params))
((archive-register-block-name)(apply db:archive-register-block-name dbstruct params))
((archive-allocate-testsuite/area-to-block)(apply db:archive-allocate-testsuite/area-to-block dbstruct block-id testsuite-name areakey))
;;======================================================================
;; READ ONLY QUERIES
;;======================================================================
;; KEYS
((get-key-val-pairs) (apply db:get-key-val-pairs dbstruct params))
((get-keys) (db:get-keys dbstruct))
((get-key-vals) (apply db:get-key-vals dbstruct params))
((get-target) (apply db:get-target dbstruct params))
((get-targets) (db:get-targets dbstruct))
;; ARCHIVES
((test-get-archive-block-info) (apply db:test-get-archive-block-info dbstruct params))
;; TESTS
((test-toplevel-num-items) (apply db:test-toplevel-num-items dbstruct params))
((get-test-info-by-id) (apply db:get-test-info-by-id dbstruct params))
((test-get-rundir-from-test-id) (apply db:test-get-rundir-from-test-id dbstruct params))
((get-count-tests-running-for-testname) (apply db:get-count-tests-running-for-testname dbstruct params))
((get-count-tests-running) (apply db:get-count-tests-running dbstruct params))
((get-count-tests-running-in-jobgroup) (apply db:get-count-tests-running-in-jobgroup dbstruct params))
;; ((delete-test-step-records) (apply db:delete-test-step-records dbstruct params))
((get-previous-test-run-record) (apply db:get-previous-test-run-record dbstruct params))
((get-matching-previous-test-run-records)(apply db:get-matching-previous-test-run-records dbstruct params))
((test-get-logfile-info) (apply db:test-get-logfile-info dbstruct params))
((test-get-records-for-index-file) (apply db:test-get-records-for-index-file dbstruct params))
((get-testinfo-state-status) (apply db:get-testinfo-state-status dbstruct params))
((test-get-top-process-pid) (apply db:test-get-top-process-pid dbstruct params))
((test-get-paths-matching-keynames-target-new) (apply db:test-get-paths-matching-keynames-target-new dbstruct params))
((get-prereqs-not-met) (apply db:get-prereqs-not-met dbstruct params))
((get-count-tests-running-for-run-id) (apply db:get-count-tests-running-for-run-id dbstruct params))
((synchash-get) (apply synchash:server-get dbstruct params))
((get-raw-run-stats) (apply db:get-raw-run-stats dbstruct params))
;; RUNS
((get-run-info) (apply db:get-run-info dbstruct params))
((get-run-status) (apply db:get-run-status dbstruct params))
((set-run-status) (apply db:set-run-status dbstruct params))
((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
((get-test-id) (apply db:get-test-id dbstruct params))
((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
((get-runs) (apply db:get-runs dbstruct params))
((get-num-runs) (apply db:get-num-runs dbstruct params))
((get-all-run-ids) (db:get-all-run-ids dbstruct))
((get-prev-run-ids) (apply db:get-prev-run-ids dbstruct params))
((get-run-ids-matching-target) (apply db:get-run-ids-matching-target dbstruct params))
((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params))
((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
((get-main-run-stats) (apply db:get-main-run-stats dbstruct params))
((get-var) (apply db:get-var dbstruct params))
((get-run-stats) (apply db:get-run-stats dbstruct params))
;; STEPS
((get-steps-data) (apply db:get-steps-data dbstruct params))
((get-steps-for-test) (apply db:get-steps-for-test dbstruct params))
;; TEST DATA
((read-test-data) (apply db:read-test-data dbstruct params))
((read-test-data*) (apply db:read-test-data* dbstruct params))
;; MISC
((get-latest-host-load) (apply db:get-latest-host-load dbstruct params))
((have-incompletes?) (apply db:have-incompletes? dbstruct params))
((login) (apply db:login dbstruct params))
((general-call) (let ((stmtname (car params))
(run-id (cadr params))
(realparams (cddr params)))
(db:general-call dbstruct stmtname realparams)))
((sdb-qry) (apply sdb:qry params))
((ping) (current-process-id))
((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params))
;; TESTMETA
((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
;; TASKS
((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params))
(else
(debug:print 0 *default-log-port* "ERROR: bad api call " cmd)
(conc "ERROR: BAD api call " cmd))))))
;; save all stats
(let ((delta-t (- (current-milliseconds)
start-t)))
(hash-table-set! *db-api-call-time* cmd
(cons delta-t (hash-table-ref/default *db-api-call-time* cmd '()))))
(if writecmd-in-readonly-mode
(vector #f res)
(vector #t res)))))))
|
Deleted emergency-patches/emergency-patch-2.scm version [2347b68fd3].
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
55
56
57
58
59
60
61
62
63
64
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
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
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000) (msg #f)(remote-host #f))
(let* ((loadavg (common:get-cpu-load remote-host))
(first (car loadavg))
(next (cadr loadavg))
(adjload (* maxload numcpus))
(loadjmp (- first next)))
(cond
((and (> first adjload)
(> count 0))
(debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload " " (if msg msg ""))
(thread-sleep! waitdelay)
(common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))
((and (> loadjmp numcpus)
(> count 0))
(debug:print-info 0 *default-log-port* "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus (if msg msg ""))
(thread-sleep! waitdelay)
(common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))))))
(define (common:wait-for-homehost-load maxload msg)
(let* ((hh-dat (if (common:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
#f
(common:get-homehost)))
(hh (if hh-dat (car hh-dat) #f))
(numcpus (common:get-num-cpus hh)))
(common:wait-for-normalized-load maxload msg: msg remote-host: hh)))
;; wait for normalized cpu load to drop below maxload
;;
(define (common:wait-for-normalized-load maxload #!key (msg #f)(remote-host #f))
(let ((num-cpus (common:get-num-cpus remote-host)))
(common:wait-for-cpuload maxload num-cpus 15 msg: msg remote-host: remote-host)))
;; hed tal reg reruns reglen regfull test-record runname test-name item-path jobgroup max-concurrent-jobs run-id waitons item-path testmode test-patts required-tests test-registry registry-mutex flags keyvals run-info newtal all-tests-registry itemmaps)
(define (runs:process-expanded-tests runsdat testdat)
;; unroll the contents of runsdat and testdat (due to ongoing refactoring).
(let* ((hed (runs:testdat-hed testdat))
(tal (runs:testdat-tal testdat))
(reg (runs:testdat-reg testdat))
(reruns (runs:testdat-reruns testdat))
(test-name (runs:testdat-test-name testdat))
(item-path (runs:testdat-item-path testdat))
(jobgroup (runs:testdat-jobgroup testdat))
(waitons (runs:testdat-waitons testdat))
(item-path (runs:testdat-item-path testdat))
(testmode (runs:testdat-testmode testdat))
(newtal (runs:testdat-newtal testdat))
(itemmaps (runs:testdat-itemmaps testdat))
(test-record (runs:testdat-test-record testdat))
(prereqs-not-met (runs:testdat-prereqs-not-met testdat))
(reglen (runs:dat-reglen runsdat))
(regfull (runs:dat-regfull runsdat))
(runname (runs:dat-runname runsdat))
(max-concurrent-jobs (runs:dat-max-concurrent-jobs runsdat))
(run-id (runs:dat-run-id runsdat))
(test-patts (runs:dat-test-patts runsdat))
(required-tests (runs:dat-required-tests runsdat))
(test-registry (runs:dat-test-registry runsdat))
(registry-mutex (runs:dat-registry-mutex runsdat))
(flags (runs:dat-flags runsdat))
(keyvals (runs:dat-keyvals runsdat))
(run-info (runs:dat-run-info runsdat))
(all-tests-registry (runs:dat-all-tests-registry runsdat))
(run-limits-info (runs:dat-can-run-more-tests runsdat))
;; (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
(have-resources (car run-limits-info))
(num-running (list-ref run-limits-info 1))
(num-running-in-jobgroup(list-ref run-limits-info 2))
(max-concurrent-jobs (list-ref run-limits-info 3))
(job-group-limit (list-ref run-limits-info 4))
;; (prereqs-not-met (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))
;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
(fails (if (list? prereqs-not-met)
(runs:calc-fails prereqs-not-met)
(begin
(debug:print-error 0 *default-log-port* "prereqs-not-met is not a list! " prereqs-not-met)
'())))
(non-completed (filter (lambda (x) ;; remove hed from not completed list, duh, of course it is not completed!
(not (equal? x hed)))
(runs:calc-not-completed prereqs-not-met)))
(loop-list (list hed tal reg reruns))
;; configure the load runner
(numcpus (common:get-num-cpus #f))
(maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3.0"))) ;; use a non-number string to disable
(maxhomehostload (string->number (or (configf:lookup *configdat* "jobtools" "maxhomehostload") "1.2"))) ;; use a non-number string to disable
(waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60"))))
(debug:print-info 4 *default-log-port* "have-resources: " have-resources " prereqs-not-met: ("
(string-intersperse
(map (lambda (t)
(if (vector? t)
(conc (db:test-get-state t) "/" (db:test-get-status t))
(conc " WARNING: t is not a vector=" t )))
prereqs-not-met)
", ") ") fails: " fails
"\nregistered? " (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
(if (and (not (null? prereqs-not-met))
(runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60))
(debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", ")))
;; Don't know at this time if the test have been launched at some time in the past
;; i.e. is this a re-launch?
(debug:print-info 4 *default-log-port* "run-limits-info = " run-limits-info)
(cond
;; Check item path against item-patts,
;;
((not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests)) ;; This test/itempath is not to be run
;; else the run is stuck, temporarily or permanently
;; but should check if it is due to lack of resources vs. prerequisites
(debug:print-info 1 *default-log-port* "Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " test-patts)
(if (or (not (null? tal))(not (null? reg)))
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
reruns)
#f))
;; Register tests
;;
((not (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f))
(debug:print-info 4 *default-log-port* "Pre-registering test " test-name "/" item-path " to create placeholder" )
;; always do firm registration now in v1.60 and greater ;; (eq? *transport-type* 'fs) ;; no point in parallel registration if use fs
(let register-loop ((numtries 15))
(rmt:register-test run-id test-name item-path)
(if (rmt:get-test-id run-id test-name item-path)
(hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'done)
(if (> numtries 0)
(begin
(thread-sleep! 0.5)
(register-loop (- numtries 1)))
(debug:print-error 0 *default-log-port* "failed to register test " (db:test-make-full-name test-name item-path)))))
(if (not (eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name "") #f) 'done))
(begin
(rmt:register-test run-id test-name "")
(if (rmt:get-test-id run-id test-name "")
(hash-table-set! test-registry (db:test-make-full-name test-name "") 'done))))
(runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
(if (and (null? tal)(null? reg))
(list hed tal (append reg (list hed)) reruns)
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
;; NB// Here we are building reg as we register tests
;; if regfull we must pop the front item off reg
(if regfull
(append (cdr reg) (list hed))
(append reg (list hed)))
reruns)))
;; At this point hed test registration must be completed.
;;
((eq? (hash-table-ref/default test-registry (db:test-make-full-name test-name item-path) #f)
'start)
(debug:print-info 0 *default-log-port* "Waiting on test registration(s): "
(string-intersperse
(filter (lambda (x)
(eq? (hash-table-ref/default test-registry x #f) 'start))
(hash-table-keys test-registry))
", "))
(thread-sleep! 0.051)
(list hed tal reg reruns))
;; If no resources are available just kill time and loop again
;;
((not have-resources) ;; simply try again after waiting a second
(if (runs:lownoise "no resources" 60)
(debug:print-info 1 *default-log-port* "no resources to run new tests, waiting ..."))
;; Have gone back and forth on this but db starvation is an issue.
;; wait one second before looking again to run jobs.
(thread-sleep! 1)
;; could have done hed tal here but doing car/cdr of newtal to rotate tests
(list (car newtal)(cdr newtal) reg reruns))
;; This is the final stage, everything is in place so launch the test
;;
((and have-resources
(or (null? prereqs-not-met)
(and (member 'toplevel testmode) ;; 'toplevel)
(null? non-completed)
(not (member 'exclusive testmode)))))
;; (hash-table-delete! *max-tries-hash* (db:test-make-full-name test-name item-path))
;; we are going to reset all the counters for test retries by setting a new hash table
;; this means they will increment only when nothing can be run
(set! *max-tries-hash* (make-hash-table))
;; well, first lets see if cpu load throttling is enabled. If so wait around until the
;; average cpu load is under the threshold before continuing
(if maxload ;; only gate if maxload is specified
(common:wait-for-cpuload maxload numcpus waitdelay))
(if maxhomehostload
(common:wait-for-homehost-load maxhomehostload (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload)))
(run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
(runs:incremental-print-results run-id)
(hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'running)
(runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
(if (or (not (null? tal))(not (null? reg)))
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
reruns)
#f))
;; must be we have unmet prerequisites
;;
(else
(debug:print 4 *default-log-port* "FAILS: " fails)
;; If one or more of the prereqs-not-met are FAIL then we can issue
;; a message and drop hed from the items to be processed.
;; (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met)
(if (and (not (null? prereqs-not-met))
(runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60))
(debug:print-info 1 *default-log-port* "waiting on tests; " (string-intersperse
(runs:mixed-list-testname-and-testrec->list-of-strings
prereqs-not-met) ", ")))
(if (or (null? fails)
(member 'toplevel testmode))
(begin
;; couldn't run, take a breather
(if (runs:lownoise "Waiting for more work to do..." 60)
(debug:print-info 0 *default-log-port* "Waiting for more work to do..."))
(thread-sleep! 1)
(list (car newtal)(cdr newtal) reg reruns))
;; the waiton is FAIL so no point in trying to run hed ever again
(if (or (not (null? reg))(not (null? tal)))
(if (vector? hed)
(begin
(debug:print 1 *default-log-port* "WARNING: Dropping test " test-name "/" item-path
" from the launch list as it has prerequistes that are FAIL")
(let ((test-id (rmt:get-test-id run-id hed "")))
(if test-id (mt:test-set-state-status-by-id run-id test-id "NOT_STARTED" "PREQ_FAIL" "Failed to run due to failed prerequisites")))
(runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
;; This next is for the items
(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "BLOCKED" #f)
(hash-table-set! test-registry (db:test-make-full-name test-name item-path) 'removed)
(list (runs:queue-next-hed tal reg reglen regfull)
(runs:queue-next-tal tal reg reglen regfull)
(runs:queue-next-reg tal reg reglen regfull)
reruns ;; WAS: (cons hed reruns) ;; but that makes no sense?
))
(let ((nth-try (hash-table-ref/default test-registry hed 0)))
(cond
((member "RUNNING" (map db:test-get-state prereqs-not-met))
(if (runs:lownoise (conc "possible RUNNING prerequistes " hed) 60)
(debug:print 0 *default-log-port* "WARNING: test " hed " has possible RUNNING prerequisites, don't give up on it yet."))
(thread-sleep! 4)
(list (runs:queue-next-hed newtal reg reglen regfull)
(runs:queue-next-tal newtal reg reglen regfull)
(runs:queue-next-reg newtal reg reglen regfull)
reruns))
((or (not nth-try)
(and (number? nth-try)
(< nth-try 10)))
(hash-table-set! test-registry hed (if (number? nth-try)
(+ nth-try 1)
0))
(if (runs:lownoise (conc "not removing test " hed) 60)
(debug:print 1 *default-log-port* "WARNING: not removing test " hed " from queue although it may not be runnable due to FAILED prerequisites"))
;; may not have processed correctly. Could be a race condition in your test implementation? Dropping test " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
(runs:shrink-can-run-more-tests-count runsdat) ;; DELAY TWEAKER (still needed?)
;; (list hed tal reg reruns)
;; (list (car newtal)(cdr newtal) reg reruns)
;; (hash-table-set! test-registry hed 'removed)
(list (runs:queue-next-hed newtal reg reglen regfull)
(runs:queue-next-tal newtal reg reglen regfull)
(runs:queue-next-reg newtal reg reglen regfull)
reruns))
((symbol? nth-try)
(if (eq? nth-try 'removed) ;; removed is removed - drop it NOW
(if (null? tal)
#f ;; yes, really
(list (car tal)(cdr tal) reg reruns))
(begin
(if (runs:lownoise (conc "FAILED prerequisites or other issue" hed) 60)
(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequisites or other issue. Internal state " nth-try " will be overridden and we'll retry."))
(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "KEEP_TRYING" #f)
(hash-table-set! test-registry hed 0)
(list (runs:queue-next-hed newtal reg reglen regfull)
(runs:queue-next-tal newtal reg reglen regfull)
(runs:queue-next-reg newtal reg reglen regfull)
reruns))))
(else
(if (runs:lownoise (conc "FAILED prerequitests and we tried" hed) 60)
(debug:print 0 *default-log-port* "WARNING: test " hed " has FAILED prerequitests and we've tried at least 10 times to run it. Giving up now."))
;; (debug:print 0 *default-log-port* " prereqs: " prereqs-not-met)
(hash-table-set! test-registry hed 'removed)
(mt:test-set-state-status-by-testname run-id test-name item-path "NOT_STARTED" "TEN_STRIKES" #f)
;; I'm unclear on if this roll up is needed - it may be the root cause of the "all set to FAIL" bug.
(rmt:set-state-status-and-roll-up-items run-id test-name item-path #f "FAIL" #f) ;; treat as FAIL
(list (if (null? tal)(car newtal)(car tal))
tal
reg
reruns)))))
;; can't drop this - maybe running? Just keep trying
(let ((runable-tests (runs:runable-tests prereqs-not-met)))
(if (null? runable-tests)
#f ;; I think we are truly done here
(list (runs:queue-next-hed newtal reg reglen regfull)
(runs:queue-next-tal newtal reg reglen regfull)
(runs:queue-next-reg newtal reg reglen regfull)
reruns)))))))))
|
Deleted emergency-patches/emergency-patch-3.scm version [73e5520573].
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
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; To build patch:
;;;;;;;;;;;;;;;;;;;;;;;;;
;; ldd /p/foundry/env/pkgs/megatest/1.64/19/bin/.11/mtest
;; linux-vdso.so.1 => (0x00002aaaaaaab000)
;; libchicken.so.7 => /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0//lib/libchicken.so.7 (0x00002aaaaaaad000)
;; libm.so.6 => /lib64/libm.so.6 (0x00002aaaab0a6000)
;; libdl.so.2 => /lib64/libdl.so.2 (0x00002aaaab31f000)
;; libc.so.6 => /lib64/libc.so.6 (0x00002aaaab523000)
;; /lib64/ld-linux-x86-64.so.2 (0x0000555555554000)
;;
;; /p/foundry/env/pkgs/megatest/1.64/chicken-4.10.0/bin/csc -s emergency-patch-3.scm
;;
;; to test patch:
;;;;;;;;;;;;;;;;;;;;;;;;;
;; in .megatestrc, add:
;; (if (and (> megatest-version 1.64)
;; (< megatest-version 1.6421))
;; (begin
;; (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-1.so")
;; (load "/p/foundry/env/pkgs/megatest/1.64/19/share/epatch-2.so")))
;;
;; to productize patch:
;;;;;;;;;;;;;;;;;;;;;;;;;
;;
(use directory-utils regex)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
;; Given a run id start a server process ### NOTE ### > file 2>&1
;; if the run-id is zero and the target-host is set
;; try running on that host
;; incidental: rotate logs in logs/ dir.
;;
(define (server:run areapath) ;; areapath is *toppath* for a given testsuite area
(let* ((curr-host (get-host-name))
;; (attempt-in-progress (server:start-attempted? areapath))
;; (dot-server-url (server:check-if-running areapath))
(curr-ip (server:get-best-guess-address curr-host))
(curr-pid (current-process-id))
(homehost (common:get-homehost)) ;; configf:lookup *configdat* "server" "homehost" ))
(target-host (car homehost))
(testsuite (common:get-testsuite-name))
(logfile (conc areapath "/logs/server.log")) ;; -" curr-pid "-" target-host ".log"))
(cmdln (conc (common:get-megatest-exe)
" -server " (or target-host "-") (if (equal? (configf:lookup *configdat* "server" "daemonize") "yes")
" -daemonize "
"")
;; " -log " logfile
" -m testsuite:" testsuite)) ;; (conc " >> " logfile " 2>&1 &")))))
(log-rotate (make-thread common:rotate-logs "server run, rotate logs thread"))
(load-limit (configf:lookup-number *configdat* "server" "load-limit" default: 0.9)))
;; we want the remote server to start in *toppath* so push there
(push-directory areapath)
(debug:print 0 *default-log-port* "INFO: Trying to start server (" cmdln ") ...")
(thread-start! log-rotate)
;; host.domain.tld match host?
(if (and target-host
;; look at target host, is it host.domain.tld or ip address and does it
;; match current ip or hostname
(not (string-match (conc "("curr-host "|" curr-host"\\..*)") target-host))
(not (equal? curr-ip target-host)))
(begin
(debug:print-info 0 *default-log-port* "Starting server on " target-host ", logfile is " logfile)
(setenv "TARGETHOST" target-host)))
(setenv "TARGETHOST_LOGF" logfile)
(common:wait-for-normalized-load load-limit " delaying server start due to load" remote-host: (get-environment-variable "TARGETHOST")) ;; do not try starting servers on an already overloaded machine, just wait forever
(system (conc "nbfake " cmdln))
(unsetenv "TARGETHOST_LOGF")
(if (get-environment-variable "TARGETHOST")(unsetenv "TARGETHOST"))
(thread-join! log-rotate)
(pop-directory)))
|
Deleted iupexamples/graph.scm version [5afd5f9dcd].
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
55
56
57
58
59
60
61
62
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(use iup)
(import iup-pplot)
(define (tl)
(let* ((lastx 0)
(lastsample 2)
(plt (pplot
#:title "MyTitle"
#:marginbottom "65"
#:marginleft "65"
#:axs_xlabel "Score"
#:axs_ylabel "Count"
#:legendshow "YES"
;; #:axs_xmin "0"
;; #:axs_ymin "0"
#:axs_yautomin "YES"
#:axs_xautomin "YES"
#:axs_xautotick "YES"
#:axs_yautotick "YES"
#:ds_showvalues "YES"
#:size "200x200"
))
(plt1 (call-with-pplot
plt
(lambda (x)
(pplot-add! plt 10 100)
(pplot-add! plt 20 120)
(pplot-add! plt 30 200))
#:x-string #f
))
(plt2 (call-with-pplot
plt
(lambda (x)
(pplot-add! plt 10 180)
(pplot-add! plt 20 125)
(pplot-add! plt 30 100))
#:x-string #f
))
(dlg (dialog
(vbox
plt
(hbox
;; (button "Redraw" size: "50x" action: (lambda (obj)
;; (redraw plt)))
(button "Quit" size: "50x" action: (lambda (obj)
(exit)))
(button "AddPoint" size: "50x" action: (lambda (obj)
(set! lastx (+ lastx 10))
(set! lastsample (+ lastsample 1))
;; (attribute-set! plt 'current 0)
(print "lastx: " lastx " lastsample: " lastsample)
(pplot-add! plt lastx (random 300) lastsample 1)
(attribute-set! plt "REDRAW" "1"))))))))
(set! lastx 30)
(attribute-set! plt 'ds_mode "LINE")
;; (attribute-set! plt 'ds_legend "Yada")
(show dlg)
(main-loop)))
(tl)
|
Deleted iupexamples/iupwidgetinfo.scm version [c580d04776].
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
55
56
57
58
59
60
61
62
63
64
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
#! /usr/bin/env csi
(require-library srfi-4 iup)
(import srfi-4 iup iup-pplot iup-glcanvas)
(define (popup dlg . args)
(apply show dlg #:modal? 'yes args)
(destroy! dlg))
(define (properties ih)
(popup (element-properties-dialog ih))
'default)
(define dlg
(dialog
(vbox
(hbox ; headline
(fill)
(frame (label " Inspect control and dialog classes "
fontsize: 15))
(fill)
margin: '0x0)
(label "")
(label "Dialogs" fontsize: 12)
(hbox
(button "dialog"
action: (lambda (self) (properties (dialog (vbox)))))
(button "color-dialog"
action: (lambda (self) (properties (color-dialog))))
(button "file-dialog"
action: (lambda (self) (properties (file-dialog))))
(button "font-dialog"
action: (lambda (self) (properties (font-dialog))))
(button "message-dialog"
action: (lambda (self) (properties (message-dialog))))
(fill)
margin: '0x0)
(hbox
(button "layout-dialog"
action: (lambda (self) (properties (layout-dialog))))
(button "element-properties-dialog"
action: (lambda (self)
(properties
(element-properties-dialog (create 'user)))))
(fill)
margin: '0x0)
(label "")
(label "Composition widgets" fontsize: 12)
(hbox
(button "fill"
action: (lambda (self) (properties (fill))))
(button "hbox"
action: (lambda (self) (properties (hbox))))
(button "vbox"
action: (lambda (self) (properties (vbox))))
(button "zbox"
action: (lambda (self) (properties (zbox))))
(button "radio"
action: (lambda (self) (properties (radio (vbox)))))
(button "normalizer"
action: (lambda (self) (properties (normalizer))))
(button "cbox"
action: (lambda (self) (properties (cbox))))
(button "sbox"
action: (lambda (self) (properties (sbox (vbox)))))
(button "split"
action: (lambda (self) (properties (split (vbox) (vbox)))))
(fill)
margin: '0x0)
(label "")
(label "Standard widgets" fontsize: 12)
(hbox
(button "button"
action: (lambda (self) (properties (button))))
(button "canvas"
action: (lambda (self) (properties (canvas))))
(button "frame"
action: (lambda (self) (properties (frame))))
(button "label"
action: (lambda (self) (properties (label))))
(button "listbox"
action: (lambda (self) (properties (listbox))))
(button "progress-bar"
action: (lambda (self) (properties (progress-bar))))
(button "spin"
action: (lambda (self) (properties (spin))))
(fill)
margin: '0x0)
(hbox
(button "tabs"
action: (lambda (self) (properties (tabs))))
(button "textbox"
action: (lambda (self) (properties (textbox))))
(button "toggle"
action: (lambda (self) (properties (toggle))))
(button "treebox"
action: (lambda (self) (properties (treebox))))
(button "valuator"
action: (lambda (self) (properties (valuator ""))))
(fill)
margin: '0x0)
(label "")
(label "Additional widgets" fontsize: 12)
(hbox
(button "cells"
action: (lambda (self) (properties (cells))))
(button "color-bar"
action: (lambda (self) (properties (color-bar))))
(button "color-browser"
action: (lambda (self) (properties (color-browser))))
(button "dial"
action: (lambda (self) (properties (dial ""))))
(button "matrix"
action: (lambda (self) (properties (matrix))))
(fill)
margin: '0x0)
(hbox
(button "pplot"
action: (lambda (self) (properties (pplot))))
(button "glcanvas"
action: (lambda (self) (properties (glcanvas))))
(button "web-browser"
action: (lambda (self) (properties (web-browser))))
(fill)
margin: '0x0)
(label "")
(label "Menu widgets" fontsize: 12)
(hbox
(button "menu"
action: (lambda (self) (properties (menu))))
(button "menu-item"
action: (lambda (self) (properties (menu-item))))
(button "menu-separator"
action: (lambda (self) (properties (menu-separator))))
(fill)
margin: '0x0)
(label "")
(label "Images" fontsize: 12)
(hbox
(button "image/palette"
action: (lambda (self)
(properties
(image/palette 1 1 (u8vector->blob (u8vector 0))))))
(button "image/rgb"
action: (lambda (self)
(properties
(image/rgb 1 1 (u8vector->blob (u8vector 0))))))
(button "image/rgba"
action: (lambda (self)
(properties
(image/rgba 1 1 (u8vector->blob (u8vector 0))))))
(button "image/file"
action: (lambda (self)
(properties
;; same attributes as image/palette
(image/palette 1 1 (u8vector->blob (u8vector 0))))))
;; needs a file in current directory
;(image/file "chicken.ico")))) ; ok
;(image/file "chicken.png")))) ; doesn't work
(fill)
margin: '0x0)
(label "")
(label "Other widgets" fontsize: 12)
(hbox
(button "clipboard"
action: (lambda (self) (properties (clipboard))))
(button "timer"
action: (lambda (self) (properties (timer))))
(button "spinbox"
action: (lambda (self) (properties (spinbox (vbox)))))
(fill)
margin: '0x0)
(fill)
(button "E&xit"
expand: 'horizontal
action: (lambda (self) 'close))
)
margin: '15x15
title: "Iup inspector"))
(show dlg)
(main-loop)
(exit 0)
|
Deleted iupexamples/tree.scm version [872c01f2cf].
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
55
56
57
58
59
60
61
62
63
64
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(use test)
(require-library iup)
(import (prefix iup iup:))
(define t #f)
(define tree-dialog
(iup:dialog
#:title "Tree Test"
(let ((t1 (iup:treebox
#:selection_cb (lambda (obj id state)
(print "selection_db with id=" id " state=" state)
(print "USERDATA: " (iup:attribute obj "USERDATA"))
(print "SPECIALDATA: " (iup:attribute obj "SPECIALDATA"))
(print "Depth: " (iup:attribute obj "DEPTH"))
))))
(set! t t1)
t1)))
(iup:show tree-dialog)
(map (lambda (elname el)
(print "Adding " elname " with value " el)
(iup:attribute-set! t elname el)
(iup:attribute-set! t "USERDATA" el))
'("VALUE" "NAME" "ADDLEAF" "ADDBRANCH1" "ADDLEAF2" "VALUE")
'("0" "Figures" "Other" "triangle" "equilateral" "4")
)
(map (lambda (attr)
(print attr " is " (iup:attribute t attr)))
'("KIND1" "PARENT2" "STATE1"))
(define (tree-find-node obj path)
;; start at the base of the tree
(if (null? path)
#f ;; or 0 ????
(let loop ((hed (car path))
(tal (cdr path))
(depth 0)
(nodenum 0))
;; nodes in iup tree are 100% sequential so iterate over nodenum
(if (iup:attribute obj (conc "DEPTH" nodenum)) ;; end when no more nodes
(let ((node-depth (string->number (iup:attribute obj (conc "DEPTH" nodenum))))
(node-title (iup:attribute obj (conc "TITLE" nodenum))))
;; (print 0 "hed: " hed ", depth: " depth ", node-depth: " node-depth ", nodenum: " nodenum ", node-title: " node-title)
(if (and (equal? depth node-depth)
(equal? hed node-title)) ;; yep, this is the one!
(if (null? tal) ;; end of the line
nodenum
(loop (car tal)(cdr tal)(+ depth 1)(+ 1 nodenum)))
;; this is the case where we found part of the hierarchy but not
;; all of it, i.e. the node-depth went from deep to less deep
(if (> depth node-depth) ;; (+ 1 node-depth))
#f
(loop hed tal depth (+ nodenum 1)))))
#f))))
;; top is the top node name zeroeth node VALUE=0
(define (tree-add-node obj top nodelst)
(if (not (iup:attribute obj "TITLE0"))
(iup:attribute-set! obj "ADDBRANCH0" top))
(cond
((not (string=? top (iup:attribute obj "TITLE0")))
(print "ERROR: top name " top " doesn't match " (iup:attribute obj "TITLE0")))
((null? nodelst))
(else
(let loop ((hed (car nodelst))
(tal (cdr nodelst))
(depth 1)
(pathl (list top)))
;; Because the tree dialog changes node numbers when
;; nodes are added or removed we must look up nodes
;; each and every time. 0 is the top node so default
;; to that.
(let* ((newpath (append pathl (list hed)))
(parentnode (tree-find-node obj pathl))
(nodenum (tree-find-node obj newpath)))
;; (print "newpath: " newpath ", nodenum " nodenum ", hed: " hed ", depth: " depth ", parentnode: " parentnode ", pathl: " pathl)
;; Add the branch under lastnode if not found
(if (not nodenum)
(begin
(iup:attribute-set! obj (conc "ADDBRANCH" parentnode) hed)
(if (null? tal)
#t
;; reset to top
(loop (car nodelst)(cdr nodelst) 1 (list top))))
(if (null? tal) ;; if null here then this path has already been added
#t
;; (if nodenum
(loop (car tal)(cdr tal)(+ depth 1) newpath)))))))) ;; (if nodenum nodenum lastnode)))))))
;; (loop hed tal depth pathl lastnode)))))))
(define (tree-node->path obj nodenum)
;; (print "\ncurrnode nodenum depth node-depth node-title path")
(let loop ((currnode 0)
(depth 0)
(path '()))
(let ((node-depth (iup:attribute obj (conc "DEPTH" currnode)))
(node-title (iup:attribute obj (conc "TITLE" currnode))))
;; (display (conc "\n "currnode " " nodenum " " depth " " node-depth " " node-title " " path))
(if (> currnode nodenum)
path
(if (not node-depth) ;; #f if we are out of nodes
'()
(let ((ndepth (string->number node-depth)))
(if (eq? ndepth depth)
;; This next is the match condition depth == node-depth
(if (eq? currnode nodenum)
(begin
;; (display " <X>")
(append path (list node-title)))
(loop (+ currnode 1)
(+ depth 1)
(append path (list node-title))))
;; didn't match, reset to base path and keep looking
;; due to more iup odditys we don't reset to base
(begin
;; (display " <L>")
(loop (+ 1 currnode)
2
(append (take path ndepth)(list node-title)))))))))))
(test #f 0 (tree-find-node t '("Figures")))
(test #f 1 (tree-find-node t '("Figures" "Other")))
(test #f #f (tree-find-node t '("Figures" "Other" "equilateral")))
(test #f 3 (tree-find-node t '("Figures" "triangle" "equilateral")))
(test #f #t (tree-add-node t "Figures" '()))
(test #f #t (tree-add-node t "Figures" '("a" "b" "c")))
(test #f 3 (tree-find-node t '("Figures" "a" "b" "c")))
(test #f #t (tree-add-node t "Figures" '("d" "b" "c")))
(test #f 3 (tree-find-node t '("Figures" "d" "b" "c")))
(test #f 6 (tree-find-node t '("Figures" "a" "b" "c")))
(test #f #t (tree-add-node t "Figures" '("a" "e" "c")))
(test #f 6 (tree-find-node t '("Figures" "a" "e" "c")))
(test #f '("Figures") (tree-node->path t 0))
(test #f '("Figures" "d") (tree-node->path t 1))
(test #f '("Figures" "d" "b" "c") (tree-node->path t 3))
(test #f '("Figures" "a") (tree-node->path t 4))
(test #f '("Figures" "a" "b" "c") (tree-node->path t 8))
(test #f '() (tree-node->path t 40))
(iup:main-loop)
|
Deleted loadwatch/Makefile version [d2fa89fb63].
1
2
3
4
5
6
7
8
9
10
11
|
|
-
-
-
-
-
-
-
-
-
-
-
|
all : launch-many queuefeeder queuefeeder-server
launch-many : launch-many.scm
csc launch-many.scm
queuefeeder : queuefeeder.scm
csc queuefeeder.scm
queuefeeder-server : queuefeeder-server.scm
csc queuefeeder-server.scm
|
Deleted loadwatch/bjob-count.sh version [0c8ad639ee].
1
2
3
|
|
-
-
-
|
#!/bin/bash
bqueues | grep normal |awk '{print $8}'
|
Deleted loadwatch/launch-many.scm version [141ac70432].
1
2
3
4
5
6
7
8
9
|
|
-
-
-
-
-
-
-
-
-
|
(use posix)
(let loop ((count 0))
(if (> count 500000)
(print "DONE")
(let ((cmd (conc "./queuefeeder xena:22022 bsub ./testopenlava.sh " count " " (random 30))))
(print "Running: " cmd)
(system cmd)
(loop (+ count 1)))))
|
Deleted loadwatch/loadwatch.scm version [d281425009].
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
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(use regex srfi-69)
(define-record processdat
%cpu
virt
res
%mem
count
)
(define (pp-processdat dat)
(print "(processdat"
" %cpu=" (processdat-%cpu dat)
" virt=" (processdat-virt dat)
" res=" (processdat-res dat)
" %mem=" (processdat-%mem dat)
" count=" (processdat-count dat)))
(define nrex (regexp "^(\\d+[\\d\\.]*)([mkgMKG])$"))
(define (get-number numstr)
(let ((n (string->number numstr)))
(if n
n
(let ((nmatch (string-match nrex numstr)))
(if nmatch
(* (string->number (cadr nmatch))
(case (string->symbol (caddr nmatch))
((k) 1024)
((m) 1048576)
((g) 1073741824)
(else
(print "ERROR: Unrecognised unit: " (caddr nmatch) ", extracted for " numstr)
1)))
#f)))))
(define (snagload)
(let ((dat (make-hash-table)) ;; user => hash-of-processdat
(hdr (regexp "^\\s+PID"))
(rx (regexp "\\s+"))
(wht (regexp "^\\s+"))
)
(with-input-from-pipe
"top -n 1 -b"
(lambda ()
(let loop ((inl (read-line))
(inbod #f))
(if (eof-object? inl)
dat
(if (not inbod)
(if (string-search hdr inl)
(loop (read-line) #t)
(loop (read-line) #f))
(let* ((lparts (map (lambda (x)
(let ((num (get-number x)))
(if num num x)))
(string-split-fields rx (string-substitute wht "" inl) #:infix))))
(if (> (length lparts) 10)
(let* ((user (list-ref lparts 1))
(virt (list-ref lparts 4))
(res (list-ref lparts 5))
(%cpu (list-ref lparts 8))
(%mem (list-ref lparts 9))
(time (list-ref lparts 10))
(pname (list-ref lparts 11))
(udat (or (hash-table-ref/default dat user #f)
(let ((u (make-hash-table)))
(hash-table-set! dat user u)
u)))
(pdat (or (hash-table-ref/default udat pname #f)
(let ((p (make-processdat 0 0 0 0 0)))
(hash-table-set! udat pname p)
p))))
(print "User: " user ", pname: " pname ", virt: " virt ", res: " res ", %cpu: " %cpu ", %mem: " %mem)
(processdat-%cpu-set! pdat (+ (processdat-%cpu pdat) %cpu))
(processdat-%mem-set! pdat (+ (processdat-%mem pdat) %mem))
(processdat-virt-set! pdat (+ (processdat-virt pdat) virt))
(processdat-res-set! pdat (+ (processdat-res pdat) res))
(processdat-count-set! pdat (+ (processdat-count pdat) 1))
(loop (read-line) inbod))
dat)))))))))
(define x (snagload))
;; (processdat-%cpu (hash-table-ref (hash-table-ref x "matt") "evolution-calen"))
|
Deleted loadwatch/queuefeeder-server.scm version [4584852f4e].
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
55
56
57
58
59
60
61
62
63
64
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;;======================================================================
;; Copyright 2015-2015, 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.
;;======================================================================
;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue
;; to prevent slamming the queue
;;======================================================================
;; Methodology
;;
;; Connect to the server, the server delays the appropriate time (if
;; any) and then launch the task.
;;
(use nanomsg posix regex)
;; (use trace)
;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close )
(define port 22022)
;; get needed stuff from commandline
;;
(define queuelen #f)
(define cmd '()) ;; cmd is run to give a count of the queue length => returns number in queue
(define usage "Usage: queuefeeder-server port target_queue_length command
where command is a script or program that gives an integer on stdout of current queue length")
(let ((args (argv)))
(if (> (length args) 3)
(begin
(set! port (cadr args))
(set! queuelen (string->number (caddr args)))
(set! cmd (cadddr args))) ;; no params supported
(begin
(print usage)
(exit))))
(if (not queuelen)
(begin
(print "queuelen must be a number")
(print usage)
(exit)))
(print "Running queue feeder with port=" port ", command=" cmd)
(define rep (nn-socket 'rep))
(print "connecting, got: " (nn-bind rep (conc "tcp://" "*" ":" port)))
(define *current-delay* 0)
(define (exp-droop-calc x targ)
(cond
((> (- x targ) 1) 136) ;; top off at 136 seconds
(else
(let ((res (* 50 (exp (- x targ)))))
(cond
((and (> res 0)(< res 0.01)) 0.01)
((> res 45) 45) ;; cap at 45 seconds
(else res))))))
;; x input value (current number in the queue)
;; targ is the desired queue length
;;
(define (piecewise-droop-calc x targ)
(let ((top 50))
(cond
((> (- x targ) 0)
top) ;; top off at top seconds
((> x (- targ top))
(+ (* 1 (- x (- targ top)))
(/ (- top targ) targ)))
(else (let ((res (/ x targ)))
(if (< res 0.01)
0.01
res))))))
(define (server soc)
(print "server starting")
(let loop ((msg-in (nn-recv soc))
(count 0))
(if (eq? 0 (modulo count 1000))
(print "server received: " msg-in ", count=" count))
(cond
((equal? msg-in "quit")
(nn-send soc "Ok, quitting"))
((and (>= (string-length msg-in) 4)
(equal? (substring msg-in 0 4) "ping"))
(nn-send soc (conc (current-process-id)))
(loop (nn-recv soc)(+ count 1)))
(else
(mutex-lock! *current-delay-mutex*)
(let ((current-delay *current-delay*))
(mutex-unlock! *current-delay-mutex*)
;; (thread-sleep! current-delay)
(nn-send soc (conc current-delay " hello " msg-in " you waited " current-delay " seconds"))
(loop (nn-recv soc)(if (> count 20000000)
0
(+ count 1))))))))
(define (ping-self host port #!key (return-socket #t))
;; send a random number along with pid and check that we get it back
(let* ((req (nn-socket 'req))
(key "ping")
(success #f)
(keepwaiting #t)
(ping (make-thread
(lambda ()
(print "ping: sending string \"" key "\", expecting " (current-process-id))
(nn-send req key)
(let ((result (nn-recv req)))
(if (equal? (conc (current-process-id)) result)
(begin
(print "ping, success: received \"" result "\"")
(set! success #t))
(begin
(print "ping, failed: received key \"" result "\"")
(set! keepwaiting #f)
(set! success #f)))))
"ping"))
(timeout (make-thread (lambda ()
(let loop ((count 0))
(thread-sleep! 1)
(print "still waiting after " count " seconds...")
(if (and keepwaiting (< count 10))
(loop (+ count 1))))
(if keepwaiting
(begin
(print "timeout waiting for ping")
(thread-terminate! ping))))
"timeout")))
(nn-connect req (conc "tcp://" host ":" port))
(handle-exceptions
exn
(begin
(print-call-chain)
(print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
(print "exn=" (condition->list exn))
(print "ping failed to connect to " host ":" port))
(thread-start! timeout)
(thread-start! ping)
(thread-join! ping)
(if success (thread-terminate! timeout)))
(if return-socket
(if success req #f)
(begin
(nn-close req)
success))))
(define *current-delay-mutex* (make-mutex))
;; update the *current-delay* value every minute or QUEUE_CHK_DELAY seconds
(thread-start! (make-thread (lambda ()
(let ((delay-time (string->number (or (get-environment-variable "QUEUE_CHK_DELAY") "30"))))
(let loop ()
(with-input-from-pipe
cmd ;;; my query to get queue length
(lambda ()
(let* ((val (read))
(droop-val (if (number? val)(piecewise-droop-calc val queuelen) #f)))
;; val is number of jobs in queue. Use a linear droop of val/40
(mutex-lock! *current-delay-mutex*)
(set! *current-delay* (or droop-val 30)) ;; (/ (or droop-val 100) 50))
(mutex-unlock! *current-delay-mutex*)
(print "droop-val=" droop-val)
(thread-sleep! delay-time))))
(loop))))))
(let ((server-thread (make-thread (lambda ()(server rep)) "server")))
(thread-start! server-thread)
(if (ping-self (get-host-name) port)
(begin
(thread-join! server-thread)
(nn-close rep))
(print "ping failed")))
(exit)
|
Deleted loadwatch/queuefeeder.scm version [b7ca858163].
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
55
56
57
58
59
60
61
62
63
64
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;;======================================================================
;; Copyright 2015-2015, 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.
;;======================================================================
;; Queue Feeder. Use a crude droop curve to limit feeding jobs into a queue
;; to prevent slamming the queue
;;======================================================================
;; Methodology
;;
;; Connect to the server, the server delays the appropriate time (if
;; any) and then launch the task.
;;
(use nanomsg posix regex message-digest md5)
(define req (nn-socket 'req))
;; get needed stuff from commandline
;;
(define hostport #f)
(define cmd '())
(let ((args (argv)))
(if (> (length args) 2)
(begin
(set! hostport (cadr args))
(set! cmd (cddr args)))
(begin
(print "Usage: queuefeeder host:port command params ....")
(exit))))
(nn-connect req (conc "tcp://" hostport)) ;; xena:22022")
(define (client-send-receive soc msg)
(nn-send soc msg)
(nn-recv soc))
;; Generate a unique signature for this client location
;;
(define (make-signature)
(message-digest-string (md5-primitive)
(with-output-to-string
(lambda ()
(write (current-directory))))))
;; (define ((talk-to-server soc))
;; (let loop ((cnt 200000))
;; (let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6))))
;; ;; (print "Sending " name)
;; ;; (print
;; (client-send-receive req name) ;; )
;; (if (> cnt 0)(loop (- cnt 1)))))
;; (print (client-send-receive req "quit"))
;; (nn-close req)
;; (exit))
;;
(define (get-delay signature)
(let* ((full-msg (client-send-receive req (conc (current-user-name) "@" (get-host-name) ":" signature))))
(print "Got " full-msg)
(let* ((reply-msg (string-match "^([\\d\\.]+)\\s+(.*)$" full-msg))
(delay-time (if (> (length reply-msg) 2)
(string->number (cadr reply-msg))
1)) ;; fall back to one sec delay
(msg (if (> (length reply-msg) 2)
(caddr reply-msg)
full-msg)))
(values delay-time msg))))
(let ((signature (make-signature)))
(thread-start! (lambda ()
(thread-sleep! 60)
(print "Give up on waiting for the server")
;; (nn-close req)
;; (exit)
))
(thread-join! (thread-start! (lambda ()
(let-values
(((delay-time msg)(get-delay signature)))
(print "INFO: sleeping " delay-time " seconds per request of queuefeeder server")
(thread-sleep! delay-time)
(print "INFO: done waiting, now executing requested task.")))))
(nn-close req))
(process-execute (car cmd) (cdr cmd))
|
Deleted loadwatch/testopenlava.sh version [1f61657fdf].
1
2
3
4
5
6
7
8
9
|
|
-
-
-
-
-
-
-
-
-
|
#!/bin/bash
job_order=$1
job_length=$2
echo "START: $job_order" > $job_order.log
sleep $job_length
echo "END: $job_order" >> $job_order.log
|
Deleted rpctest/rpctest-continuous-client.scm version [bb9e39b0dd].
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
55
56
57
58
59
60
61
62
63
64
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;;;; rpc-demo.scm
;;;; Simple database server / client
;;; start server thusly: ./rpctest server test.db
;;; you will need to init test.db:
;;; sqlite3 test.db "CREATE TABLE foo (id INTEGER PRIMARY KEY, var TEXT, val TEXT);"
(require-extension (srfi 18) extras tcp rpc sql-de-lite)
;;; Common things
(define total-queries 0)
(define start-time (current-seconds))
(define operation (string->symbol (car (command-line-arguments))))
(define param (cadr (command-line-arguments)))
(print "Operation: " operation ", param: " param)
;; have a pool of db's to pick from
(define *dbpool* '())
(define *pool-mutex* (make-mutex))
(define (get-db)
(mutex-lock! *pool-mutex*)
(if (null? *dbpool*)
(begin
(mutex-unlock! *pool-mutex*)
(let ((db (open-database param)))
(set-busy-handler! db (busy-timeout 10000))
(exec (sql db "PRAGMA synchronous=0;"))
db))
(let ((res (car *dbpool*)))
(set! *dbpool* (cdr *dbpool*))
(mutex-unlock! *pool-mutex*)
res)))
(define (return-db db)
(mutex-lock! *pool-mutex*)
(set! *dbpool* (cons db *dbpool* ))
(let ((res (length *dbpool*)))
(mutex-unlock! *pool-mutex*)
res))
(define rpc:listener
(if (eq? operation 'server)
(tcp-listen (rpc:default-server-port))
(tcp-listen 0)))
;; Start server thread
(define rpc:server
(make-thread
(cute (rpc:make-server rpc:listener) "rpc:server") ;; NOTE: see equivalent code below
'rpc:server))
;; This is what the code would look like without cute
;; (define rpc:server
;; (make-thread
;; (lambda ()
;; ((rpc:make-server rpc:listener) "rpc:server"))
;; 'rpc:server))
(thread-start! rpc:server)
;;; Server side
(define (server)
(rpc:publish-procedure!
'change-response-port
(lambda (port)
(rpc:default-server-port port))
#f)
;;(let ((db (get-db))(open-database param)))
;; (set-finalizer! db finalize!)
(rpc:publish-procedure!
'query
(lambda (sqlstmt callback)
(set! total-queries (+ total-queries 1))
(print "Executing query '" sqlstmt "' ...")
(let ((db (get-db)))
(query (for-each-row
callback)
(sql db sqlstmt))
(print "Query rate: " (/ total-queries (/ (- (current-seconds) start-time) 60)) " per minute")
(print "num dbs: " (return-db db))
)))
(thread-join! rpc:server))
;;; Client side
(define (callback1 . columns)
(let loop ((c columns) (i 0))
(unless (null? c)
(printf "~a=~s " i (car c))
(loop (cdr c) (+ i 1))))
(newline))
(define callback2-results '())
(define (callback2 . columns)
(set! callback2-results (cons columns callback2-results)))
(define (client param)
((rpc:procedure 'change-response-port "localhost")
(tcp-listener-port rpc:listener))
((rpc:procedure 'query "localhost") param callback1)
(rpc:publish-procedure! 'callback2 callback2)
((rpc:procedure 'query "localhost") param callback2)
(pp callback2-results)
(rpc:close-all-connections!)
;; (rpc:close-connection! "localhost" (rpc:default-server-port))
)
(define (run-query param)
((rpc:procedure 'query "localhost") param callback1)
((rpc:procedure 'query "localhost") param callback2)
callback2-results)
(define (continuous-client #!key (duration 600)) ;; default - run for 10 minutes
((rpc:procedure 'change-response-port "localhost")
(tcp-listener-port rpc:listener))
(rpc:publish-procedure! 'callback2 callback2)
(let loop ()
(if (< (- (current-seconds) start-time) duration)
(begin
(run-query (conc "INSERT INTO foo (var,val) VALUES (" (random 1000) "," (random 1000) ");"))
(let ((numrows (caaar (run-query "SELECT COUNT(id) FROM foo;"))))
(if (and (number? numrows)
(> numrows 300))
(print (run-query (conc "DELETE FROM foo WHERE var > " (random 1000) ";")))))
(loop))))
(rpc:close-all-connections!))
;;; Run it
(if (eq? operation 'server)
(server)
(continuous-client))
|
Deleted rpctest/rpctest.scm version [900250564a].
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
55
56
57
58
59
60
61
62
63
64
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;;;; rpc-demo.scm
;;;; Simple database server / client
;;; start server thusly: ./rpctest server test.db
;;; you will need to init test.db:
;;; sqlite3 test.db "CREATE TABLE foo (id INTEGER PRIMARY KEY, var TEXT, val TEXT);"
(require-extension (srfi 18) extras tcp rpc sql-de-lite)
;;; Common things
(define total-queries 0)
(define start-time (current-seconds))
(define operation (string->symbol (car (command-line-arguments))))
(define param (cadr (command-line-arguments)))
(print "Operation: " operation ", param: " param)
;; have a pool of db's to pick from
(define *dbpool* '())
(define *pool-mutex* (make-mutex))
(define (get-db)
(mutex-lock! *pool-mutex*)
(if (null? *dbpool*)
(begin
(mutex-unlock! *pool-mutex*)
(let ((db (open-database param)))
(set-busy-handler! db (busy-timeout 10000))
(exec (sql db "PRAGMA synchronous=0;"))
db))
(let ((res (car *dbpool*)))
(set! *dbpool* (cdr *dbpool*))
(mutex-unlock! *pool-mutex*)
res)))
(define (return-db db)
(mutex-lock! *pool-mutex*)
(set! *dbpool* (cons db *dbpool* ))
(let ((res (length *dbpool*)))
(mutex-unlock! *pool-mutex*)
res))
(define rpc:listener
(if (eq? operation 'server)
(tcp-listen (rpc:default-server-port))
(tcp-listen 0)))
;; Start server thread
(define rpc:server
(make-thread
(cute (rpc:make-server rpc:listener) "rpc:server")
'rpc:server))
(thread-start! rpc:server)
;;; Server side
(define (server)
(rpc:publish-procedure!
'change-response-port
(lambda (port)
(rpc:default-server-port port))
#f)
;;(let ((db (get-db))(open-database param)))
;; (set-finalizer! db finalize!)
(rpc:publish-procedure!
'query
(lambda (sqlstmt callback)
(set! total-queries (+ total-queries 1))
(print "Executing query '" sqlstmt "' ...")
(let ((db (get-db)))
(query (for-each-row
callback)
(sql db sqlstmt))
(print "Query rate: " (/ total-queries (/ (- (current-seconds) start-time) 60)) " per minute")
(print "num dbs: " (return-db db))
)))
(thread-join! rpc:server))
;;; Client side
(define (callback1 . columns)
(let loop ((c columns) (i 0))
(unless (null? c)
(printf "~a=~s " i (car c))
(loop (cdr c) (+ i 1))))
(newline))
(define callback2-results '())
(define (callback2 . columns)
(set! callback2-results (cons columns callback2-results)))
(define (client)
((rpc:procedure 'change-response-port "localhost")
(tcp-listener-port rpc:listener))
((rpc:procedure 'query "localhost") param callback1)
(rpc:publish-procedure! 'callback2 callback2)
((rpc:procedure 'query "localhost") param callback2)
(pp callback2-results)
(rpc:close-connection! "localhost" (rpc:default-server-port)))
;;; Run it
(if (eq? operation 'server)
(server)
(client))
|
Deleted rpctest/run-client.sh version [7217b9abad].
1
2
3
4
5
6
7
8
9
10
11
12
|
|
-
-
-
-
-
-
-
-
-
-
-
-
|
#!/bin/bash
while ./rpctest client "insert into foo (var,val) values ($RANDOM,$RANDOM);";do
numrows=$(./rpctest client "select count(id) from foo;") # |wc -l)
deletefrom=$RANDOM
echo "numrows=$numrows, deletefrom=$deletefrom"
if [[ $numrows -gt 300 ]];then
echo "numrows=$numrows, deletefrom=$deletefrom"
./rpctest client "delete from foo where var > $deletefrom;"
fi
done
|
Deleted spreadsheet/basic/Configurations2/accelerator/current.xml version [da39a3ee5e].
Deleted spreadsheet/basic/META-INF/manifest.xml version [d7d7c2a2dc].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
<?xml version="1.0" encoding="UTF-8"?>
<manifest:manifest xmlns:manifest="urn:oasis:names:tc:opendocument:xmlns:manifest:1.0">
<manifest:file-entry manifest:media-type="application/vnd.oasis.opendocument.spreadsheet" manifest:version="1.2" manifest:full-path="/"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/statusbar/"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/accelerator/current.xml"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/accelerator/"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/floater/"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/popupmenu/"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/progressbar/"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/toolpanel/"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/menubar/"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/toolbar/"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/images/Bitmaps/"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Configurations2/images/"/>
<manifest:file-entry manifest:media-type="application/vnd.sun.xml.ui.configuration" manifest:full-path="Configurations2/"/>
<manifest:file-entry manifest:media-type="text/xml" manifest:full-path="content.xml"/>
<manifest:file-entry manifest:media-type="text/xml" manifest:full-path="styles.xml"/>
<manifest:file-entry manifest:media-type="text/xml" manifest:full-path="meta.xml"/>
<manifest:file-entry manifest:media-type="image/png" manifest:full-path="Thumbnails/thumbnail.png"/>
<manifest:file-entry manifest:media-type="" manifest:full-path="Thumbnails/"/>
<manifest:file-entry manifest:media-type="text/xml" manifest:full-path="settings.xml"/>
</manifest:manifest>
|
Deleted spreadsheet/basic/Thumbnails/thumbnail.png version [faa30ff37d].
cannot compute difference between binary files
Deleted spreadsheet/basic/content.xml version [2fc389eb9d].
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
55
56
57
58
59
60
61
62
63
64
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
<?xml version="1.0" encoding="UTF-8"?>
<office:document-content xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:presentation="urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:xforms="http://www.w3.org/2002/xforms" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:rpt="http://openoffice.org/2005/report" xmlns:of="urn:oasis:names:tc:opendocument:xmlns:of:1.2" xmlns:xhtml="http://www.w3.org/1999/xhtml" xmlns:grddl="http://www.w3.org/2003/g/data-view#" xmlns:tableooo="http://openoffice.org/2009/table" xmlns:field="urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0" xmlns:formx="urn:openoffice:names:experimental:ooxml-odf-interop:xmlns:form:1.0" xmlns:css3t="http://www.w3.org/TR/css3-text/" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl">
<office:scripts/>
<office:font-face-decls>
<style:font-face style:name="Arial" svg:font-family="Arial" style:font-family-generic="swiss" style:font-pitch="variable"/>
<style:font-face style:name="DejaVu Sans" svg:font-family="'DejaVu Sans'" style:font-family-generic="system" style:font-pitch="variable"/>
<style:font-face style:name="Droid Sans Fallback" svg:font-family="'Droid Sans Fallback'" style:font-family-generic="system" style:font-pitch="variable"/>
<style:font-face style:name="Lohit Hindi" svg:font-family="'Lohit Hindi'" style:font-family-generic="system" style:font-pitch="variable"/>
</office:font-face-decls>
<office:automatic-styles>
<style:style style:name="co1" style:family="table-column">
<style:table-column-properties fo:break-before="auto" style:column-width="0.8925in"/>
</style:style>
<style:style style:name="ro1" style:family="table-row">
<style:table-row-properties style:row-height="0.178in" fo:break-before="auto" style:use-optimal-row-height="true"/>
</style:style>
<style:style style:name="ta1" style:family="table" style:master-page-name="Default">
<style:table-properties table:display="true" style:writing-mode="lr-tb"/>
</style:style>
</office:automatic-styles>
<office:body>
<office:spreadsheet>
<table:table table:name="Sheet1" table:style-name="ta1" table:print="false">
<table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>Row 1,A</text:p>
</table:table-cell>
<table:table-cell office:value-type="string">
<text:p>Row 1,B</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>Row 2,A</text:p>
</table:table-cell>
<table:table-cell office:value-type="string">
<text:p>Row 2,B</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell table:number-columns-repeated="2"/>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>this is sheet one</text:p>
</table:table-cell>
<table:table-cell/>
</table:table-row>
</table:table>
<table:table table:name="Sheet2" table:style-name="ta1" table:print="false">
<table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>Row 1,A</text:p>
</table:table-cell>
<table:table-cell office:value-type="string">
<text:p>Row 1,B</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>Row 2,A</text:p>
</table:table-cell>
<table:table-cell office:value-type="string">
<text:p>Row 2,B</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell table:number-columns-repeated="2"/>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="string">
<text:p>this is sheet two</text:p>
</table:table-cell>
<table:table-cell/>
</table:table-row>
</table:table>
<table:table table:name="Sheet3" table:style-name="ta1" table:print="false">
<table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="1">
<text:p>1</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="2">
<text:p>2</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="2">
<text:p>2</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="4">
<text:p>4</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="3">
<text:p>3</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="6">
<text:p>6</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="4">
<text:p>4</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="8">
<text:p>8</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="5">
<text:p>5</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="10">
<text:p>10</text:p>
</table:table-cell>
</table:table-row>
<table:table-row table:style-name="ro1">
<table:table-cell office:value-type="float" office:value="6">
<text:p>6</text:p>
</table:table-cell>
<table:table-cell office:value-type="float" office:value="12">
<text:p>12</text:p>
</table:table-cell>
</table:table-row>
</table:table>
</office:spreadsheet>
</office:body>
</office:document-content>
|
Deleted spreadsheet/basic/content.xml~ version [41688395c5].
1
2
|
|
-
-
|
<?xml version="1.0" encoding="UTF-8"?>
<office:document-content xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:presentation="urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:xforms="http://www.w3.org/2002/xforms" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:rpt="http://openoffice.org/2005/report" xmlns:of="urn:oasis:names:tc:opendocument:xmlns:of:1.2" xmlns:xhtml="http://www.w3.org/1999/xhtml" xmlns:grddl="http://www.w3.org/2003/g/data-view#" xmlns:tableooo="http://openoffice.org/2009/table" xmlns:field="urn:openoffice:names:experimental:ooo-ms-interop:xmlns:field:1.0" xmlns:formx="urn:openoffice:names:experimental:ooxml-odf-interop:xmlns:form:1.0" xmlns:css3t="http://www.w3.org/TR/css3-text/" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl"><office:scripts/><office:font-face-decls><style:font-face style:name="Arial" svg:font-family="Arial" style:font-family-generic="swiss" style:font-pitch="variable"/><style:font-face style:name="DejaVu Sans" svg:font-family="'DejaVu Sans'" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Droid Sans Fallback" svg:font-family="'Droid Sans Fallback'" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Lohit Hindi" svg:font-family="'Lohit Hindi'" style:font-family-generic="system" style:font-pitch="variable"/></office:font-face-decls><office:automatic-styles><style:style style:name="co1" style:family="table-column"><style:table-column-properties fo:break-before="auto" style:column-width="0.8925in"/></style:style><style:style style:name="ro1" style:family="table-row"><style:table-row-properties style:row-height="0.178in" fo:break-before="auto" style:use-optimal-row-height="true"/></style:style><style:style style:name="ta1" style:family="table" style:master-page-name="Default"><style:table-properties table:display="true" style:writing-mode="lr-tb"/></style:style></office:automatic-styles><office:body><office:spreadsheet><table:table table:name="Sheet1" table:style-name="ta1" table:print="false"><table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 1,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 1,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 2,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 2,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell table:number-columns-repeated="2"/></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>this is sheet one</text:p></table:table-cell><table:table-cell/></table:table-row></table:table><table:table table:name="Sheet2" table:style-name="ta1" table:print="false"><table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 1,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 1,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>Row 2,A</text:p></table:table-cell><table:table-cell office:value-type="string"><text:p>Row 2,B</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell table:number-columns-repeated="2"/></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="string"><text:p>this is sheet two</text:p></table:table-cell><table:table-cell/></table:table-row></table:table><table:table table:name="Sheet3" table:style-name="ta1" table:print="false"><table:table-column table:style-name="co1" table:number-columns-repeated="2" table:default-cell-style-name="Default"/><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="1"><text:p>1</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="2"><text:p>2</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="2"><text:p>2</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="4"><text:p>4</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="3"><text:p>3</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="6"><text:p>6</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="4"><text:p>4</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="8"><text:p>8</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="5"><text:p>5</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="10"><text:p>10</text:p></table:table-cell></table:table-row><table:table-row table:style-name="ro1"><table:table-cell office:value-type="float" office:value="6"><text:p>6</text:p></table:table-cell><table:table-cell office:value-type="float" office:value="12"><text:p>12</text:p></table:table-cell></table:table-row></table:table></office:spreadsheet></office:body></office:document-content>
|
Deleted spreadsheet/basic/meta.xml version [a8103b8c6c].
1
2
|
|
-
-
|
<?xml version="1.0" encoding="UTF-8"?>
<office:document-meta xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:grddl="http://www.w3.org/2003/g/data-view#" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl"><office:meta><meta:initial-creator>Matt Welland</meta:initial-creator><meta:creation-date>2011-09-06T20:46:23</meta:creation-date><dc:date>2011-09-06T22:05:47</dc:date><dc:creator>Matt Welland</dc:creator><meta:editing-duration>PT1H19M25S</meta:editing-duration><meta:editing-cycles>2</meta:editing-cycles><meta:generator>LibreOffice/3.3$Linux LibreOffice_project/330m19$Build-301</meta:generator><meta:document-statistic meta:table-count="3" meta:cell-count="22" meta:object-count="0"/></office:meta></office:document-meta>
|
Deleted spreadsheet/basic/mimetype version [015538d968].
1
|
|
-
|
application/vnd.oasis.opendocument.spreadsheet
|
Deleted spreadsheet/basic/settings.xml version [ba07aed085].
1
2
|
|
-
-
|
<?xml version="1.0" encoding="UTF-8"?>
<office:document-settings xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:config="urn:oasis:names:tc:opendocument:xmlns:config:1.0" xmlns:ooo="http://openoffice.org/2004/office" office:version="1.2"><office:settings><config:config-item-set config:name="ooo:view-settings"><config:config-item config:name="VisibleAreaTop" config:type="int">0</config:config-item><config:config-item config:name="VisibleAreaLeft" config:type="int">0</config:config-item><config:config-item config:name="VisibleAreaWidth" config:type="int">4516</config:config-item><config:config-item config:name="VisibleAreaHeight" config:type="int">1799</config:config-item><config:config-item-map-indexed config:name="Views"><config:config-item-map-entry><config:config-item config:name="ViewId" config:type="string">view1</config:config-item><config:config-item-map-named config:name="Tables"><config:config-item-map-entry config:name="Sheet1"><config:config-item config:name="CursorPositionX" config:type="int">0</config:config-item><config:config-item config:name="CursorPositionY" config:type="int">0</config:config-item><config:config-item config:name="HorizontalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="VerticalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="HorizontalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="VerticalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="ActiveSplitRange" config:type="short">2</config:config-item><config:config-item config:name="PositionLeft" config:type="int">0</config:config-item><config:config-item config:name="PositionRight" config:type="int">0</config:config-item><config:config-item config:name="PositionTop" config:type="int">0</config:config-item><config:config-item config:name="PositionBottom" config:type="int">0</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item></config:config-item-map-entry><config:config-item-map-entry config:name="Sheet2"><config:config-item config:name="CursorPositionX" config:type="int">0</config:config-item><config:config-item config:name="CursorPositionY" config:type="int">4</config:config-item><config:config-item config:name="HorizontalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="VerticalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="HorizontalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="VerticalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="ActiveSplitRange" config:type="short">2</config:config-item><config:config-item config:name="PositionLeft" config:type="int">0</config:config-item><config:config-item config:name="PositionRight" config:type="int">0</config:config-item><config:config-item config:name="PositionTop" config:type="int">0</config:config-item><config:config-item config:name="PositionBottom" config:type="int">0</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item></config:config-item-map-entry><config:config-item-map-entry config:name="Sheet3"><config:config-item config:name="CursorPositionX" config:type="int">1</config:config-item><config:config-item config:name="CursorPositionY" config:type="int">5</config:config-item><config:config-item config:name="HorizontalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="VerticalSplitMode" config:type="short">0</config:config-item><config:config-item config:name="HorizontalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="VerticalSplitPosition" config:type="int">0</config:config-item><config:config-item config:name="ActiveSplitRange" config:type="short">2</config:config-item><config:config-item config:name="PositionLeft" config:type="int">0</config:config-item><config:config-item config:name="PositionRight" config:type="int">0</config:config-item><config:config-item config:name="PositionTop" config:type="int">0</config:config-item><config:config-item config:name="PositionBottom" config:type="int">0</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item></config:config-item-map-entry></config:config-item-map-named><config:config-item config:name="ActiveTable" config:type="string">Sheet3</config:config-item><config:config-item config:name="HorizontalScrollbarWidth" config:type="int">270</config:config-item><config:config-item config:name="ZoomType" config:type="short">0</config:config-item><config:config-item config:name="ZoomValue" config:type="int">100</config:config-item><config:config-item config:name="PageViewZoomValue" config:type="int">60</config:config-item><config:config-item config:name="ShowPageBreakPreview" config:type="boolean">false</config:config-item><config:config-item config:name="ShowZeroValues" config:type="boolean">true</config:config-item><config:config-item config:name="ShowNotes" config:type="boolean">true</config:config-item><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item><config:config-item config:name="GridColor" config:type="long">12632256</config:config-item><config:config-item config:name="ShowPageBreaks" config:type="boolean">true</config:config-item><config:config-item config:name="HasColumnRowHeaders" config:type="boolean">true</config:config-item><config:config-item config:name="HasSheetTabs" config:type="boolean">true</config:config-item><config:config-item config:name="IsOutlineSymbolsSet" config:type="boolean">true</config:config-item><config:config-item config:name="IsSnapToRaster" config:type="boolean">false</config:config-item><config:config-item config:name="RasterIsVisible" config:type="boolean">false</config:config-item><config:config-item config:name="RasterResolutionX" config:type="int">1270</config:config-item><config:config-item config:name="RasterResolutionY" config:type="int">1270</config:config-item><config:config-item config:name="RasterSubdivisionX" config:type="int">1</config:config-item><config:config-item config:name="RasterSubdivisionY" config:type="int">1</config:config-item><config:config-item config:name="IsRasterAxisSynchronized" config:type="boolean">true</config:config-item></config:config-item-map-entry></config:config-item-map-indexed></config:config-item-set><config:config-item-set config:name="ooo:configuration-settings"><config:config-item config:name="IsKernAsianPunctuation" config:type="boolean">false</config:config-item><config:config-item config:name="IsRasterAxisSynchronized" config:type="boolean">true</config:config-item><config:config-item config:name="LinkUpdateMode" config:type="short">3</config:config-item><config:config-item config:name="SaveVersionOnClose" config:type="boolean">false</config:config-item><config:config-item config:name="AllowPrintJobCancel" config:type="boolean">true</config:config-item><config:config-item config:name="HasSheetTabs" config:type="boolean">true</config:config-item><config:config-item config:name="ShowPageBreaks" config:type="boolean">true</config:config-item><config:config-item config:name="RasterResolutionX" config:type="int">1270</config:config-item><config:config-item config:name="PrinterSetup" config:type="base64Binary"/><config:config-item config:name="RasterResolutionY" config:type="int">1270</config:config-item><config:config-item config:name="LoadReadonly" config:type="boolean">false</config:config-item><config:config-item config:name="RasterSubdivisionX" config:type="int">1</config:config-item><config:config-item config:name="ShowNotes" config:type="boolean">true</config:config-item><config:config-item config:name="ShowZeroValues" config:type="boolean">true</config:config-item><config:config-item config:name="RasterSubdivisionY" config:type="int">1</config:config-item><config:config-item config:name="ApplyUserData" config:type="boolean">true</config:config-item><config:config-item config:name="GridColor" config:type="long">12632256</config:config-item><config:config-item config:name="RasterIsVisible" config:type="boolean">false</config:config-item><config:config-item config:name="IsSnapToRaster" config:type="boolean">false</config:config-item><config:config-item config:name="PrinterName" config:type="string"/><config:config-item config:name="ShowGrid" config:type="boolean">true</config:config-item><config:config-item config:name="CharacterCompressionType" config:type="short">0</config:config-item><config:config-item config:name="HasColumnRowHeaders" config:type="boolean">true</config:config-item><config:config-item config:name="IsOutlineSymbolsSet" config:type="boolean">true</config:config-item><config:config-item config:name="AutoCalculate" config:type="boolean">true</config:config-item><config:config-item config:name="IsDocumentShared" config:type="boolean">false</config:config-item><config:config-item config:name="UpdateFromTemplate" config:type="boolean">true</config:config-item></config:config-item-set></office:settings></office:document-settings>
|
Deleted spreadsheet/basic/styles.xml version [e3b321fd12].
1
2
|
|
-
-
|
<?xml version="1.0" encoding="UTF-8"?>
<office:document-styles xmlns:office="urn:oasis:names:tc:opendocument:xmlns:office:1.0" xmlns:style="urn:oasis:names:tc:opendocument:xmlns:style:1.0" xmlns:text="urn:oasis:names:tc:opendocument:xmlns:text:1.0" xmlns:table="urn:oasis:names:tc:opendocument:xmlns:table:1.0" xmlns:draw="urn:oasis:names:tc:opendocument:xmlns:drawing:1.0" xmlns:fo="urn:oasis:names:tc:opendocument:xmlns:xsl-fo-compatible:1.0" xmlns:xlink="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:meta="urn:oasis:names:tc:opendocument:xmlns:meta:1.0" xmlns:number="urn:oasis:names:tc:opendocument:xmlns:datastyle:1.0" xmlns:presentation="urn:oasis:names:tc:opendocument:xmlns:presentation:1.0" xmlns:svg="urn:oasis:names:tc:opendocument:xmlns:svg-compatible:1.0" xmlns:chart="urn:oasis:names:tc:opendocument:xmlns:chart:1.0" xmlns:dr3d="urn:oasis:names:tc:opendocument:xmlns:dr3d:1.0" xmlns:math="http://www.w3.org/1998/Math/MathML" xmlns:form="urn:oasis:names:tc:opendocument:xmlns:form:1.0" xmlns:script="urn:oasis:names:tc:opendocument:xmlns:script:1.0" xmlns:ooo="http://openoffice.org/2004/office" xmlns:ooow="http://openoffice.org/2004/writer" xmlns:oooc="http://openoffice.org/2004/calc" xmlns:dom="http://www.w3.org/2001/xml-events" xmlns:rpt="http://openoffice.org/2005/report" xmlns:of="urn:oasis:names:tc:opendocument:xmlns:of:1.2" xmlns:xhtml="http://www.w3.org/1999/xhtml" xmlns:grddl="http://www.w3.org/2003/g/data-view#" xmlns:tableooo="http://openoffice.org/2009/table" xmlns:css3t="http://www.w3.org/TR/css3-text/" office:version="1.2" grddl:transformation="http://docs.oasis-open.org/office/1.2/xslt/odf2rdf.xsl"><office:font-face-decls><style:font-face style:name="Arial" svg:font-family="Arial" style:font-family-generic="swiss" style:font-pitch="variable"/><style:font-face style:name="DejaVu Sans" svg:font-family="'DejaVu Sans'" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Droid Sans Fallback" svg:font-family="'Droid Sans Fallback'" style:font-family-generic="system" style:font-pitch="variable"/><style:font-face style:name="Lohit Hindi" svg:font-family="'Lohit Hindi'" style:font-family-generic="system" style:font-pitch="variable"/></office:font-face-decls><office:styles><style:default-style style:family="table-cell"><style:paragraph-properties style:tab-stop-distance="0.5in"/><style:text-properties style:font-name="Arial" fo:language="en" fo:country="US" style:font-name-asian="DejaVu Sans" style:language-asian="zh" style:country-asian="CN" style:font-name-complex="DejaVu Sans" style:language-complex="hi" style:country-complex="IN"/></style:default-style><number:number-style style:name="N0"><number:number number:min-integer-digits="1"/></number:number-style><number:currency-style style:name="N104P0" style:volatile="true"><number:currency-symbol number:language="en" number:country="US">$</number:currency-symbol><number:number number:decimal-places="2" number:min-integer-digits="1" number:grouping="true"/></number:currency-style><number:currency-style style:name="N104"><style:text-properties fo:color="#ff0000"/><number:text>-</number:text><number:currency-symbol number:language="en" number:country="US">$</number:currency-symbol><number:number number:decimal-places="2" number:min-integer-digits="1" number:grouping="true"/><style:map style:condition="value()>=0" style:apply-style-name="N104P0"/></number:currency-style><style:style style:name="Default" style:family="table-cell"><style:text-properties style:font-name-asian="Droid Sans Fallback" style:font-name-complex="Lohit Hindi"/></style:style><style:style style:name="Result" style:family="table-cell" style:parent-style-name="Default"><style:text-properties fo:font-style="italic" style:text-underline-style="solid" style:text-underline-width="auto" style:text-underline-color="font-color" fo:font-weight="bold"/></style:style><style:style style:name="Result2" style:family="table-cell" style:parent-style-name="Result" style:data-style-name="N104"/><style:style style:name="Heading" style:family="table-cell" style:parent-style-name="Default"><style:table-cell-properties style:text-align-source="fix" style:repeat-content="false"/><style:paragraph-properties fo:text-align="center"/><style:text-properties fo:font-size="16pt" fo:font-style="italic" fo:font-weight="bold"/></style:style><style:style style:name="Heading1" style:family="table-cell" style:parent-style-name="Heading"><style:table-cell-properties style:rotation-angle="90"/></style:style></office:styles><office:automatic-styles><style:page-layout style:name="Mpm1"><style:page-layout-properties style:writing-mode="lr-tb"/><style:header-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-bottom="0.0984in"/></style:header-style><style:footer-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-top="0.0984in"/></style:footer-style></style:page-layout><style:page-layout style:name="Mpm2"><style:page-layout-properties style:writing-mode="lr-tb"/><style:header-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-bottom="0.0984in" fo:border="0.0346in solid #000000" fo:padding="0.0071in" fo:background-color="#c0c0c0"><style:background-image/></style:header-footer-properties></style:header-style><style:footer-style><style:header-footer-properties fo:min-height="0.2957in" fo:margin-left="0in" fo:margin-right="0in" fo:margin-top="0.0984in" fo:border="0.0346in solid #000000" fo:padding="0.0071in" fo:background-color="#c0c0c0"><style:background-image/></style:header-footer-properties></style:footer-style></style:page-layout></office:automatic-styles><office:master-styles><style:master-page style:name="Default" style:page-layout-name="Mpm1"><style:header><text:p><text:sheet-name>???</text:sheet-name></text:p></style:header><style:header-left style:display="false"/><style:footer><text:p>Page <text:page-number>1</text:page-number></text:p></style:footer><style:footer-left style:display="false"/></style:master-page><style:master-page style:name="Report" style:page-layout-name="Mpm2"><style:header><style:region-left><text:p><text:sheet-name>???</text:sheet-name> (<text:title>???</text:title>)</text:p></style:region-left><style:region-right><text:p><text:date style:data-style-name="N2" text:date-value="2011-09-06">09/06/2011</text:date>, <text:time>22:05:47</text:time></text:p></style:region-right></style:header><style:header-left style:display="false"/><style:footer><text:p>Page <text:page-number>1</text:page-number> / <text:page-count>99</text:page-count></text:p></style:footer><style:footer-left style:display="false"/></style:master-page></office:master-styles></office:document-styles>
|
Deleted testhttp/example-client.scm version [57afe37838].
1
2
3
4
5
6
|
|
-
-
-
-
-
-
|
(use regex http-client)
(print (with-input-from-request "http://localhost:8083/?foo=1" #f
(lambda ()
(let ((match (string-search (regexp "<body>(.*)<.body>") (caddr (string-split (read-string) "\n")))))
(cadr match)))))
|
Deleted testhttp/example-server.scm version [1efa10faa7].
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(use spiffy awful)
(tcp-buffer-size 2048)
(enable-sxml #t)
(define (hello-world)
(define-page (main-page-path)
(lambda ()
(with-request-variables (foo)
foo))))
(define (start-server #!key (portnum 8080))
(handle-exceptions
exn
(begin
(print-error-message exn)
(if (< portnum 9000)
(begin
(print "WARNING: failed to start on portnum: " portnum ", trying next port")
(sleep 1)
(start-server portnum: (+ portnum 1)))
(print "ERROR: Tried and tried but could not start the server")))
(print "INFO: Trying to start server on portnum: " portnum)
(awful-start hello-world port: portnum)))
(start-server)
|
Deleted testhttp/mockupclient.scm version [fceab37de6].
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(use posix)
(define cname "Bob")
(define runtime 10)
(let ((args (argv)))
(if (< (length args) 3)
(begin
(print "Usage: mockupclient clientname runtime")
(exit))
(begin
(set! cname (cadr args))
(set! runtime (string->number (caddr args))))))
;; (define start-delay (/ (random 100) 9))
;; (define runtime (+ 1 (/ (random 200) 2)))
(print "Starting client " cname " with runtime " runtime)
(include "mockupclientlib.scm")
(set! endtime (+ (current-seconds) runtime))
(let loop ()
(let ((x (random 15))
(varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4))))
(case x
;; ((1)(dbaccess cname 'sync "nodat" #f))
((2 3 4 5)(dbaccess cname 'set varname (random 999)))
((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f)))
(else
(thread-sleep! 0.011)))
(if (< (current-seconds) endtime)
(loop))))
(print "Client " cname " all done!!")
|
Deleted testhttp/mockupclientlib.scm version [6a9bd9de5d].
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(define sub (make-socket 'sub))
(define push (make-socket 'push))
(socket-option-set! sub 'subscribe cname)
(connect-socket sub "tcp://localhost:5563")
(connect-socket push "tcp://localhost:5564")
(define (dbaccess cname cmd var val #!key (numtries 1))
(let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var)))
(res #f)
(do-access (lambda ()
(print "Sending msg: " msg)
(send-message push msg)
(print "Message " msg " sent")
(print "Client " cname " waiting for response to " msg)
(print "Client " cname " received address " (receive-message* sub))
(set! res (receive-message* sub)))))
(let ((th1 (make-thread do-access "do access"))
(th2 (make-thread (lambda ()
(thread-sleep! 5)
(if (not res)
(if (> numtries 0)
(begin
(print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries)
(dbaccess cname cmd var val numtries: (- numtries 1)))
(begin
(print "ERROR: dbaccess timed out. Exiting")
(exit)))))
"timeout thread")))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
res)))
|
Deleted testhttp/mockupserver.scm version [aa3c5bcdcf].
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
55
56
57
58
59
60
61
62
63
64
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; pub/sub with envelope address
;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon
;; as a client disconnects. Also a remaining client may receive tons of
;; messages afterward.
(use srfi-18 sqlite3 spiffy)
(define cname "server")
(define total-db-accesses 0)
(define start-time (current-seconds))
;; setup the server here
(tcp-buffer-size 2048)
(server-port 5563)
(define (open-db)
(let* ((dbpath "mockup.db")
(dbexists (file-exists? dbpath))
(db (open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout 10)))
(set-busy-handler! db handler)
(if (not dbexists)
(for-each
(lambda (stmt)
(execute db stmt))
(list
"PRAGMA SYNCHRONOUS=0;"
"CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);"
"CREATE TABLE vars (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));")))
db))
(define cid-cache (make-hash-table))
(define (get-client-id db cname)
(let ((cid (hash-table-ref/default cid-cache cname #f)))
(if cid
cid
(begin
(execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname)
(for-each-row
(lambda (id)
(set! cid id))
db
"SELECT id FROM clients WHERE name=?;" cname)
(hash-table-set! cid-cache cname cid)
(set! total-db-accesses (+ total-db-accesses 2))
cid))))
(define (count-client db cname)
(let ((cid (get-client-id db cname)))
(execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid)
(set! total-db-accesses (+ total-db-accesses 1))
))
(define db (open-db))
;; (define queuelst '())
;; (define mx1 (make-mutex))
(define max-queue-len 0)
(define (process-queue queuelst)
(let ((queuelen (length queuelst)))
(if (> queuelen max-queue-len)
(set! max-queue-len queuelen))
(for-each
(lambda (item)
(let ((cname (vector-ref item 1))
(clcmd (vector-ref item 2))
(cdata (vector-ref item 3)))
(send-message pub cname send-more: #t)
(send-message pub (case clcmd
((sync)
(conc queuelen))
((set)
(set! total-db-accesses (+ total-db-accesses 1))
(apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata))
"ok")
((get)
(set! total-db-accesses (+ total-db-accesses 1))
(let ((res "noval"))
(for-each-row
(lambda (val)
(set! res val))
db
"SELECT val FROM vars WHERE var=?;" cdata)
res))
(else (conc "unk cmd: " clcmd))))))
queuelst)))
(define th1 (make-thread
(lambda ()
(let ((last-run 0)) ;; current-seconds when run last
(let loop ((queuelst '()))
(let* ((indat (receive-message* pull))
(parts (string-split indat ":"))
(cname (car parts)) ;; client name
(clcmd (string->symbol (cadr parts))) ;; client cmd
(cdata (caddr parts)) ;; client data
(svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue
(count-client db cname)
(case clcmd
((sync) ;; just process the queue
(print "Got sync from " cname)
(process-queue (cons svect queuelst))
(loop '()))
((get)
(process-queue (cons svect queuelst))
(loop '()))
(else
(loop (cons svect queuelst))))))))
"server thread"))
(include "mockupclientlib.scm")
;; ;; send a sync to the pull port
;; (define th2 (make-thread
;; (lambda ()
;; (let ((last-action-time (current-seconds)))
;; (let loop ()
;; (thread-sleep! 5)
;; (let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f)))
;; (last-action-delta #f))
;; (if (> queuelen 1)(set! last-action-time (current-seconds)))
;; (set! last-action-delta (- (current-seconds) last-action-time))
;; (print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta)
;; (if (< last-action-delta 60)
;; (loop)
;; (print "Server exiting, 25 seconds since last access"))))))
;; "sync thread"))
(handle-not-found
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
(let* ((run-time (- (current-seconds) start-time))
(queries/second (/ total-db-accesses run-time)))
(print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len))
|
Deleted testhttp/testclient.scm version [4aba6dc5d5].
1
2
3
4
5
6
7
8
|
|
-
-
-
-
-
-
-
-
|
(use http-client)
(with-input-from-request "http://localhost:12345/hey"
;; #f
;; msg
(list (cons 'dat "Testing eh"))
read-string)
|
Deleted testhttp/testserver.scm version [02c28bc9cb].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(use spiffy uri-common intarweb spiffy-request-vars)
(root-path "/var/www")
(vhost-map `(((* any) . ,(lambda (continue)
(let (($ (request-vars source: 'both)))
(print ($ 'dat))
(if (equal? (uri-path (request-uri (current-request)))
'(/ "hey"))
(send-response body: "hey there!\n"
headers: '((content-type text/plain)))
(continue)))))))
(start-server port: 12345)
|
Deleted testnanomsg/basic-req-rep.scm version [1436c827c9].
1
2
3
|
|
-
-
-
|
(use nanomsg srfi-18 sqlite3 numbers)
(define resp (nn-socket 'rep))
|
Deleted testnanomsg/mockupclient.scm version [63a8c6685a].
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(use zmq posix numbers)
(define cname "Bob")
(define runtime 10)
(let ((args (argv)))
(if (< (length args) 3)
(begin
(print "Usage: mockupclient clientname runtime")
(exit))
(begin
(set! cname (cadr args))
(set! runtime (string->number (caddr args))))))
;; (define start-delay (/ (random 100) 9))
;; (define runtime (+ 1 (/ (random 200) 2)))
(print "Starting client " cname " with runtime " runtime)
(include "mockupclientlib.scm")
(set! endtime (+ (current-seconds) runtime))
;; first ping the server to ensure we have a connection
(if (server-ping cname 5)
(print "SUCCESS: Client " cname " connected to server")
(begin
(print "ERROR: Client " cname " failed ping of server, exiting")
(exit)))
(let loop ()
(let ((x (random 15))
(varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4))))
(case x
;; ((1)(dbaccess cname 'sync "nodat" #f))
((2 3 4 5)(dbaccess cname 'set varname (random 999)))
((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f)))
(else
(thread-sleep! 0.011)))
(if (< (current-seconds) endtime)
(loop))))
(print "Client " cname " all done!!")
|
Deleted testnanomsg/mockupclientlib.scm version [3b245ba7a9].
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
55
56
57
58
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(define reqs (nn-socket 'req))
(connect-socket reqs "tcp://localhost:6563")
(thread-sleep! 0.2)
(define (server-ping cname timeout)
(let ((msg (conc cname ":ping:" timeout))
(maxtime (+ (current-seconds) timeout)))
(print "pinging server from " cname " with timeout " timeout)
(let loop ((res #f))
(if (< maxtime (current-seconds))
#f ;; failed to ping
(if (equal? res "Got ping")
#t
(begin
(print "Ping received from server " res)
(send-message push msg)
(thread-sleep! 0.1)
(loop (receive-message sub non-blocking: #t))))))))
(define (dbaccess cname cmd var val #!key (numtries 20))
(let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var)))
(res #f)
(mtx1 (make-mutex))
(do-access (lambda ()
(let ((tmpres #f))
(print "Sending msg: " msg)
(send-message push msg)
(print "Message " msg " sent")
(print "Client " cname " waiting for response to " msg)
(print "Client " cname " received address " (receive-message* sub))
(set! tmpres (receive-message* sub))
(mutex-lock! mtx1)
(set! res tmpres)
(mutex-unlock! mtx1))))
(th1 (make-thread do-access "do access"))
(th2 (make-thread (lambda ()
(let ((result #f))
(mutex-lock! mtx1)
(set! result res)
(mutex-unlock! mtx1)
(thread-sleep! 5)
(if (not result)
(if (> numtries 0)
(begin
(print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries)
(dbaccess cname cmd var val numtries: (- numtries 1)))
(begin
(print "ERROR: dbaccess timed out. Exiting")
(exit)))))
"timeout thread"))))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(if res (print "SUCCESS: received " res " with " numtries " remaining possible attempts"))
res))
|
Deleted testnanomsg/mockupserver.scm version [a4d3e5594c].
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
55
56
57
58
59
60
61
62
63
64
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; pub/sub with envelope address
;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon
;; as a client disconnects. Also a remaining client may receive tons of
;; messages afterward.
(use nanomsg srfi-18 sqlite3 numbers)
(define resp (nn-socket 'rep))
(define cname "server")
(define total-db-accesses 0)
(define start-time (current-seconds))
(nn-bind resp "tcp://*:6563")
(thread-sleep! 0.2)
(define (open-db)
(let* ((dbpath "mockup.db")
(dbexists (file-exists? dbpath))
(db (open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout 10)))
(set-busy-handler! db handler)
(if (not dbexists)
(for-each
(lambda (stmt)
(execute db stmt))
(list
"PRAGMA SYNCHRONOUS=0;"
"CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);"
"CREATE TABLE vars (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));")))
db))
(define cid-cache (make-hash-table))
(define (get-client-id db cname)
(let ((cid (hash-table-ref/default cid-cache cname #f)))
(if cid
cid
(begin
(execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname)
(for-each-row
(lambda (id)
(set! cid id))
db
"SELECT id FROM clients WHERE name=?;" cname)
(hash-table-set! cid-cache cname cid)
(set! total-db-accesses (+ total-db-accesses 2))
cid))))
(define (count-client db cname)
(let ((cid (get-client-id db cname)))
(execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid)
(set! total-db-accesses (+ total-db-accesses 1))
))
(define db (open-db))
;; (define queuelst '())
;; (define mx1 (make-mutex))
(define max-queue-len 0)
(define (process-queue queuelst)
(let ((queuelen (length queuelst)))
(if (> queuelen max-queue-len)
(set! max-queue-len queuelen))
(for-each
(lambda (item)
(let ((cname (vector-ref item 1))
(clcmd (vector-ref item 2))
(cdata (vector-ref item 3)))
(send-message pub cname send-more: #t)
(send-message pub (case clcmd
((sync)
(conc queuelen))
((set)
(set! total-db-accesses (+ total-db-accesses 1))
(apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata))
"ok")
((get)
(set! total-db-accesses (+ total-db-accesses 1))
(let ((res "noval"))
(for-each-row
(lambda (val)
(set! res val))
db
"SELECT val FROM vars WHERE var=?;" cdata)
res))
(else (conc "unk cmd: " clcmd))))))
queuelst)))
;; SERVER THREAD
(define th1 (make-thread
(lambda ()
(let ((last-run 0)) ;; current-seconds when run last
(let loop ((queuelst '()))
(let* ((indat (receive-message* pull))
(parts (string-split indat ":"))
(cname (car parts)) ;; client name
(clcmd (string->symbol (cadr parts))) ;; client cmd
(cdata (caddr parts)) ;; client data
(svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue
;; (print "Server received message: " indat)
(count-client db cname)
(case clcmd
((ping)
(print "Got ping from " cname)
(send-message pub cname send-more: #t)
(send-message pub "Got ping")
(loop queuelst))
((sync) ;; just process the queue
(print "Got sync from " cname)
(process-queue (cons svect queuelst))
(loop '()))
((get)
(process-queue (cons svect queuelst))
(loop '()))
(else
(loop (cons svect queuelst))))))))
"server thread"))
(include "mockupclientlib.scm")
;; SYNC THREAD
;; send a sync to the pull port
(define th2 (make-thread
(lambda ()
(let ((last-action-time (current-seconds)))
(let loop ()
(thread-sleep! 5)
(let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f)))
(last-action-delta #f))
(if (> queuelen 1)(set! last-action-time (current-seconds)))
(set! last-action-delta (- (current-seconds) last-action-time))
(print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta)
(if (< last-action-delta 60)
(loop)
(print "Server exiting, 25 seconds since last access"))))))
"sync thread"))
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
(let* ((run-time (- (current-seconds) start-time))
(queries/second (/ total-db-accesses run-time)))
(print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len))
|
Deleted testnanomsg/pipeline.scm version [1d4d831eb6].
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg)
(define push (nn-socket 'push))
(define pull1 (nn-socket 'pull))
(define pull2 (nn-socket 'pull))
(nn-bind push "inproc://test")
(nn-connect pull1 "inproc://test")
(nn-connect pull2 "inproc://test")
(nn-send push "a")
(nn-send push "b")
(nn-send push "c")
(nn-send push "d")
(define ((th sock))
(print (current-thread) ": " (nn-recv sock))
(print (current-thread) ": " (nn-recv sock))
(print (current-thread) " is done"))
(thread-start! (th pull1))
(thread-start! (th pull2))
(thread-sleep! 1)
|
Deleted testnanomsg/req-rep-client.scm version [62cc97e2a5].
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg posix regex)
(define req (nn-socket 'req))
(nn-connect req "tcp://localhost:22022")
;; (with-output-to-string (lambda ()(serialize obj)))
(define (client-send-receive soc msg)
(nn-send soc msg)
(nn-recv soc))
(define ((talk-to-server soc))
(let loop ((cnt 200000))
(let ((name (list-ref '("Matt" "Tom" "Bob" "Jill" "James" "Jane")(random 6))))
;; (print "Sending " name)
;; (print
(client-send-receive req name) ;; )
(if (> cnt 0)(loop (- cnt 1)))))
(print (client-send-receive req "quit"))
(nn-close req)
(exit))
;; (thread-start! (lambda ()
;; (thread-sleep! 20)
;; (print "Give up on waiting for the server")
;; (nn-close req)
;; (exit)))
(thread-join! (thread-start! (talk-to-server req)))
|
Deleted testnanomsg/req-rep-server.scm version [7ffb9a9d45].
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
55
56
57
58
59
60
61
62
63
64
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg posix regex)
;; (use trace)
;; (trace nn-bind nn-socket nn-assert nn-recv nn-send thread-terminate! nn-close )
(define port 22022)
(define host "127.0.0.1")
(define rep (nn-socket 'rep))
(print "connecting, got: " (nn-bind rep (conc "tcp://" "*" ":" port)))
(define (server soc)
(print "server starting")
(let loop ((msg-in (nn-recv soc))
(count 0))
(if (eq? 0 (modulo count 1000))
(print "server received: " msg-in ", count=" count))
(cond
((equal? msg-in "quit")
(nn-send soc "Ok, quitting"))
((and (>= (string-length msg-in) 4)
(equal? (substring msg-in 0 4) "ping"))
(nn-send soc (conc (current-process-id)))
(loop (nn-recv soc)(+ count 1)))
;;((and (>= (string-length msg-in)
(else
(let ((this-task (/ (random 10) 200.0))
(start-time (current-milliseconds)))
;; (thread-sleep! this-task)
(nn-send soc (conc "hello " msg-in " this task took " this-task " seconds to complete"))
;; (print "Actual send-receive time: " (- (current-milliseconds) start-time));
(loop (nn-recv soc)(+ count 1)))))))
(define (ping-self host port #!key (return-socket #t))
;; send a random number along with pid and check that we get it back
(let* ((req (nn-socket 'req))
(key "ping")
(success #f)
(keepwaiting #t)
(ping (make-thread
(lambda ()
(print "ping: sending string \"" key "\", expecting " (current-process-id))
(nn-send req key)
(let ((result (nn-recv req)))
(if (equal? (conc (current-process-id)) result)
(begin
(print "ping, success: received \"" result "\"")
(set! success #t))
(begin
(print "ping, failed: received key \"" result "\"")
(set! keepwaiting #f)
(set! success #f)))))
"ping"))
(timeout (make-thread (lambda ()
(let loop ((count 0))
(thread-sleep! 1)
(print "still waiting after count seconds...")
(if (and keepwaiting (< count 10))
(loop (+ count 1))))
(if keepwaiting
(begin
(print "timeout waiting for ping")
(thread-terminate! ping))))
"timeout")))
(nn-connect req (conc "tcp://" host ":" port))
(handle-exceptions
exn
(begin
(print-call-chain)
(print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
(print "exn=" (condition->list exn))
(print "ping failed to connect to " host ":" port))
(thread-start! timeout)
(thread-start! ping)
(thread-join! ping)
(if success (thread-terminate! timeout)))
(if return-socket
(if success req #f)
(begin
(nn-close req)
success))))
(let ((server-thread (make-thread (lambda ()(server rep)) "server")))
(thread-start! server-thread)
;; (thread-sleep! 1)
(if (ping-self host port)
(begin
(thread-join! server-thread)
(nn-close rep))
(print "ping failed")))
(exit)
|
Deleted testnanomsg/req-rep.scm version [4b0d8cd65b].
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; watch nanomsg's pipeline load-balancer in action.
(use nanomsg)
;; client
(define req (nn-socket 'req))
(nn-connect req "inproc://test")
(define (client-send-receive soc msg)
(nn-send soc msg)
(nn-recv soc))
;; server
(define rep (nn-socket 'rep))
(nn-bind rep "inproc://test")
(define ((server soc))
(let loop ((msg-in (nn-recv soc)))
(if (not (equal? msg-in "quit"))
(begin
(nn-send soc (conc "hello " msg-in))
(loop (nn-recv soc))))))
(thread-start! (server rep))
;; client
(print (client-send-receive req "Matt"))
(print (client-send-receive req "Tom"))
;; (client-send-receive req "quit")
(nn-close req) ;; client
(nn-close rep) ;; server
(exit)
|
Deleted testrpc/client.scm version [eacc9c3c29].
1
2
3
4
5
6
7
8
|
|
-
-
-
-
-
-
-
-
|
;;;; client.scm
(use rpc posix)
(define call (rpc:procedure 'foo "localhost"))
(do ((i 10 (sub1 i)))
((zero? i))
(print "-> " (call (random 100))))
|
Deleted testrpc/server.scm version [d4d2e05e92].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;;;; server.scm
(use rpc)
(rpc:publish-procedure!
'foo
(lambda (x)
(print "foo: " x)
#f))
(rpc:publish-procedure!
'fini
(lambda () (print "fini") (thread-start! (lambda () (thread-sleep! 3) (print "terminate") (exit))) #f))
((rpc:make-server (tcp-listen (rpc:default-server-port))) #t)
|
Deleted testzmq/hwclient.scm version [2bca7d9a69].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(use zmq posix srfi-18)
(define s (make-socket 'req))
(connect-socket s "tcp://*:5563")
(define myname (cadr (argv)))
(print "Start client...")
(do ((i 0 (+ i 1)))
((>= i 1000))
(print "sending message #" i)
(send-message s (conc "Hello from " myname))
(print "sent \"Hello\", looking for a reply")
(printf "Received reply ~a [~a]\n"
i (receive-message s)))
|
Deleted testzmq/hwserver.scm version [d8d9994146].
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(use zmq srfi-18 posix)
(define th1 (make-thread
(lambda ()
(let ((s (make-socket 'rep)))
(bind-socket s "tcp://*:5563")
(print "Start server...")
(let loop ()
(let* ((msg (receive-message s))
(name (caddr (string-split msg " ")))
(resp (conc "World " name)))
(print "Received request: [" msg "]")
(thread-sleep! 0.0001)
(print "Sending response \"" resp "\"")
(send-message s resp)
(loop)))))))
(define th2 (make-thread
(lambda ()
(let loop ((count 0))
(print "count is " count)
(thread-sleep! 0.1)
(if (< count 10000)
(loop (+ count 1)))))))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
|
Deleted testzmq/hwtest.sh version [aa5368d04d].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
#!/bin/bash
echo Compiling hwclient and hwserver
csc hwclient.scm
csc hwserver.scm
./hwserver > hwserver.log &
sleep 1
for x in a b c d e f g h i j k l m n o p q r s t u v w x y z;do
./hwclient $x &
done
# killall -v hwserver hwclient
|
Deleted testzmq/mockupclient.scm version [63a8c6685a].
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(use zmq posix numbers)
(define cname "Bob")
(define runtime 10)
(let ((args (argv)))
(if (< (length args) 3)
(begin
(print "Usage: mockupclient clientname runtime")
(exit))
(begin
(set! cname (cadr args))
(set! runtime (string->number (caddr args))))))
;; (define start-delay (/ (random 100) 9))
;; (define runtime (+ 1 (/ (random 200) 2)))
(print "Starting client " cname " with runtime " runtime)
(include "mockupclientlib.scm")
(set! endtime (+ (current-seconds) runtime))
;; first ping the server to ensure we have a connection
(if (server-ping cname 5)
(print "SUCCESS: Client " cname " connected to server")
(begin
(print "ERROR: Client " cname " failed ping of server, exiting")
(exit)))
(let loop ()
(let ((x (random 15))
(varname (list-ref (list "hello" "goodbye" "saluton" "kiaorana")(random 4))))
(case x
;; ((1)(dbaccess cname 'sync "nodat" #f))
((2 3 4 5)(dbaccess cname 'set varname (random 999)))
((6 7 8 9 10)(print cname ": Get \"" varname "\" " (dbaccess cname 'get varname #f)))
(else
(thread-sleep! 0.011)))
(if (< (current-seconds) endtime)
(loop))))
(print "Client " cname " all done!!")
|
Deleted testzmq/mockupclientlib.scm version [1577031d21].
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
55
56
57
58
59
60
61
62
63
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(define sub (make-socket 'sub))
(define push (make-socket 'push))
(socket-option-set! sub 'subscribe cname)
(socket-option-set! sub 'hwm 1000)
(socket-option-set! push 'hwm 1000)
(connect-socket sub "tcp://localhost:6563")
(connect-socket push "tcp://localhost:6564")
(thread-sleep! 0.2)
(define (server-ping cname timeout)
(let ((msg (conc cname ":ping:" timeout))
(maxtime (+ (current-seconds) timeout)))
(print "pinging server from " cname " with timeout " timeout)
(let loop ((res #f))
(if (< maxtime (current-seconds))
#f ;; failed to ping
(if (equal? res "Got ping")
#t
(begin
(print "Ping received from server " res)
(send-message push msg)
(thread-sleep! 0.1)
(loop (receive-message sub non-blocking: #t))))))))
(define (dbaccess cname cmd var val #!key (numtries 20))
(let* ((msg (conc cname ":" cmd ":" (if val (conc var " " val) var)))
(res #f)
(mtx1 (make-mutex))
(do-access (lambda ()
(let ((tmpres #f))
(print "Sending msg: " msg)
(send-message push msg)
(print "Message " msg " sent")
(print "Client " cname " waiting for response to " msg)
(print "Client " cname " received address " (receive-message* sub))
(set! tmpres (receive-message* sub))
(mutex-lock! mtx1)
(set! res tmpres)
(mutex-unlock! mtx1))))
(th1 (make-thread do-access "do access"))
(th2 (make-thread (lambda ()
(let ((result #f))
(mutex-lock! mtx1)
(set! result res)
(mutex-unlock! mtx1)
(thread-sleep! 5)
(if (not result)
(if (> numtries 0)
(begin
(print "WARNING: access timed out for " cname ", trying again. Trys remaining=" numtries)
(dbaccess cname cmd var val numtries: (- numtries 1)))
(begin
(print "ERROR: dbaccess timed out. Exiting")
(exit)))))
"timeout thread"))))
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(if res (print "SUCCESS: received " res " with " numtries " remaining possible attempts"))
res))
|
Deleted testzmq/mockupserver.scm version [f130435054].
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
55
56
57
58
59
60
61
62
63
64
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; pub/sub with envelope address
;; Note that if you don't insert a sleep, the server will crash with SIGPIPE as soon
;; as a client disconnects. Also a remaining client may receive tons of
;; messages afterward.
(use zmq srfi-18 sqlite3 numbers)
(define pub (make-socket 'pub))
(define pull (make-socket 'pull))
(define cname "server")
(define total-db-accesses 0)
(define start-time (current-seconds))
(socket-option-set! pub 'hwm 1000)
(socket-option-set! pull 'hwm 1000)
(bind-socket pub "tcp://*:6563")
(bind-socket pull "tcp://*:6564")
(thread-sleep! 0.2)
(define (open-db)
(let* ((dbpath "mockup.db")
(dbexists (file-exists? dbpath))
(db (open-database dbpath)) ;; (never-give-up-open-db dbpath))
(handler (make-busy-timeout 10)))
(set-busy-handler! db handler)
(if (not dbexists)
(for-each
(lambda (stmt)
(execute db stmt))
(list
"PRAGMA SYNCHRONOUS=0;"
"CREATE TABLE clients (id INTEGER PRIMARY KEY,name TEXT,num_accesses INTEGER DEFAULT 0);"
"CREATE TABLE vars (var TEXT,val TEXT,CONSTRAINT vars_constraint UNIQUE (var));")))
db))
(define cid-cache (make-hash-table))
(define (get-client-id db cname)
(let ((cid (hash-table-ref/default cid-cache cname #f)))
(if cid
cid
(begin
(execute db "INSERT OR REPLACE INTO clients (name) VALUES(?);" cname)
(for-each-row
(lambda (id)
(set! cid id))
db
"SELECT id FROM clients WHERE name=?;" cname)
(hash-table-set! cid-cache cname cid)
(set! total-db-accesses (+ total-db-accesses 2))
cid))))
(define (count-client db cname)
(let ((cid (get-client-id db cname)))
(execute db "UPDATE clients SET num_accesses=num_accesses+1 WHERE id=?;" cid)
(set! total-db-accesses (+ total-db-accesses 1))
))
(define db (open-db))
;; (define queuelst '())
;; (define mx1 (make-mutex))
(define max-queue-len 0)
(define (process-queue queuelst)
(let ((queuelen (length queuelst)))
(if (> queuelen max-queue-len)
(set! max-queue-len queuelen))
(for-each
(lambda (item)
(let ((cname (vector-ref item 1))
(clcmd (vector-ref item 2))
(cdata (vector-ref item 3)))
(send-message pub cname send-more: #t)
(send-message pub (case clcmd
((sync)
(conc queuelen))
((set)
(set! total-db-accesses (+ total-db-accesses 1))
(apply execute db "INSERT OR REPLACE INTO vars (var,val) VALUES (?,?);" (string-split cdata))
"ok")
((get)
(set! total-db-accesses (+ total-db-accesses 1))
(let ((res "noval"))
(for-each-row
(lambda (val)
(set! res val))
db
"SELECT val FROM vars WHERE var=?;" cdata)
res))
(else (conc "unk cmd: " clcmd))))))
queuelst)))
;; SERVER THREAD
(define th1 (make-thread
(lambda ()
(let ((last-run 0)) ;; current-seconds when run last
(let loop ((queuelst '()))
(let* ((indat (receive-message* pull))
(parts (string-split indat ":"))
(cname (car parts)) ;; client name
(clcmd (string->symbol (cadr parts))) ;; client cmd
(cdata (caddr parts)) ;; client data
(svect (vector (current-seconds) cname clcmd cdata))) ;; record for the queue
;; (print "Server received message: " indat)
(count-client db cname)
(case clcmd
((ping)
(print "Got ping from " cname)
(send-message pub cname send-more: #t)
(send-message pub "Got ping")
(loop queuelst))
((sync) ;; just process the queue
(print "Got sync from " cname)
(process-queue (cons svect queuelst))
(loop '()))
((get)
(process-queue (cons svect queuelst))
(loop '()))
(else
(loop (cons svect queuelst))))))))
"server thread"))
(include "mockupclientlib.scm")
;; SYNC THREAD
;; send a sync to the pull port
(define th2 (make-thread
(lambda ()
(let ((last-action-time (current-seconds)))
(let loop ()
(thread-sleep! 5)
(let ((queuelen (string->number (dbaccess "server" 'sync "nada" #f)))
(last-action-delta #f))
(if (> queuelen 1)(set! last-action-time (current-seconds)))
(set! last-action-delta (- (current-seconds) last-action-time))
(print "Server: Got queuelen=" queuelen ", last-action-delta=" last-action-delta)
(if (< last-action-delta 60)
(loop)
(print "Server exiting, 25 seconds since last access"))))))
"sync thread"))
(thread-start! th1)
(thread-start! th2)
(thread-join! th2)
(let* ((run-time (- (current-seconds) start-time))
(queries/second (/ total-db-accesses run-time)))
(print "Server exited! Total db accesses=" total-db-accesses " in " run-time " seconds for " queries/second " queries/second with max queue length of: " max-queue-len))
|
Deleted testzmq/random.scm version [7090f9f44f].
1
2
3
4
5
6
7
8
|
|
-
-
-
-
-
-
-
-
|
(use posix numbers)
(randomize (inexact->exact (current-seconds)))
(define low (string->number (cadr (argv))))
(define hi (string->number (caddr (argv))))
(print (+ low (random (- hi low))))
|
Deleted testzmq/testmockup.sh version [8905872c25].
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
#!/bin/bash
rm -f mockup.db
echo Compiling mockupserver.scm and mockupclient.scm
# Clean up first
killall mockupserver mockupclient -v
csc random.scm
csc mockupserver.scm
csc mockupclient.scm
echo Starting server
./mockupserver &
sleep 1
rm -f mockupclients.log
echo Starting clients
for i in a b c d e f g h i j k l m n o p q s t u v w x y z;
do
for k in a b;
do
for j in 0 1 2 3 4 5 6 7 8 9;
do
waittime=`./random 0 60`
runtime=`./random 5 120`
echo "Starting client $i$k$j with waittime $waittime and runtime $runtime"
(sleep $waittime;./mockupclient $i$k$j $runtime) &
# >> mockupclients.log &
done
done
done
wait
echo testmockup.sh script done
# echo "Waiting for 5 seconds then killing all mockupserver and mockupclient processes"
# sleep 30
# killall -v mockupserver mockupclient
|
