This is equivalent to a diff from
6ce4b508b6
to 559228be40
Modified Makefile
from [2775c16066]
to [26b6092a78].
| ︙ | | |
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
+
+
+
+
|
$(PREFIX)/bin/nbfake : utils/nbfake
$(INSTALL) $< $@
chmod a+x $@
$(PREFIX)/bin/nbfind : utils/nbfind
$(INSTALL) $< $@
chmod a+x $@
$(PREFIX)/bin/loadrunner : utils/loadrunner
$(INSTALL) $< $@
chmod a+x $@
$(PREFIX)/bin/refdb : refdb
$(INSTALL) $< $@
chmod a+x $@
deploytarg/nbfake : utils/nbfake
$(INSTALL) $< $@
|
| ︙ | | |
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
-
+
|
# install dashboard as dboard so wrapper script can be called dashboard
$(PREFIX)/bin/dboard : dboard $(FILES)
$(INSTALL) dboard $(PREFIX)/bin/dboard
utils/mk_wrapper $(PREFIX) dboard > $(PREFIX)/bin/dashboard
chmod a+x $(PREFIX)/bin/dashboard
install : bin $(PREFIX)/bin/mtest $(PREFIX)/bin/megatest $(PREFIX)/bin/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
$(PREFIX)/bin/nbfind $(PREFIX)/bin/newdboard $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm $(PREFIX)/bin/revtagfsl
$(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/newdboard $(PREFIX)/bin/refdb $(PREFIX)/bin/mt_xterm $(PREFIX)/bin/revtagfsl
deploytarg/apropos.so : Makefile
for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \
chicken-install -prefix deploytarg -deploy $$i;done
deploytarg/libsqlite3.so :
CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3
|
| ︙ | | |
Modified TODO
from [61ddd55e7d]
to [249cc9a526].
1
2
3
4
|
1
2
3
4
5
6
7
8
9
10
11
12
|
+
+
-
-
-
+
+
+
+
+
+
+
+
+
|
TODO
====
1. Confirm that branch transaction-for-sequential-writes content was added to trunk/development
2. Add a host chooser for ssh to launch-tests
3. Try making static executable
|
Modified api.scm
from [a5a1f9f0f0]
to [d466f290aa].
| ︙ | | |
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
|
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
|
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
((set-tests-state-status) (apply db:set-tests-state-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-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
((get-run-name-from-id) (apply db:get-run-name-from-id dbstruct params))
((delete-run) (apply db:delete-run dbstruct params))
((get-runs) (apply db:get-runs dbstruct params))
((get-all-run-ids) (db:get-all-run-ids dbstruct))
((get-runs-by-patt) (apply db:get-runs-by-patt dbstruct params))
((lock/unlock-run) (apply db:lock/unlock-run dbstruct params))
((update-run-event_time) (apply db:update-run-event_time 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))
((get-steps-data) (apply db:get-steps-data dbstruct params))
;; MISC
((login) (apply db:login dbstruct params))
((general-call) (let ((stmtname (car params))
(run-id (cadr params))
(realparams (cddr params)))
(db:with-db dbstruct run-id #t ;; these are all for modifying the db
(lambda (db)
(db:general-call db stmtname realparams)))))
((sync-inmem->db) (db:sync-touched dbstruct force-sync: #t))
((kill-server)
(db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*) ;; (db:sync-to *inmemdb* *db*)
(let ((hostname (car *runremote*))
(port (cadr *runremote*))
(pid (if (null? params) #f (car params)))
(th1 (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread")))
(debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
(debug:print-info 1 "current pid=" (current-process-id))
(open-run-close tasks:server-deregister tasks:open-db
hostname
port: port)
(set! *server-run* #f)
(thread-sleep! 3)
(if pid
(process-signal pid signal/kill)
(thread-start! th1))
'(#t "exit process started")))
((sync-inmem->db) (db:sync-touched dbstruct run-id force-sync: #t))
;; ((kill-server)
;; (db:sync-tables (db:tbls *inmemdb*) *inmemdb* *db*) ;; (db:sync-to *inmemdb* *db*)
;; (let ((hostname (car *runremote*))
;; (port (cadr *runremote*))
;; (pid (if (null? params) #f (car params)))
;; (th1 (make-thread (lambda ()(thread-sleep! 3)(debug:print 0 "Server exiting!")(exit 0)) "Server exit thread")))
;; (debug:print 0 "WARNING: Server on " hostname ":" port " going down by user request!")
;; (debug:print-info 1 "current pid=" (current-process-id))
;; (open-run-close tasks:server-deregister tasks:open-db
;; hostname
;; port: port)
;; (set! *server-run* #f)
;; (thread-sleep! 3)
;; (if pid
;; (process-signal pid signal/kill)
;; (thread-start! th1))
;; '(#t "exit process started")))
((sdb-qry) (apply sdb:qry params))
;; TESTMETA
((testmeta-get-record) (apply db:testmeta-get-record dbstruct params))
((testmeta-add-record) (apply db:testmeta-add-record dbstruct params))
((testmeta-update-field) (apply db:testmeta-update-field dbstruct params))
(else
|
| ︙ | | |
Modified client.scm
from [83cf5c7402]
to [d859fde28d].
| ︙ | | |
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
|
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
|
-
+
-
+
-
-
-
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
+
+
+
+
+
|
;;
;; There are two scenarios.
;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline
;; 2. We are a run tests, list runs or other interactive process and we must figure out
;; *transport-type* and *runremote* from the monitor.db
;;
;; client:setup
(define (client:setup #!key (numtries 3))
(define (client:setup run-id #!key (remaining-tries 3))
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: failed to find megatest.config, exiting")
(exit))))
(push-directory *toppath*) ;; This is probably NOT needed
;; (push-directory *toppath*) ;; This is probably NOT needed
;; clients get the sdb:qry proc created here
;; (if (not sdb:qry)
;; (begin
;; (set! sdb:qry (make-sdb:qry (conc *toppath* "/db/strings.db"))) ;; we open the normalization helpers here
;; (sdb:qry 'setup #f)))
(debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*)
(let* ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(let ((hostinfo (and run-id (hash-table-ref/default *runremote* run-id #f))))
(debug:print-info 11 "for run-id=" run-id ", *transport-type* is " *transport-type*)
(if hostinfo
hostinfo ;; have hostinfo - just return it
(let* ((hostinfo (open-run-close tasks:get-server tasks:open-db run-id))
(debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo)
(set! *transport-type* (if hostinfo
(string->symbol (tasks:hostinfo-get-transport hostinfo))
'fs))
(debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) ""))
(case *transport-type*
;; ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db))))
((http)
(http-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
(tasks:hostinfo-get-port hostinfo)))
((zmq)
(zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo)
(tasks:hostinfo-get-port hostinfo)
(tasks:hostinfo-get-pubport hostinfo)))
(else ;; default to fs
(debug:print 0 "ERROR: unrecognised transport type " *transport-type* " exiting now.")
(exit)))
(pop-directory)))
(define (client:launch)
(define (client:launch run-id)
(set-signal-handler! signal/int client:signal-handler)
(if (client:setup)
(debug:print-info 2 "connected as client")
(begin
(debug:print 0 "ERROR: Failed to connect as client")
(exit))))
|
Modified common.scm
from [a28c1ed00f]
to [8ec6f3bb49].
| ︙ | | |
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
|
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
|
-
+
-
+
+
|
(define *passnum* 0) ;; when running track calls to run-tests or similar
;; DATABASE
(define *open-dbs* (vector #f (make-hash-table))) ;; megatestdb run-id-dbs
;; SERVER
(define *my-client-signature* #f)
(define *transport-type* 'fs)
(define *transport-type* 'http)
(define *megatest-db* #f)
(define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port
(define *runremote* #f) ;; if set up for server communication this will hold <host port>
(define *runremote* (make-hash-table)) ;; if set up for server communication this will hold <host port>
(define *last-db-access* (current-seconds)) ;; update when db is accessed via server
(define *max-cache-size* 0)
(define *logged-in-clients* (make-hash-table))
(define *client-non-blocking-mode* #f)
(define *server-id* #f)
(define *server-info* #f)
(define *time-to-exit* #f)
(define *received-response* #f)
(define *default-numtries* 10)
(define *server-run* #t)
(define *db-write-access* #t)
(define *inmemdb* #f)
(define *run-id* #f)
(define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN
(define *keys* (make-hash-table)) ;; cache the keys here
(define *keyvals* (make-hash-table))
(define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here
(define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here
(define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id
|
| ︙ | | |
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
|
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
|
-
+
|
(uname #f))
(if (null? (car uname-res))
"unknown"
(caar uname-res))))
(define (save-environment-as-files fname #!key (ignorevars (list "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR")))
(let ((envvars (get-environment-variables))
(whitesp (regexp "[^a-zA-Z0-9_\\-:;,.\\/%$]")))
(whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")))
(with-output-to-file (conc fname ".csh")
(lambda ()
(for-each (lambda (key)
(if (not (member key ignorevars))
(let* ((val (cdr key))
(sval (if (string-search whitesp val)(conc "\"" val "\"") val)))
(print "setenv " (car key) " " sval))))
|
| ︙ | | |
Modified dashboard-tests.scm
from [78c574598f]
to [0f843da842].
| ︙ | | |
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
-
-
+
+
+
+
+
+
+
+
|
(db:test-get-status testdat))))
(iup:attribute-set! lbl "TITLE" (db:test-get-status testdat)))))))
lbl)
(store-label "testcomment"
(iup:label "TestComment "
#:expand "HORIZONTAL")
(lambda (testdat)
;; (sdb:qry 'getstr
(db:test-get-comment testdat))) ;; )
|
| ︙ | | |
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
-
+
|
;;======================================================================
;; Run info panel
;;======================================================================
(define (run-info-panel db keydat testdat runname)
(let* ((run-id (db:test-get-run_id testdat))
(rundat (db:get-run-info db run-id))
(header (db:get-header rundat))
(event_time (db:get-value-by-header (db:get-row rundat)
(event_time (db:get-value-by-header (db:get-rows rundat)
(db:get-header rundat)
"event_time")))
(iup:frame
#:title "Megatest Run Info" ; #:expand "YES"
(iup:hbox ; #:expand "YES"
(apply iup:vbox ; #:expand "YES"
(append (map (lambda (keyval)
|
| ︙ | | |
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
|
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
|
+
-
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
|
(let* ((state (db:test-get-state testdat))
(status (db:test-get-status testdat))
(color (car (gutils:get-color-for-state-status state status))))
((vector-ref *state-status* 0) state color)
((vector-ref *state-status* 1) status color)))
(define *dashboard-test-db* #t)
(define *dashboard-comment-share-slot* #f)
;;======================================================================
;; Set fields
;;======================================================================
(define (set-fields-panel dbstruct run-id test-id testdat #!key (db #f))
(let ((newcomment #f)
(newstatus #f)
(newstate #f))
(newstate #f)
(wtxtbox #f))
(iup:frame
#:title "Set fields"
(iup:vbox
(iup:hbox (iup:label "Comment:")
(iup:textbox #:action (lambda (val a b)
(rmt:test-set-state-status-by-id run-id test-id #f #f b)
;; IDEA: Just set a variable with the proc to call?
(set! newcomment b))
#:value (db:test-get-comment testdat)
#:expand "HORIZONTAL"))
(let ((txtbox (iup:textbox #:action (lambda (val a b)
(rmt:test-set-state-status-by-id run-id test-id #f #f b)
;; IDEA: Just set a variable with the proc to call?
(rmt:test-set-state-status-by-id run-id test-id #f #f b)
(set! newcomment b))
#:value (db:test-get-comment testdat)
#:expand "HORIZONTAL")))
(set! wtxtbox txtbox)
txtbox))
(apply iup:hbox
(iup:label "STATE:" #:size "30x")
(let* ((btns (map (lambda (state)
(let ((btn (iup:button state
#:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
#:action (lambda (x)
(rmt:test-set-state-status-by-id run-id test-id state #f #f)
|
| ︙ | | |
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
|
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
|
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
|
(iup:label "STATUS:" #:size "30x")
(let* ((btns (map (lambda (status)
(let ((btn (iup:button status
#:expand "HORIZONTAL" #:size "50x" #:font "Courier New, -10"
#:action (lambda (x)
(let ((t (iup:attribute x "TITLE")))
(if (equal? t "WAIVED")
(iup:show (dashboard-tests:waiver testdat (lambda (c)
(set! newcomment c))))
(begin
(open-run-close db:test-set-state-status-by-id db test-id #f status #f)
(iup:show (dashboard-tests:waiver testdat
(if wtxtbox (iup:attribute wtxtbox "VALUE") #f)
(lambda (c)
(set! newcomment c)
(if wtxtbox
(begin
(iup:attribute-set! wtxtbox "VALUE" c)
(if (not *dashboard-comment-share-slot*)
(set! *dashboard-comment-share-slot* wtxtbox)))
))))
(begin
(rmt:test-set-state-status-by-id run-id test-id #f status #f)
(db:test-set-status! testdat status))))))))
btn))
(map cadr *common:std-statuses*)))) ;; (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVED" "SKIP"))))
(vector-set! *state-status* 1
(lambda (status color)
(for-each
(lambda (btn)
|
| ︙ | | |
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
|
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
|
-
+
-
+
|
(conc "ezstep run from step " stepname)))))
;; (iup:button "Refresh test data"
;; #:expand "HORIZONTAL"
;; #:action (lambda (obj)
;; (print "Refresh test data " stepname))
)))
(define (dashboard-tests:waiver testdat cmtcmd)
(define (dashboard-tests:waiver testdat ovrdval cmtcmd)
(let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt"))
(wregx (if (string? wpatt)(regexp wpatt) #f))
(wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) "")))
(comnt (iup:textbox #:action (lambda (val a b)
(if wpatt
(if (string-match wregx b)
(iup:attribute-set! wmesg "TITLE" (conc "Comment matches " wpatt))
(iup:attribute-set! wmesg "TITLE" (conc "Comment does not match " wpatt))
)))
#:value (db:test-get-comment testdat)
#:value (if ovrdval ovrdval (db:test-get-comment testdat))
#:expand "HORIZONTAL"))
(dlog #f))
(set! dlog (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES"
#:title "SET WAIVER"
(iup:vbox ; #:expand "YES"
(iup:label (conc "Enter justification for waiving test "
(db:test-get-testname testdat)
|
| ︙ | | |
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
|
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
|
-
+
|
#:expand "HORIZONTAL"
#:action (lambda (obj)
(let ((comment (iup:attribute comnt "VALUE"))
(test-id (db:test-get-id testdat)))
(if (or (not wpatt)
(string-match wregx comment))
(begin
(open-run-close db:test-set-state-status-by-id #f test-id #f "WAIVED" comment)
(rmt:test-set-state-status-by-id run-id test-id #f "WAIVED" comment)
(db:test-set-status! testdat "WAIVED")
(cmtcmd comment)
(iup:destroy! dlog))))))
(iup:button "Cancel"
#:expand "HORIZONTAL"
#:action (lambda (obj)
(iup:destroy! dlog)))))))
|
| ︙ | | |
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
|
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
|
-
+
|
(if (not testdat)
(begin
(debug:print 2 "ERROR: No test data found for test " test-id ", exiting")
(exit 1))
(let* (;; (run-id (if testdat (db:test-get-run_id testdat) #f))
(keydat (if testdat (db:get-key-val-pairs dbstruct run-id) #f))
(rundat (if testdat (db:get-run-info dbstruct run-id) #f))
(runname (if testdat (db:get-value-by-header (db:get-row rundat)
(runname (if testdat (db:get-value-by-header (db:get-rows rundat)
(db:get-header rundat)
"runname") #f))
(tdb (tdb:open-test-db-by-test-id-local dbstruct run-id test-id))
;; These next two are intentional bad values to ensure errors if they should not
;; get filled in properly.
(logfile "/this/dir/better/not/exist")
(rundir logfile)
|
| ︙ | | |
Modified dashboard.scm
from [7a92ca5dd5]
to [420ddf64af].
| ︙ | | |
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
-
+
|
(include "db_records.scm")
(include "run_records.scm")
(include "megatest-fossil-hash.scm")
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2013
license GPL, Copyright (C) Matt Welland 2012-2014
Usage: dashboard [options]
-h : this help
-server host:port : connect to host:port instead of db access
-test run-id,test-id : control test identified by testid
-guimonitor : control panel for runs
|
| ︙ | | |
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
|
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
|
-
+
-
-
+
+
-
+
-
+
-
-
+
+
|
(exit)))
(if (not (setup-for-run))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
(define *db* (make-dbr:dbstruct path: *toppath* local: #t))
(define *dbstruct-local* (make-dbr:dbstruct path: *toppath* local: #t))
;; (define sdb:qry (make-sdb:qry)) ;; 'init #f)
;; (if (args:get-arg "-host")
;; (begin
;; (set! *runremote* (string-split (args:get-arg "-host" ":")))
;; (client:launch))
;; (if (not (args:get-arg "-use-server"))
;; (set! *transport-type* 'fs) ;; force fs access
;; (client:launch)))
;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db"))))
;; (client:setup *db*)
(define *read-only* (not (file-read-access? (conc *toppath* "db/main.db"))))
;; (client:setup *dbstruct-local*)
(define toplevel #f)
(define dlg #f)
(define max-test-num 0)
(define *keys* (db:get-keys *db*))
(define *keys* (db:get-keys *dbstruct-local*))
;; (define *keys* (cdb:remote-run db:get-keys #f))
;; (define *keys* (db:get-keys *db*))
;; (define *keys* (db:get-keys *dbstruct-local*))
(define *dbkeys* (append *keys* (list "runname")))
(define *header* #f)
(define *allruns* '())
(define *allruns-by-id* (make-hash-table)) ;;
(define *runchangerate* (make-hash-table))
(define *buttondat* (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts* (make-hash-table))
(define *num-runs* 8)
(define *tot-run-count* (db:get-num-runs *db* "%"))
;; (define *tot-run-count* (db:get-num-runs *db* "%"))
(define *tot-run-count* (db:get-num-runs *dbstruct-local* "%"))
;; (define *tot-run-count* (db:get-num-runs *dbstruct-local* "%"))
;; Update management
;;
(define *last-update* (current-seconds))
(define *last-db-update-time* 0)
(define *please-update-buttons* #t)
(define *delayed-update* 0)
|
| ︙ | | |
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
|
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
|
-
+
-
+
-
+
|
(c2 (map string->number (string-split color2)))
(delta (map (lambda (a b)(abs (- a b))) c1 c2)))
(null? (filter (lambda (x)(> x 3)) delta))))
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
(define (update-rundat runnamepatt numruns testnamepatt keypatts)
(let* ((referenced-run-ids '())
(allruns (db:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
(allruns (db:get-runs *dbstruct-local* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
*start-run-offset* keypatts))
(header (db:get-header allruns))
(runs (db:get-rows allruns))
(result '())
(maxtests 0)
(states (hash-table-keys *state-ignore-hash*))
(statuses (hash-table-keys *status-ignore-hash*))
(sort-info (get-curr-sort))
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
(bubble-type (if (member sort-order '(testname))
'testname
'itempath)))
;;
;; trim runs to only those that are changing often here
;;
(for-each (lambda (run)
(let* ((run-id (db:get-value-by-header run header "id"))
(tests (db:get-tests-for-run *db* run-id testnamepatt states statuses
(tests (db:get-tests-for-run *dbstruct-local* run-id testnamepatt states statuses
#f #f
*hide-not-hide*
sort-by
sort-order
'shortlist))
;; NOTE: bubble-up also sets the global *all-item-test-names*
;; (tests (bubble-up tmptests priority: bubble-type))
(key-vals (db:get-key-vals *db* run-id)))
(key-vals (db:get-key-vals *dbstruct-local* run-id)))
;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals)
;; Not sure this is needed?
(set! referenced-run-ids (cons run-id referenced-run-ids))
(if (> (length tests) maxtests)
(set! maxtests (length tests)))
(if (or (not *hide-empty-runs*) ;; this reduces the data burden when set
|
| ︙ | | |
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
|
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
|
-
+
|
(if (not (null? values))
(let ((newval (car values)))
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector key-lbs #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
(db-target-dat (db:get-targets *db*))
(db-target-dat (db:get-targets *dbstruct-local*))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(all-targets (append db-targets
(map (lambda (x)
(list->vector
(take (append (string-split x "/")
(make-list (length header) "na"))
|
| ︙ | | |
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
|
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
|
-
+
|
#:dropdown "YES"
#:action (lambda (obj val index lbstate)
(iup:attribute-set! tb "VALUE" val)
(dboard:data-set-run-name! *data* val)
(dashboard:update-run-command))))
(refresh-runs-list (lambda ()
(let* ((target (dboard:data-get-target-string *data*))
(runs-for-targ (db:get-runs-by-patt *db* *keys* "%" target #f #f))
(runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f))
(runs-header (vector-ref runs-for-targ 0))
(runs-dat (vector-ref runs-for-targ 1))
(run-names (cons default-run-name
(map (lambda (x)
(db:get-value-by-header x runs-header "runname"))
runs-dat))))
(iup:attribute-set! lb "REMOVEITEM" "ALL")
|
| ︙ | | |
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
|
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
|
-
+
|
(let ((hideit (iup:button "HideTests" #:action (lambda (obj)
(set! *hide-not-hide* (not *hide-not-hide*))
(iup:attribute-set! obj "TITLE" (if *hide-not-hide* "HideTests" "NotHide"))
(mark-for-update)))))
(set! *hide-not-hide-button* hideit)
hideit))
(iup:hbox
(iup:button "Quit" #:action (lambda (obj)(if *db* (db:close-all *db*))(exit)))
(iup:button "Quit" #:action (lambda (obj)(if *dbstruct-local* (db:close-all *dbstruct-local*))(exit)))
(iup:button "Refresh" #:action (lambda (obj)
(mark-for-update)))
(iup:button "Collapse" #:action (lambda (obj)
(let ((myname (iup:attribute obj "TITLE")))
(if (equal? myname "Collapse")
(begin
(for-each (lambda (tname)
|
| ︙ | | |
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
|
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
|
+
+
+
+
+
-
+
|
(define *monitor-db-path* (conc *toppath* "/db/monitor.db"))
(define *last-monitor-update-time* 0)
;; Force creation of the db in case it isn't already there.
(let ((db (tasks:open-db)))
(sqlite3:finalize! db))
(define (dashboard:get-youngest-run-db-mod-time)
(apply max (map (lambda (filen)
(file-modification-time filen))
(glob (conc *toppath* "/db/*.db")))))
(define (dashboard:run-update x)
(let* ((modtime (file-modification-time *db-file-path*))
(let* ((modtime (dashboard:get-youngest-run-db-mod-time)) ;; (file-modification-time *db-file-path*))
(monitor-modtime (file-modification-time *monitor-db-path*))
(run-update-time (current-seconds))
(recalc (dashboard:recalc modtime *please-update-buttons* *last-db-update-time*)))
(if (and (eq? *current-tab-number* 0)
(> monitor-modtime *last-monitor-update-time*))
(begin
(set! *last-monitor-update-time* monitor-modtime)
|
| ︙ | | |
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
|
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
|
-
-
+
+
-
+
-
+
-
+
|
(cond
((args:get-arg "-run")
(let ((runid (string->number (args:get-arg "-run"))))
(if runid
(begin
(lambda (x)
(on-exit (lambda ()
(if *db* (db:close-all *db*))))
(examine-run *db* runid)))
(if *dbstruct-local* (db:close-all *dbstruct-local*))))
(examine-run *dbstruct-local* runid)))
(begin
(print "ERROR: runid is not a number " (args:get-arg "-run"))
(exit 1)))))
((args:get-arg "-test") ;; run-id,test-id
(let* ((dat (map string->number (string-split (args:get-arg "-test") ",")))
(run-id (car dat))
(test-id (cadr dat)))
(if (and (number? run-id)
(number? test-id)
(>= test-id 0))
(examine-test run-id test-id)
(begin
(debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test"))
(exit 1)))))
((args:get-arg "-guimonitor")
(gui-monitor *db*))
(gui-monitor *dbstruct-local*))
(else
(set! uidat (make-dashboard-buttons *db* *num-runs* *num-tests* *dbkeys*))
(set! uidat (make-dashboard-buttons *dbstruct-local* *num-runs* *num-tests* *dbkeys*))
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (x)
(let ((update-is-running #f))
(mutex-lock! *update-mutex*)
(set! update-is-running *update-is-running*)
(if (not update-is-running)
(set! *update-is-running* #t))
(mutex-unlock! *update-mutex*)
(if (not update-is-running)
(begin
(dashboard:run-update x)
(mutex-lock! *update-mutex*)
(set! *update-is-running* #f)
(mutex-unlock! *update-mutex*))))
1))))
(iup:main-loop)
(db:close-all *db*)
(db:close-all *dbstruct-local*)
|
Modified db.scm
from [2818f0f5b2]
to [42d3ed003f].
| ︙ | | |
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
-
-
-
+
+
+
|
;; 'read read data
;;
(define (db:done-with dbstruct run-id mod-read)
(if (not (sqlite3:database? dbstruct))
(begin
(mutex-lock! *rundb-mutex*)
(if (eq? mod-read 'mod)
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'mtime (current-milliseconds))
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'rtime (current-milliseconds)))
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'inuse #f)
(dbr:dbstruct-set-mtime! dbstruct (current-milliseconds))
(dbr:dbstruct-set-rtime! dbstruct (current-milliseconds)))
(dbr:dbstruct-set-inuse! dbstruct #f)
(mutex-unlock! *rundb-mutex*))))
;; (db:with-db dbstruct run-id sqlite3:exec "select blah from blaz;")
;; r/w is a flag to indicate if the db is modified by this query #t = yes, #f = no
;;
(define (db:with-db dbstruct run-id r/w proc . params)
(let* ((db (db:get-db dbstruct run-id)))
|
| ︙ | | |
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
|
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
|
+
+
+
-
+
-
-
+
+
-
-
-
+
+
+
-
+
-
+
+
+
|
;; (define (db:get-path dbstruct id)
;; (let ((fdb (db:get-filedb dbstruct)))
;; (filedb:get-path db id)))
;; This routine creates the db. It is only called if the db is not already opened
;;
(define (db:open-rundb dbstruct run-id) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let* ((local (dbr:dbstruct-get-local dbstruct))
(rdb (if local
(dbr:dbstruct-get-localdb dbstruct run-id)
(let ((rdb (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
(dbr:dbstruct-get-inmem dbstruct)))) ;; (dbr:dbstruct-get-runrec dbstruct run-id 'inmem)))
(if rdb
rdb
(let* ((local (dbr:dbstruct-get-local dbstruct))
(toppath (dbr:dbstruct-get-path dbstruct))
(sqlite3:execute db "PRAGMA synchronous = 0;")))
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'rundb db)
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'inuse #t)
(sqlite3:execute db "PRAGMA synchronous = 1;"))) ;; was 0 but 0 is a gamble
(dbr:dbstruct-set-rundb! dbstruct db)
(dbr:dbstruct-set-inuse! dbstruct #t)
(if local
(begin
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'inmem db) ;; direct access ...
(dbr:dbstruct-set-localdb! dbstruct run-id db) ;; (dbr:dbstruct-set-inmem! dbstruct db) ;; direct access ...
db)
(begin
(dbr:dbstruct-set-runvec-val! dbstruct run-id 'inmem inmem)
(dbr:dbstruct-set-inmem! dbstruct inmem)
(db:sync-tables db:sync-tests-only db inmem)
(dbr:dbstruct-set-refdb! dbstruct refdb)
(db:sync-tables db:sync-tests-only db refdb)
inmem))))))
;; This routine creates the db. It is only called if the db is not already opened
;;
(define (db:open-main dbstruct) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
(let ((mdb (dbr:dbstruct-get-main dbstruct)))
(if mdb
|
| ︙ | | |
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
|
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
-
+
-
-
-
-
-
-
-
-
-
-
|
(if (not dbexists)
(db:initialize-main-db db))
(dbr:dbstruct-set-main! dbstruct db)
db))))
;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
(define (db:setup #!key (local #f))
(define (db:setup run-id #!key (local #f))
(let ((dbstruct (make-dbr:dbstruct path: *toppath* local: local)))
(db:get-db dbstruct #f) ;; force one call to main
;; (if (not sdb:qry)
;; (begin
;; (set! sdb:qry (make-sdb:qry (conc *toppath* "/db/strings.db"))) ;; we open the normalization helpers here
;; (sdb:qry 'setup #f)
;; ;; Initialize with some known needed strings, NOTE: set this up to only execute on first db initialization
;; (for-each
;; (lambda (str)
;; (sdb:qry 'get-id str))
;; (list "" "logs/final.log"))))
;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
|
| ︙ | | |
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
|
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
|
+
-
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
-
-
-
-
|
(if (not dbexists)
(begin
(db:initialize-main-db db)
(db:initialize-run-id-db db)))
db))
;; sync all touched runs to disk
;;
(define (db:sync-touched dbstruct #!key (force-sync #f))
(let ((tot-synced 0))
(for-each
(lambda (runvec)
(let ((mtime (vector-ref runvec (dbr:dbstruct-field-name->num 'mtime)))
(stime (vector-ref runvec (dbr:dbstruct-field-name->num 'stime)))
(rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb)))
(inmem (vector-ref runvec (dbr:dbstruct-field-name->num 'inmem))))
(inmem (vector-ref runvec (dbr:dbstruct-field-name->num 'inmem)))
(refdb (vector-ref runvec (dbr:dbstruct-field-name->num 'refdb))))
(if (or (> mtime stime) force-sync)
(let ((num-synced (db:sync-tables db:sync-tests-only inmem rundb)))
(let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb)))
(set! tot-synced (+ tot-synced num-synced))
(vector-set! runvec (dbr:dbstruct-field-name->num 'stime) (current-milliseconds))))))
(hash-table-values (vector-ref dbstruct 1)))
tot-synced))
;; sync run to disk if touched
;;
(define (db:sync-touched dbstruct #!key (force-sync #f))
(let ((mtime (dbr:dbstruct-get-mtime dbstruct))
(stime (dbr:dbstruct-get-stime dbstruct))
(rundb (dbr:dbstruct-get-rundb dbstruct))
(inmem (dbr:dbstruct-get-inmem dbstruct))
(refdb (dbr:dbstruct-get-refdb dbstruct)))
(if (or (not (number? mtime))
(not (number? stime))
(> mtime stime)
force-sync)
(let ((num-synced (db:sync-tables db:sync-tests-only inmem refdb rundb)))
(dbr:dbstruct-set-stime! dbstruct (current-milliseconds))
num-synced)
0)))
;; close all opened run-id dbs
(define (db:close-all dbstruct)
;; finalize main.db
(db:sync-touched dbstruct force-sync: #t)
(sqlite3:finalize! (db:get-db dbstruct #f))
(let* ((local (dbr:dbstruct-get-local dbstruct))
(rundb (dbr:dbstruct-get-rundb dbstruct)))
(if local
(for-each
(lambda (runvec)
(let ((rundb (vector-ref runvec (dbr:dbstruct-field-name->num 'rundb))))
(if (sqlite3:database? rundb)
(sqlite3:finalize! rundb)
(debug:print 0 "WARNING: attempting to close databases but got " rundb " instead of a database"))))
(hash-table-values (vector-ref dbstruct 1)))
;; (sdb:qry 'finalize! #f)
)
;; (filedb:finalize-db! *fdb*))
|
| ︙ | | |
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
|
-
+
|
'("iterated" #f)
'("avg_runtime" #f)
'("avg_disk" #f)
'("tags" #f)
'("jobgroup" #f)))))
;; tbls is ( ("tablename" ( "field1" [#f|proc1] ) ( "field2" [#f|proc2] ) .... ) )
(define (db:sync-tables tbls fromdb todb)
(define (db:sync-tables tbls fromdb todb . slave-dbs)
(cond
((not fromdb) (debug:print 0 "ERROR: db:sync-tables called with fromdb missing") -1)
((not todb) (debug:print 0 "ERROR: db:sync-tables called with todb missing") -2)
((not (sqlite3:database? fromdb))
(debug:print 0 "ERROR: db:sync-tables called with fromdb not a database " fromdb) -3)
((not (sqlite3:database? todb))
(debug:print 0 "ERROR: db:sync-tables called with todb not a database " todb) -4)
|
| ︙ | | |
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
|
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
|
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(sqlite3:for-each-row
(lambda (a . b)
(hash-table-set! todat a (apply vector a b)))
todb
full-sel)
;; first pass implementation, just insert all changed rows
(for-each
(lambda (targdb)
(let ((stmth (sqlite3:prepare todb full-ins)))
(sqlite3:with-transaction
todb
(lambda ()
(for-each ;;
(lambda (fromrow)
(let* ((a (vector-ref fromrow 0))
(curr (hash-table-ref/default todat a #f))
(same #t))
(let loop ((i 0))
(if (or (not curr)
(not (equal? (vector-ref fromrow i)(vector-ref curr i))))
(set! same #f))
(if (and same
(< i (- num-fields 1)))
(loop (+ i 1))))
(if (not same)
(begin
(apply sqlite3:execute stmth (vector->list fromrow))
(hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
fromdat)))
(sqlite3:finalize! stmth))))
(let ((stmth (sqlite3:prepare targdb full-ins)))
(sqlite3:with-transaction
targdb
(lambda ()
(for-each ;;
(lambda (fromrow)
(let* ((a (vector-ref fromrow 0))
(curr (hash-table-ref/default todat a #f))
(same #t))
(let loop ((i 0))
(if (or (not curr)
(not (equal? (vector-ref fromrow i)(vector-ref curr i))))
(set! same #f))
(if (and same
(< i (- num-fields 1)))
(loop (+ i 1))))
(if (not same)
(begin
(apply sqlite3:execute stmth (vector->list fromrow))
(hash-table-set! numrecs tablename (+ 1 (hash-table-ref/default numrecs tablename 0)))))))
fromdat)))
(sqlite3:finalize! stmth)))
(append (list todb) slave-dbs))))
tbls)
(let ((runtime (- (current-milliseconds) start-time)))
(debug:print 0 "INFO: db sync, total run time " runtime " ms")
(for-each
(lambda (dat)
(let ((tblname (car dat))
(count (cdr dat)))
|
| ︙ | | |
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
|
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
|
-
+
-
+
+
+
+
+
|
(lambda (key)
(set! res (cons key res)))
(db:get-db dbstruct #f)
"SELECT fieldname FROM keys ORDER BY id DESC;")))
(set! *db-keys* res)
res)))
;;
;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
(debug:print-info 4 "db:get-value-by-header row: " row " header: " header " field: " field)
|
| ︙ | | |
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
|
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
|
-
+
+
+
-
|
(conc fieldname " " wildtype " '" patt "'")))
(if (null? patts)
'("")
patts))
comparator)))
;; register a test run with the db
;; register a test run with the db, this accesses the main.db and does NOT
;; use server api
;;
(define (db:register-run dbstruct keyvals runname state status user)
(debug:print 3 "runs:register-run runname: " runname " state: " state " status: " status " user: " user)
|
| ︙ | | |
933
934
935
936
937
938
939
940
941
942
943
944
945
946
|
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
|
+
+
+
+
+
+
+
+
+
|
(sqlite3:for-each-row
(lambda (count)
(set! numruns count))
(db:get-db dbstruct #f)
"SELECT COUNT(id) FROM runs WHERE runname LIKE ? AND state != 'deleted';" runpatt)
(debug:print-info 11 "db:get-num-runs END " runpatt)
numruns))
(define (db:get-all-run-ids dbstruct)
(let ((run-ids '()))
(sqlite3:for-each-row
(lambda (run-id)
(set! run-ids (cons run-id run-ids)))
(db:get-db dbstruct #f)
"SELECT id FROM runs WHERE state != 'deleted';")
run-ids))
;; get some basic run stats
;;
;; ( (runname (( state count ) ... ))
;; ( ...
(define (db:get-run-stats dbstruct)
(let ((totals (make-hash-table))
|
| ︙ | | |
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
|
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
|
-
+
|
runs-info)
res))
;; db:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; Use: (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;; to extract info from the structure returned
;;
(define (db:get-runs-by-patt dbstruct keys runnamepatt targpatt offset limit) ;; test-name)
(let* ((tmp (runs:get-std-run-fields keys '("id" "runname" "state" "status" "owner" "event_time")))
(keystr (car tmp))
(header (cadr tmp))
(res '())
|
| ︙ | | |
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
|
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
|
-
+
|
(lambda (a . r)
(set! res (cons (list->vector (cons a r)) res)))
(db:get-db dbstruct #f)
qry-str
runnamepatt)))
(vector header res)))
;; use (get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; use (get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
(define (db:get-run-info dbstruct run-id)
;;(if (hash-table-ref/default *run-info-cache* run-id #f)
;; (hash-table-ref *run-info-cache* run-id)
(let* ((res (vector #f #f #f #f))
(keys (db:get-keys dbstruct))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(header (append keys remfields))
|
| ︙ | | |
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
|
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
|
-
+
-
+
+
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
|
((and newstate newstatus)
(sqlite3:execute db "UPDATE tests SET state=?,status=? WHERE id=?;" newstate newstatus test-id))
(else
(if newstate (sqlite3:execute db "UPDATE tests SET state=? WHERE id=?;" newstate test-id))
(if newstatus (sqlite3:execute db "UPDATE tests SET status=? WHERE id=?;" newstatus test-id))
(if newcomment (sqlite3:execute db "UPDATE tests SET comment=? WHERE id=?;" newcomment ;; (sdb:qry 'getid newcomment)
test-id))))
(mt:process-triggers test-id newstate newstatus)))
(mt:process-triggers run-id test-id newstate newstatus)))
;; Never used, but should be?
(define (db:test-set-state-status-by-run-id-testname db run-id test-name item-path status state)
(sqlite3:execute db "UPDATE tests SET state=?,status=?,event_time=strftime('%s','now') WHERE run_id=? AND testname=? AND item_path=?;"
state status run-id test-name item-path))
;; NEW BEHAVIOR: Count tests running in only one run!
;;
(define (db:get-count-tests-running dbstruct run-id)
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
(set! res count))
(db:get-db dbstruct run-id)
"SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART');")
"SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;"
run-id) ;; NOT IN (SELECT id FROM runs WHERE state='deleted');")
res))
;; NEW BEHAVIOR: Look only at single run with run-id
;;
;; (define (db:get-running-stats dbstruct run-id)
(define (db:get-count-tests-running-for-run-id dbstruct run-id)
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
(set! res count))
(db:get-db dbstruct run-id)
"SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND run_id=?;" run-id)
res))
(define (db:get-count-tests-running-in-jobgroup dbstruct run-id jobgroup)
(if (not jobgroup)
0 ;;
(let ((res 0))
(let ((res 0)
(testnames '()))
;; get the testnames
(sqlite3:for-each-row
(lambda (testname)
(set! testnames (cons testname testnames)))
(db:get-db dbstruct #f)
"SELECT testname FROM test_meta WHERE jobgroup=?"
jobgroup)
;; get the jobcount NB// EXTEND THIS TO OPPERATE OVER ALL RUNS?
(if (not (null? testnames))
(sqlite3:for-each-row
(lambda (count)
(set! res count))
(db:get-db dbstruct run-id)
"SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART'
AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?);"
jobgroup)
(lambda (count)
(set! res count))
(db:get-db dbstruct run-id)
(conc "SELECT count(id) FROM tests WHERE state in ('RUNNING','LAUNCHED','REMOTEHOSTSTART') AND testname in ('"
(string-intersperse testnames "','")
"');")))
res)))
;; done with run when:
;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING
(define (db:estimated-tests-remaining dbstruct run-id)
(let ((res 0))
(sqlite3:for-each-row
|
| ︙ | | |
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
|
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
|
-
-
+
+
-
+
|
;; Tests meta data
;;======================================================================
;; read the record given a testname
(define (db:testmeta-get-record dbstruct testname)
(let ((res #f))
(sqlite3:for-each-row
(lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags)
(set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags)))
(lambda (id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)
(set! res (vector id testname author owner description reviewed iterated avg_runtime avg_disk tags jobgroup)))
(db:get-db dbstruct #f)
"SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags FROM test_meta WHERE testname=?;"
"SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta WHERE testname=?;"
testname)
res))
;; create a new record for a given testname
(define (db:testmeta-add-record dbstruct testname)
(sqlite3:execute (db:get-db dbstruct #f) "INSERT OR IGNORE INTO test_meta (testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags) VALUES (?,'','','','','','','','');" testname))
|
| ︙ | | |
Modified db_records.scm
from [832e173195]
to [ee094931e6].
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
|
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
|
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;; dbstruct
;;======================================================================
;;
;; -path-|-megatest.db
;; |-db-|-main.db
;; |-monitor.db
;; |-sdb.db
;; |-fdb.db
;; |-1.db
;; |-<N>.db
(define (make-dbr:dbstruct #!key (path #f)(local #f))
(vector
#f ;; the main db (contains runs, test_meta etc.) NOT CACHED IN MEM
(make-hash-table) ;; run-id => [ rundb inmemdb last-mod last-read last-sync ]
#f ;; the global string db (use for state, status etc.)
path ;; path to database files/megatest area
local)) ;; read-only local access
;; get and set main db
(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0))
(define-inline (dbr:dbstruct-set-main! vec db)(vector-set! vec 0 db))
;; get the runs hash
(define-inline (dbr:dbstruct-get-dbhash vec) (vector-ref vec 1))
;; the string db
(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 2))
(define-inline (dbr:dbstruct-set-strdb! vec db)(vector-set! vec 2 db))
;; path
(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 3))
(define-inline (dbr:dbstruct-set-path! vec path)(vector-set! vec 3))
;; local
(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 4))
(define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 4 val))
;; get a rundb vector, create it if not already existing
(define (dbr:dbstruct-get-rundb-rec vec run-id)
(let* ((dbhash (dbr:dbstruct-get-dbhash vec)) ;; get the runs hash
(runvec (hash-table-ref/default dbhash run-id #f))) ;; get the vector for run-id
(if (vector? runvec)
runvec ;; rundb inmemdb last-mod last-read last-sync in-use
(let ((nvec (vector #f #f -1 -1 -1 #f)))
(hash-table-set! dbhash run-id nvec)
nvec))))
;; [ rundb inmemdb last-mod last-read last-sync ]
(define-inline (dbr:dbstruct-field-name->num field-name)
(case field-name
((rundb) 0) ;; the on-disk db
((inmem) 1) ;; the in-memory db
((mtime) 2) ;; last modification time
((rtime) 3) ;; last read time
((stime) 4) ;; last sync time
((inuse) 5) ;; is the db currently in use, #t yes, #f no.
(else -1)))
;; get/set rundb fields
(define (dbr:dbstruct-get-runvec-val vec run-id field-name)
(let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))
(fieldnum (dbr:dbstruct-field-name->num field-name)))
;; (vector-set! runvec (dbr:dbstruct-field-name->num 'inuse) #t)
(vector-ref runvec fieldnum)))
(define (dbr:dbstruct-set-runvec-val! vec run-id field-name val)
(let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
(vector-set! runvec (dbr:dbstruct-field-name->num field-name) val)))
;; get/set inmemdb
(define (dbr:dbstruct-get-inmemdb vec run-id)
(let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
(vector-ref runvec 1)))
(define (dbr:dbstruct-set-inmemdb! vec run-id inmemdb)
(let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
(vector-set! runvec 1 inmemdb)))
;; ;; get and set main db
;; (define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0))
;; (define-inline (dbr:dbstruct-set-main! vec db)(vector-set! vec 0 db))
;; ;; get the runs hash
;; (define-inline (dbr:dbstruct-get-dbhash vec) (vector-ref vec 1))
;; ;; the string db
;; (define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 2))
;; (define-inline (dbr:dbstruct-set-strdb! vec db)(vector-set! vec 2 db))
;; ;; path
;; (define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 3))
;; (define-inline (dbr:dbstruct-set-path! vec path)(vector-set! vec 3))
;; ;; local
;; (define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 4))
;; (define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 4 val))
;;
;; ;; get a rundb vector, create it if not already existing
;; (define (dbr:dbstruct-get-rundb-rec vec run-id)
;; (let* ((dbhash (dbr:dbstruct-get-dbhash vec)) ;; get the runs hash
;; (runvec (hash-table-ref/default dbhash run-id #f))) ;; get the vector for run-id
;; (if (vector? runvec)
;; runvec ;; rundb inmemdb last-mod last-read last-sync in-use refdb
;; (let ((nvec (vector #f #f -1 -1 -1 #f #f)))
;; (hash-table-set! dbhash run-id nvec)
;; nvec))))
;;
;; ;; [ rundb inmemdb last-mod last-read last-sync ]
;; (define-inline (dbr:dbstruct-field-name->num field-name)
;; (case field-name
;; ((rundb) 0) ;; the on-disk db
;; ((inmem) 1) ;; the in-memory db
;; ((mtime) 2) ;; last modification time
;; ((rtime) 3) ;; last read time
;; ((stime) 4) ;; last sync time
;; ((inuse) 5) ;; is the db currently in use, #t yes, #f no.
;; ((refdb) 6) ;; the db used for reference (can be on disk or inmem)
;; (else -1)))
;;
;; ;; get/set rundb fields
;; (define (dbr:dbstruct-get-runvec-val vec run-id field-name)
;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id))
;; (fieldnum (dbr:dbstruct-field-name->num field-name)))
;; ;; (vector-set! runvec (dbr:dbstruct-field-name->num 'inuse) #t)
;; (vector-ref runvec fieldnum)))
;;
;; (define (dbr:dbstruct-set-runvec-val! vec run-id field-name val)
;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
;; (vector-set! runvec (dbr:dbstruct-field-name->num field-name) val)))
;;
;; ;; get/set inmemdb
;; (define (dbr:dbstruct-get-inmemdb vec run-id)
;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
;; (vector-ref runvec 1)))
;;
;; (define (dbr:dbstruct-set-inmemdb! vec run-id inmemdb)
;; (let ((runvec (dbr:dbstruct-get-rundb-rec vec run-id)))
;; (vector-set! runvec 1 inmemdb)))
(define (make-db:test)(make-vector 20))
(define-inline (db:test-get-id vec) (vector-ref vec 0))
(define-inline (db:test-get-run_id vec) (vector-ref vec 1))
(define-inline (db:test-get-testname vec) (vector-ref vec 2))
(define-inline (db:test-get-state vec) (vector-ref vec 3))
|
| ︙ | | |
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
-
-
-
-
|
(define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
(define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define-inline (db:test-set-state! vec val)(vector-set! vec 3 val))
(define-inline (db:test-set-status! vec val)(vector-set! vec 4 val))
(define-inline (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
(define-inline (db:test-set-final_logf! vec val)(vector-set! vec 13 val))
;; get rows and header from
(define-inline (db:get-header vec)(vector-ref vec 0))
(define-inline (db:get-rows vec)(vector-ref vec 1))
|
| ︙ | | |
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
|
239
240
241
242
243
244
245
246
247
248
249
250
251
252
|
-
-
-
|
(define-inline (tdb:steps-table-get-runtime vec) (vector-ref vec 4))
(define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val))
(define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val))
(define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val))
(define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val))
(define-inline (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val))
;; use this one for db-get-run-info
(define-inline (db:get-row vec)(vector-ref vec 1))
|
| ︙ | | |
Modified docs/html/megatest.html
from [637f8cb216]
to [d407d07366].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
|
-
+
|
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/>
<meta name="generator" content="http://www.nongnu.org/elyxer/"/>
<meta name="create-date" content="2012-01-29"/>
<meta name="create-date" content="2014-01-25"/>
<link rel="stylesheet" href="http://elyxer.nongnu.org/lyx.css" type="text/css" media="all"/>
<title>Megatest User Manual</title>
</head>
<body>
<div id="globalWrapper">
<div class="Standard">
|
| ︙ | | |
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
|
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
|
-
+
|
<h2 class="Subsection">
<a class="toc" name="toc-Subsection-13.1">13.1</a> Monitor logic
</h2>
<div class="Standard">
Note: The monitor is usable but incomplete as of Megatest v1.31. Click on the “Monitor” button on the dashboard to start the monitor and give it a try.
</div>
<div class="Standard">
<img class="embedded" src="monitor-state-diagram.png" alt="figure monitor-state-diagram.png" style="max-width: 383px; max-height: 335px;"/>
<img class="embedded" src="monitor-state-diagram.png" alt="figure monitor-state-diagram.png" style="max-width: 531px; max-height: 465px;"/>
</div>
<h1 class="Section">
<a class="toc" name="toc-Section-14">14</a> Reference
</h1>
<h2 class="Subsection">
<a class="toc" name="toc-Subsection-14.1">14.1</a> Configuration file Syntax
|
| ︙ | | |
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
|
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
|
-
+
|
</h1>
<h1 class="Section">
<a class="toc" name="toc-Appendix-B">B</a> References
</h1>
<hr class="footer"/>
<div class="footer" id="generated-by">
Document generated by <a href="http://elyxer.nongnu.org/">eLyXer 1.2.2 (2011-06-12)</a> on <span class="create-date">2012-01-29T19:15:57.445316</span>
Document generated by <a href="http://elyxer.nongnu.org/">eLyXer 1.2.3 (2011-08-31)</a> on <span class="create-date">2014-01-25T22:27:14.268137</span>
</div>
</div>
</body>
</html>
|
Modified docs/html/monitor-state-diagram.png
from [14f1bb59f3]
to [83e4cb1ce3].
cannot compute difference between binary files
Modified docs/manual/Makefile
from [c10ea440f6]
to [c3b17d73da].
1
2
3
4
5
6
7
|
1
2
3
4
5
6
7
8
9
10
11
|
+
+
+
+
|
megatest_manual.html : megatest_manual.txt getting_started.txt writing_tests.txt reference.txt ../plan.txt
asciidoc megatest_manual.txt
dos2unix megatest_manual.html
server.pdf : server.dot
dot -Tpdf server.dot > server.pdf
clean:
rm -f megatest_manual.html
|
Modified docs/manual/howto.txt
from [ad8e0484e1]
to [1e6d2b1394].
| ︙ | | |
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
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
-
+
-
-
-
-
-
-
-
-
-
-
|
~~~~~~~~~~~~~~~~~~~~~~~~~
During Config File Processing
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Organising Your Tests and Tasks
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
/nfs/ch/disks/ch_unienv_disk005/qa_mrwellan/interim/src/megatest/tests/fdktestqa/testqa
ww30.2
cellname/LVS/cellname.LAYOUT_ERRORS
Error: text open
ww31.3
cellname/LVS/cellname.LAYOUT_ERRORS
Error: text open
|
Modified docs/manual/megatest_manual.html
from [97d3fb8ca7]
to [b092d826cc].
| ︙ | | |
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
|
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
|
-
+
+
+
+
+
-
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
+
-
-
-
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
|
which can launch jobs on local and remote Linux hosts. Currently
megatest uses the network filesystem to call home to your master
sqlite3 database.</p></div>
</div>
</div>
</div>
<h1 id="_road_map">Road Map</h1>
<div class="paragraph"><p>Note: This road-map is tentative and subject to change without notice.</p></div>
<div class="paragraph"><p>Note 1: This road-map is tentative and subject to change without notice.</p></div>
<div class="paragraph"><p>Note 2: Starting over. Old plan is commented out.</p></div>
<div class="sect1">
<h2 id="_current_items">Current Items</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_ww32">ww32</h3>
<h3 id="_ww05_migrate_to_inmem_db">ww05 - migrate to inmem-db</h3>
<div class="paragraph"><p>Keep as much the same as possible. Add internal reference to almost
eliminate contention on db(s).</p></div>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Rerun step and or subsequent steps from gui
</p>
</li>
<li>
<p>
Refresh test area files from gui
</p>
</li>
<li>
<p>
Clean and re-run button
</p>
</li>
<li>
<p>
Clean up STATE and STATUS handling.
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Dashboard and Test control panel are reverse order - choose and fix
</p>
</li>
<li>
<p>
Move seldom used states and status to drop down selector
</p>
</li>
</ol></div>
</li>
<li>
<p>
Access test control panel when clicking on Run Summary tests
Feature: -generate-index-tree
</p>
</li>
<li>
<p>
Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww33">ww33</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
http api available for use with Perl, Ruby etc. scripts
</p>
</li>
<li>
<p>
megatest.config setup entries for:
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
run launching (e.g. /bin/sh %CMD% > /dev/null)
</p>
</li>
<li>
<p>
browser "konqueror %FNAME%
</p>
</li>
</ol></div>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww34">ww34</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Mark dependent tests for clean/rerun -rerun-downstream
</li>
<li>
<p>
On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
</p>
</li>
<li>
<p>
Fix: refresh of gui sometimes fails on last item (race condition?)
</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww35">ww35</h3>
<div class="olist arabic"><ol class="arabic">
refdb: Add export of csv, json and sexp
</p>
</li>
<li>
<p>
Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
</p>
</li>
<li>
<p>
Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
</p>
</li>
<li>
<p>
Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
</p>
</li>
<li>
<p>
Refactor Run Summary view, currently very clumsy
</p>
</li>
<li>
<p>
Add option to show steps in Run Summary view
</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_ww36">ww36</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Refactor guis for resizeablity
Add filters to Run Summary view and Run Control view
</p>
</li>
<li>
<p>
Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS…
Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme <strong>toppath</strong>}>1G
</p>
</li>
</ol></div>
</div>
<div class="sect2">
<h3 id="_bin_list">Bin List</h3>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Quality improvements
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Server stutters occasionally
</p>
</li>
<li>
<p>
Large number of items or tests still has some issues.
</p>
</li>
<li>
<p>
Code refactoring
</p>
</li>
<li>
<p>
Replace remote process with true API using json (supports Web app also)
Streamline the gui
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Everything resizable
</p>
</li>
<li>
<p>
Less clutter
</p>
</li>
<li>
<p>
Tool tips
Filters on Run Summary, Summary and Run Control panel
Built in log viewer (partially implemented)
</p>
</li>
<li>
<p>
Refactor the test control panel
</p>
</li>
</ol></div>
</li>
<li>
<p>
Help and documentation
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Complete the user manual (I’ve been working on this lately).
</p>
Online help in the gui
</ol></div>
</li>
Streamlined install
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Deployed version (download a location independent ready to run binary bundle)
</p>
</li>
<li>
<p>
Install Makefile (in progress, needed for Mike to install on VMs)
</p>
</li>
<li>
<p>
Added option to compile IUP (needed for VMs)
</p>
</li>
</ol></div>
</li>
<li>
<p>
Server side run launching
</p>
</li>
<li>
<p>
Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
<li>
<p>
Wizards for creating tests, regression areas (current ones are text only and limited).
</p>
</li>
<li>
<p>
Fully functional built in web service (currently you can browse runs but it is very simplistic).
</p>
</li>
<li>
<p>
Wildcards in runconfigs: e.g. [p1271/9/%/%]
</p>
</li>
<li>
<p>
Gui panels for editing megatest.config and runconfigs.config
</p>
</li>
<li>
<p>
Fully isolated tests (no use of NFS to see regression area files)
</p>
</li>
<li>
<p>
Windows version
</p>
</li>
</ol></div>
|
| ︙ | | |
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
|
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
</div>
<h1 id="_writing_tests">Writing Tests</h1>
<div class="sect1">
<h2 id="_the_first_chapter_of_the_second_part">The First Chapter of the Second Part</h2>
<div class="sectionbody">
<div class="paragraph"><p>Chapters grouped into book parts are at level 1 and can contain
sub-sections.</p></div>
</div>
</div>
<h1 id="_how_to_do_things">How To Do Things</h1>
<div class="sect1">
<h2 id="_tricks">Tricks</h2>
<div class="sectionbody">
<div class="paragraph"><p>This section is a compendium of a various useful tricks for debugging,
configuring and generally getting the most out of Megatest.</p></div>
</div>
</div>
<div class="sect1">
<h2 id="_debugging_tricks">Debugging Tricks</h2>
<div class="sectionbody">
<div class="sect2">
<h3 id="_examining_the_environment">Examining The Environment</h3>
<div class="sect3">
<h4 id="_during_config_file_processing">During Config File Processing</h4>
</div>
<div class="sect3">
<h4 id="_organising_your_tests_and_tasks">Organising Your Tests and Tasks</h4>
<div class="listingblock">
<div class="content">
<pre><tt>[tests-paths]
1 #{get misc parent}/simplerun/tests</tt></pre>
</div></div>
<div class="listingblock">
<div class="content">
<pre><tt>[setup]</tt></pre>
</div></div>
<div class="paragraph"><p>The runscript method is a brute force way to run scripts where the
user is responsible for setting STATE and STATUS</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>runscript main.csh</tt></pre>
</div></div>
</div>
</div>
</div>
</div>
<h1 id="_reference">Reference</h1>
<div class="sect1">
<h2 id="_the_first_chapter_of_the_second_part_2">The First Chapter of the Second Part</h2>
<div class="sectionbody">
<div class="paragraph"><p>Chapters grouped into book parts are at level 1 and can contain
|
| ︙ | | |
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
|
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
|
+
+
+
+
+
+
+
+
|
<h3 id="_ezsteps">Ezsteps</h3>
<div class="paragraph"><p>To transfer the environment to the next step you can do the following:</p></div>
<div class="listingblock">
<div class="content">
<pre><tt>$MT_MEGATEST -env2file .ezsteps/${stepname}</tt></pre>
</div></div>
</div>
<div class="sect2">
<h3 id="_megatest_internals">Megatest Internals</h3>
<div class="imageblock graphviz">
<div class="content">
<img src="server.png" alt="server.png" />
</div>
</div>
</div>
</div>
</div>
<div class="sect1">
<h2 id="_example_appendix">Appendix A: Example Appendix</h2>
<div class="sectionbody">
<div class="paragraph"><p>One or more optional appendixes go here at section level zero.</p></div>
<div class="sect2">
|
| ︙ | | |
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
|
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
|
-
+
|
</div>
</div>
</div>
<div id="footnotes"><hr /></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br />
Last updated 2013-08-01 22:59:08 MST
Last updated 2014-02-09 20:08:35 MST
</div>
</div>
</body>
</html>
|
Modified docs/manual/megatest_manual.txt
from [20ce759875]
to [38919c0414].
| ︙ | | |
46
47
48
49
50
51
52
53
54
55
56
57
58
59
|
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
+
+
+
+
+
+
+
+
+
|
sqlite3 database.
include::../plan.txt[]
include::getting_started.txt[]
include::writing_tests.txt[]
include::howto.txt[]
include::reference.txt[]
Megatest Internals
~~~~~~~~~~~~~~~~~~
["graphviz", "server.png"]
----------------------------------------------------------------------
include::server.dot[]
----------------------------------------------------------------------
[appendix]
Example Appendix
================
One or more optional appendixes go here at section level zero.
Appendix Sub-section
|
| ︙ | | |
Modified docs/manual/reference.txt
from [6d8b51499a]
to [b45aa0231c].
1
2
3
4
5
6
7
8
9
10
11
12
13
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
|
+
|
Reference
=========
The First Chapter of the Second Part
------------------------------------
Chapters grouped into book parts are at level 1 and can contain
sub-sections.
The testconfig File
-------------------
Setup section
|
| ︙ | | |
Added docs/manual/server.dot version [4efd80e71a].
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
digraph G {
// put client after server so server_start node is visible
//
subgraph cluster_0 {
node [style=filled];
start_client -> lookup_server;
lookup_server -> connect [label=found];
lookup_server -> "server_available?";
"server_available?" -> delay [label=yes];
"server_available?" -> client_start_server [label=no];
client_start_server -> delay;
connect -> login;
login -> read_write [label=success];
login -> "server_dead?" [label=fail];
read_write -> timeout -> "server_dead?";
read_write -> wrong_server -> delay;
// read_write -> read_write;
"server_dead?" -> remove_record [label="yes (too many tries)"];
remove_record -> lookup_server;
"server_dead?" -> delay [label=no];
delay -> lookup_server;
label = "client";
color=green;
}
subgraph cluster_1 {
node [style=filled];
start_server -> "server_running?";
"server_running?" -> set_available [label="no"];
"server_running?" -> delay_2s [label="yes"];
delay_2s -> "still_running?";
"still_running?" -> ping_server [label=yes];
"still_running?" -> set_available [label=no];
ping_server -> exit [label=alive];
ping_server -> remove_server_record [label=dead];
remove_server_record -> set_available;
set_available -> avail_delay [label="delay 3s"];
avail_delay -> "first_in_queue?";
"first_in_queue?" -> set_running [label=yes];
set_running -> handle_requests;
"first_in_queue?" -> "server_running?" [label=no];
handle_requests -> start_shutdown [label="no traffic"];
handle_requests -> shutdown_request;
start_shutdown -> shutdown_delay;
shutdown_request -> shutdown_delay;
shutdown_delay -> exit;
label = "server";
color=brown;
}
client_start_server -> start_server;
handle_requests -> read_write;
read_write -> handle_requests;
}
|
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
Added docs/manual/server.png version [8fdf36008d].
cannot compute difference between binary files
Modified docs/plan.txt
from [a80831142b]
to [0ead7d4df0].
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
|
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
|
-
+
+
-
-
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
Road Map
========
Note: This road-map is tentative and subject to change without notice.
Note 1: This road-map is tentative and subject to change without notice.
Note 2: Starting over. Old plan is commented out.
ww32
~~~~
. Rerun step and or subsequent steps from gui
. Refresh test area files from gui
. Clean and re-run button
. Clean up STATE and STATUS handling.
.. Dashboard and Test control panel are reverse order - choose and fix
.. Move seldom used states and status to drop down selector
. Access test control panel when clicking on Run Summary tests
. Feature: -generate-index-tree
. Change specifing of state and status to use STATE1/STATUS1,STATE2/STATUS2
ww33
~~~~
. http api available for use with Perl, Ruby etc. scripts
. megatest.config setup entries for:
.. run launching (e.g. /bin/sh %CMD% > /dev/null)
.. browser "konqueror %FNAME%
ww34
~~~~
. Mark dependent tests for clean/rerun -rerun-downstream
. On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
. Fix: refresh of gui sometimes fails on last item (race condition?)
ww35
~~~~
. refdb: Add export of csv, json and sexp
. Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
. Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
. Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
. Refactor Run Summary view, currently very clumsy
. Add option to show steps in Run Summary view
ww36
~~~~
. Refactor guis for resizeablity
. Add filters to Run Summary view and Run Control view
. Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS...
. Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G
Bin List
~~~~~~~~
. Quality improvements
.. Server stutters occasionally
.. Large number of items or tests still has some issues.
.. Code refactoring
.. Replace remote process with true API using json (supports Web app also)
. Streamline the gui
.. Everything resizable
.. Less clutter
.. Tool tips
.. Filters on Run Summary, Summary and Run Control panel
.. Built in log viewer (partially implemented)
.. Refactor the test control panel
. Help and documentation
.. Complete the user manual (I’ve been working on this lately).
.. Online help in the gui
. Streamlined install
.. Deployed version (download a location independent ready to run binary bundle)
.. Install Makefile (in progress, needed for Mike to install on VMs)
.. Added option to compile IUP (needed for VMs)
. Server side run launching
. Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
. Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
. Wizards for creating tests, regression areas (current ones are text only and limited).
. Fully functional built in web service (currently you can browse runs but it is very simplistic).
. Wildcards in runconfigs: e.g. [p1271/9/%/%]
. Gui panels for editing megatest.config and runconfigs.config
. Fully isolated tests (no use of NFS to see regression area files)
. Windows version
// ww33
// ~~~~
//
// . http api available for use with Perl, Ruby etc. scripts
// . megatest.config setup entries for:
// .. run launching (e.g. /bin/sh %CMD% > /dev/null)
// .. browser "konqueror %FNAME%
//
// ww34
// ~~~~
//
// . Mark dependent tests for clean/rerun -rerun-downstream
// . On run start check for defunct tests in RUNNING, LAUNCHED or REMOTEHOSTSTART and correct or notify
// . Fix: refresh of gui sometimes fails on last item (race condition?)
//
// ww35
// ~~~~
//
// . refdb: Add export of csv, json and sexp
// . Convert to using call-with-environment-variables where possible. Should allow handling of parallel runs in same process.
// . Re-work text interface wizards. Several bugs on record. Possibly convert to gui based.
// . Add to testconfig requirements section; launchlimiter scriptname, calls scriptname to check if ok to launch test
// . Refactor Run Summary view, currently very clumsy
// . Add option to show steps in Run Summary view
//
// ww36
// ~~~~
//
// . Refactor guis for resizeablity
// . Add filters to Run Summary view and Run Control view
// . Add to megatest.config or testconfig; rerunok STATE/STATUS,STATE/STATUS...
// . Launch gates for diskspace; /path/one>1G,/path/two>200M,/tmp>5G,#{scheme *toppath*}>1G
//
// Bin List
// ~~~~~~~~
//
// . Quality improvements
// .. Server stutters occasionally
// .. Large number of items or tests still has some issues.
// .. Code refactoring
// .. Replace remote process with true API using json (supports Web app also)
// . Streamline the gui
// .. Everything resizable
// .. Less clutter
// .. Tool tips
// .. Filters on Run Summary, Summary and Run Control panel
// .. Built in log viewer (partially implemented)
// .. Refactor the test control panel
// . Help and documentation
// .. Complete the user manual (I’ve been working on this lately).
// .. Online help in the gui
// . Streamlined install
// .. Deployed version (download a location independent ready to run binary bundle)
// .. Install Makefile (in progress, needed for Mike to install on VMs)
// .. Added option to compile IUP (needed for VMs)
// . Server side run launching
// . Support for re-running, cleaning etc. of individual steps (ezsteps makes this very easy to implement).
// . Launch process needs built in daemonizing (easy to do, just need to test it thoroughly).
// . Wizards for creating tests, regression areas (current ones are text only and limited).
// . Fully functional built in web service (currently you can browse runs but it is very simplistic).
// . Wildcards in runconfigs: e.g. [p1271/9/%/%]
// . Gui panels for editing megatest.config and runconfigs.config
// . Fully isolated tests (no use of NFS to see regression area files)
// . Windows version
|
Modified http-transport.scm
from [ac12c8febe]
to [cb9f17b39f].
| ︙ | | |
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
|
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
|
-
+
|
(set! res adr)))
(vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
(string-intersperse
(map number->string
(u8vector->list
(if res res (hostname->ip hostname)))) ".")))
(define (http-transport:run hostn)
(define (http-transport:run hostn run-id server-id)
(debug:print 2 "Attempting to start the server ...")
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, cannot start server, exiting")
(exit))))
(let* (;; (iface (if (string=? "-" hostn)
|
| ︙ | | |
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
|
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
|
-
+
-
+
-
-
-
+
-
+
-
-
+
-
-
+
+
|
(send-response body: "hey there!\n"
headers: '((content-type text/plain))))
((equal? (uri-path (request-uri (current-request)))
'(/ "hey"))
(send-response body: "hey there!\n"
headers: '((content-type text/plain))))
(else (continue))))))))
(http-transport:try-start-server ipaddrstr start-port)))
(http-transport:try-start-server ipaddrstr start-port server-id)))
;; This is recursively run by http-transport:run until sucessful
;;
(define (http-transport:try-start-server ipaddrstr portnum)
(define (http-transport:try-start-server ipaddrstr portnum server-id)
(handle-exceptions
exn
(begin
(print-error-message exn)
(if (< portnum 9000)
(begin
(debug:print 0 "WARNING: failed to start on portnum: " portnum ", trying next port")
(thread-sleep! 0.1)
;; (open-run-close tasks:remove-server-records tasks:open-db)
(open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum)
(http-transport:try-start-server ipaddrstr (+ portnum 1)))
(set! *runremote* (list ipaddrstr portnum))
(set! *server-info* (list ipaddrstr portnum))
;; (open-run-close tasks:remove-server-records tasks:open-db)
(open-run-close tasks:server-register
(current-process-id)
ipaddrstr portnum 0 'startup 'http)
server-id
ipaddrstr portnum)
(debug:print 1 "INFO: Trying to start server on " ipaddrstr ":" portnum)
;; This starts the spiffy server
;; NEED WAY TO SET IP TO #f TO BIND ALL
(start-server bind-address: ipaddrstr port: portnum)
(open-run-close tasks:server-delete tasks:open-db ipaddrstr portnum)
(debug:print 1 "INFO: server has been stopped")))
|
| ︙ | | |
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
|
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
|
-
+
-
+
+
-
+
|
(debug:print-info 11 "match=" match)
(let ((final (cadr match)))
(debug:print-info 11 "final=" final)
final)))))))
;; Send "cmd" with json payload "params" to serverdat and receive result
;;
(define (http-transport:client-api-send-receive serverdat cmd params #!key (numretries 30))
(define (http-transport:client-api-send-receive run-id serverdat cmd params #!key (numretries 30))
(let* ((fullurl (if (list? serverdat)
(cadddr serverdat) ;; this is the uri for /api
(begin
(debug:print 0 "FATAL ERROR: http-transport:client-send-receive called with no server info")
(exit 1))))
(res #f))
(handle-exceptions
exn
(begin
;; TODO: Send this output to a log file so it isn't lost when running as daemon
(print "ERROR IN http-transport:client-send-receive " ((condition-property-accessor 'exn 'message) exn))
(thread-sleep! 2)
(http-transport:client-api-send-receive serverdat cmd params numretries: (- numretries 1))))
(http-transport:client-api-send-receive run-id serverdat cmd params numretries: (- numretries 1)))))
(begin
(debug:print-info 11 "fullurl=" fullurl "\n")
;; set up the http-client here
(max-retry-attempts 5)
;; consider all requests indempotent
(retry-request? (lambda (request)
#t)) ;; (thread-sleep! (/ (if (> numretries 100) 100 numretries) 10))
|
| ︙ | | |
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
|
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
|
-
+
-
-
+
+
-
+
-
-
-
-
-
+
-
+
+
+
-
+
-
+
+
+
+
+
-
+
-
-
-
+
|
(thread-start! th1)
(thread-start! th2)
(thread-join! th1)
(thread-terminate! th2)
(debug:print-info 11 "got res=" res)
res)))))
(define (http-transport:client-connect iface port)
(define (http-transport:client-connect run-id iface port)
(let* ((login-res #f)
(uri-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/ctrl"))))
(uri-api-dat (make-request method: 'POST uri: (uri-reference (conc "http://" iface ":" port "/api"))))
(serverdat (list iface port uri-dat uri-api-dat)))
(set! *runremote* serverdat) ;; may or may not be good ...
(set! login-res (rmt:login))
(hash-table-set! *runremote* run-id serverdat) ;; may or may not be good ...
(set! login-res (rmt:login run-id))
(if (and (list? login-res)
(car login-res))
(begin
(debug:print-info 2 "Logged in and connected to " iface ":" port)
(set! *runremote* serverdat)
(hash-table-set! *runremote* run-id serverdat)
serverdat)
(begin
(debug:print-info 0 "ERROR: Failed to login or connect to " iface ":" port)
(exit 1)))))
;; (set! *runremote* #f)
;; (set! *transport-type* 'fs)
;; #f))))
(define (http-transport:keep-running)
(define (http-transport:keep-running server-id)
;; if none running or if > 20 seconds since
;; server last used then start shutdown
;; This thread waits for the server to come alive
(let* ((server-info (let loop ()
(let* ((server-info (let loop ((start-time (current-seconds))
(changed #t)
(last-sdat "not this"))
(let ((sdat #f))
(mutex-lock! *heartbeat-mutex*)
(set! sdat *runremote*)
(set! sdat *server-info*)
(mutex-unlock! *heartbeat-mutex*)
(if sdat
(if (and sdat
(not changed)
(> (- (current-seconds) start-time) 2))
sdat
(begin
(sleep 4)
(loop start-time
(equal? sdat last-sdat)
(loop))))))
sdat))))))
(iface (car server-info))
(port (cadr server-info))
(last-access 0)
(tdb (tasks:open-db))
(spid ;;(open-run-close tasks:server-get-server-id tasks:open-db #f iface port #f))
(tasks:server-get-server-id tdb #f iface port #f))
(debug:print-info 2 "server-timeout: " server-timeout ", server pid: " spid " on " iface ":" port)
(tasks:server-set-state! tdb server-id "running")
(let loop ((count 0))
;; Use this opportunity to sync the inmemdb to db
(let ((start-time (current-milliseconds))
(sync-time #f)
(rem-time #f))
(if *inmemdb* (db:sync-touched *inmemdb* force-sync: #t))
(set! sync-time (- (current-milliseconds) start-time))
|
| ︙ | | |
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
|
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
|
-
+
-
+
-
+
-
-
+
-
-
+
+
+
-
+
+
-
+
-
-
-
-
+
+
+
+
+
+
-
-
+
+
+
+
-
+
|
;; (thread-sleep! 4) ;; no need to do this very often
(if (< count 1) ;; 3x3 = 9 secs aprox
(loop (+ count 1)))
;; Check that iface and port have not changed (can happen if server port collides)
(mutex-lock! *heartbeat-mutex*)
(set! sdat *runremote*)
(set! sdat *server-info*)
(mutex-unlock! *heartbeat-mutex*)
(if (or (not (equal? sdat (list iface port)))
(not spid))
(not server-id))
(begin
(debug:print-info 0 "interface changed, refreshing iface and port info")
(set! iface (car sdat))
(set! port (cadr sdat))
(set! port (cadr sdat))))
(set! spid (tasks:server-get-server-id tdb #f iface port #f))))
(tasks:server-update-heartbeat tdb spid)
(tasks:server-update-heartbeat tdb server-id)
;; (if ;; (or (> numrunning 0) ;; stay alive for two days after last access
;; Transfer *last-db-access* to last-access to use in checking that we are still alive
(mutex-lock! *heartbeat-mutex*)
(set! last-access *last-db-access*)
(mutex-unlock! *heartbeat-mutex*)
;; (debug:print 11 "last-access=" last-access ", server-timeout=" server-timeout)
(if (and *server-run*
(> (+ last-access server-timeout)
(current-seconds)))
(begin
(debug:print-info 0 "Server continuing, seconds since last db access: " (- (current-seconds) last-access))
(loop 0))
(begin
(debug:print-info 0 "Starting to shutdown the server.")
;; need to delete only *my* server entry (future use)
(set! *time-to-exit* #t)
(if *inmemdb* (db:sync-touched *inmemdb* force-sync: #t))
(open-run-close tasks:server-deregister-self tasks:open-db (get-host-name))
(thread-sleep! 1)
( tasks:server-set-state! tdb server-id "shutting-down")
(thread-sleep! 5)
(debug:print-info 0 "Max cached queries was " *max-cache-size*)
(debug:print-info 0 "Number of cached writes " *number-of-writes*)
(debug:print-info 0 "Average cached write time "
(if (eq? *number-of-writes* 0)
"n/a (no writes)"
(/ *writes-total-delay*
*number-of-writes*))
" ms")
(debug:print-info 0 "Number non-cached queries " *number-non-write-queries*)
(debug:print-info 0 "Average non-cached time "
(if (eq? *number-non-write-queries* 0)
"n/a (no queries)"
(/ *total-non-write-delay*
*number-non-write-queries*))
" ms")
(debug:print-info 0 "Server shutdown complete. Exiting")
(tasks:server-delete-record! tdb server-id)
(exit))))))
;; all routes though here end in exit ...
(define (http-transport:launch)
(define (http-transport:launch run-id)
(set! *run-id* run-id)
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, exiting")
(exit))))
(debug:print-info 2 "Starting the standalone server")
(if (args:get-arg "-daemonize")
(daemon:ize))
(let ((hostinfo (open-run-close tasks:get-best-server tasks:open-db)))
(let ((server-id (open-run-close tasks:server-lock-slot tasks:open-db run-id)))
(debug:print 11 "http-transport:launch hostinfo=" hostinfo)
;; #(1 "143.182.207.24" 5736 -1 "http" 22771 "hostname")
(if hostinfo
(debug:print-info 2 "NOT starting new server, one is already running on " (vector-ref hostinfo 1) ":" (vector-ref hostinfo 2))
"-"))) "Server run"))
(th3 (make-thread http-transport:keep-running "Keep running")))
server-id)) "Server run"))
(th3 (make-thread (lambda ()
(http-transport:keep-running server-id))
"Keep running")))
;; Database connection
(set! *inmemdb* (db:setup))
(set! *inmemdb* (db:setup run-id))
(thread-start! th2)
(thread-start! th3)
(set! *didsomething* #t)
(thread-join! th2))
(debug:print 0 "ERROR: Failed to setup for megatest")))
;; (sdb:qry 'finalize)
(exit)))
|
| ︙ | | |
Modified launch.scm
from [7c2ca47271]
to [01eba87552].
| ︙ | | |
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
|
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
|
-
+
|
;;
;; All log file links should be stored relative to the top of link path
;;
;; <target> - <testname> [ - <itempath> ]
;;
(define (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat)
(let* ((item-path (item-list->path itemdat))
(runname (db:get-value-by-header (db:get-row run-info)
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info)
"runname"))
;; convert back to db: from rdb: - this is always run at server end
(target (string-intersperse (map cadr keyvals) "/"))
(not-iterated (equal? "" item-path))
|
| ︙ | | |
Modified megatest.scm
from [d71e637572]
to [20b3d11528].
| ︙ | | |
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
+
|
(declare (uses daemon))
(declare (uses db))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
|
| ︙ | | |
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
+
|
"-set-state-status"
"-debug" ;; for *verbosity* > 2
"-gen-megatest-test"
"-override-timeout"
"-test-files" ;; -test-paths is for listing all
"-load" ;; load and exectute a scheme file
"-dumpmode"
"-run-id"
)
(list "-h"
"-version"
"-force"
"-xterm"
"-showkeys"
"-show-keys"
|
| ︙ | | |
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
|
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
|
-
-
-
+
+
+
+
+
+
+
-
+
+
|
(if (args:get-arg "-server")
;; Server? Start up here.
;;
(let ((tl (setup-for-run))
(transport (or (configf:lookup *configdat* "setup" "transport")
(args:get-arg "-transport" "http"))))
(debug:print 2 "Launching server using transport " transport)
(server:launch (string->symbol transport)))
(args:get-arg "-transport" "http")))
(run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id")))))
(debug:print 2 "Launching server using transport " transport " for run-id=" run-id)
(if run-id
(server:launch (string->symbol transport) run-id)
(debug:print 0 "ERROR: server requires run-id be specified with -run-id")))
;; Not a server? This section will decide how to communicate
;;
;; Setup client for all expect listed here
(if (null? (lset-intersection
equal?
(hash-table-keys args:arg-hash)
'("-list-servers"
"-stop-server"
"-show-cmdinfo"
"-list-runs")))
(if (setup-for-run)
(begin
(let ((run-id (and (args:get-arg "-run-id")
(string->number (args:get-arg "-run-id")))))
;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db")))
;; if not list or kill then start a client (if appropriate)
(if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test")
(eq? (length (hash-table-keys args:arg-hash)) 0))
(debug:print-info 1 "Server connection not needed")
;; ok, so lets connect to the server
(let* ((transport-from-config (configf:lookup *configdat* "setup" "transport"))
|
| ︙ | | |
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
|
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
|
+
+
+
+
-
-
-
-
+
+
+
+
+
+
|
transport-from-cmdinfo
transport-from-config
"fs"))))
(debug:print 2 "chosen-transport: " chosen-transport " have; config=" transport-from-config ", cmdln=" transport-from-cmdln ", cmdinfo=" transport-from-cmdinfo)
(case chosen-transport
((http)
(set! *transport-type 'http)
;; if we have a run-id (why would we?) start the server for that run.
;; otherwise it is up to other calls to start the server(s) dynamically
(if run-id
(begin
(server:ensure-running)
;; Get rid of this
(client:launch))
(server:ensure-running run-id)
(client:launch run-id))
(begin
;; without run-id we'll start a server for "0"
(server:ensure-running 0)
(client:launch 0))))
(else ;; (fs)
(debug:print 0 "ERROR: Should NOT be getting here! fs transport is no longer supported")
(set! *transport-type* 'fs)
(set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))
(if (or (args:get-arg "-list-servers")
(args:get-arg "-stop-server"))
|
| ︙ | | |
688
689
690
691
692
693
694
695
696
697
698
699
700
701
|
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
|
+
+
+
+
+
+
+
+
+
+
+
|
;; - if cannot access db > allowed disconnect time then kill job
(if (args:get-arg "-runtests")
(general-run-call
"-runtests"
"run a test"
(lambda (target runname keys keyvals)
;;
;; May or may not implement it this way ...
;;
;; Insert this run into the tasks queue
;; (open-run-close tasks:add tasks:open-db
;; "runtests"
;; user
;; target
;; runname
;; (args:get-arg "-runtests")
;; #f))))
(runs:run-tests target
runname
(args:get-arg "-runtests")
user
args:arg-hash))))
;;======================================================================
|
| ︙ | | |
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
|
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
|
-
+
|
(cmd (string-intersperse (list "logpro" logprofile htmllogfile "<" logfile ">" (conc stepname "_logpro.log")) " ")))
(debug:print-info 2 "running \"" cmd "\"")
(change-directory startingdir)
(set! exitstat (system cmd))
(set! *globalexitstatus* exitstat) ;; no necessary
(change-directory testpath)
;; (cdb:test-set-log! *runremote* test-id (sdb:qry 'getid htmllogfile))))
(rmt:test-set-log! test-id htmllogfile)))
(rmt:test-set-log! run-id test-id htmllogfile)))
(let ((msg (args:get-arg "-m")))
(rmt:teststep-set-status! run-id test-id stepname "end" exitstat msg logfile))
)))
(if (or (args:get-arg "-test-status")
(args:get-arg "-set-values"))
(let ((newstatus (cond
((number? status) (if (equal? status 0) "PASS" "FAIL"))
|
| ︙ | | |
Modified mt.scm
from [78f8ad9fdf]
to [029729b148].
| ︙ | | |
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
-
+
|
;; R U N S
;;======================================================================
;; runs:get-runs-by-patt
;; get runs by list of criteria
;; register a test run with the db
;;
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-row runinfo))
;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
;; to extract info from the structure returned
;;
(define (mt:get-runs-by-patt keys runnamepatt targpatt)
(let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500))
(res '())
(offset 0)
(limit 500))
|
| ︙ | | |
Modified rmt.scm
from [9cfe708307]
to [c7c7b5a349].
| ︙ | | |
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
|
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
|
-
+
+
+
+
-
-
+
+
-
+
-
|
;;======================================================================
;; S U P P O R T F U N C T I O N S
;;======================================================================
;; cmd is a symbol
;; vars is a json string encoding the parameters for the call
;;
(define (rmt:send-receive cmd params)
(define (rmt:send-receive cmd run-id params)
(case *transport-type*
((fs-aint-here)
(debug:print 0 "ERROR: Not yet (re)supported")
(exit 1))
((fs http)
;; if run-id is #f send the request to run-id = 0 server. This will be for main.db
;;
(let* ((connection-info (client:setup (if run-id run-id 0)))
(let* ((jparams (db:obj->string params)) ;; (rmt:dat->json-str params))
(res (http-transport:client-api-send-receive *runremote* cmd jparams)))
#f))
#f))))
))
|
| ︙ | | |
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
|
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
|
-
-
+
+
-
-
+
+
-
+
-
-
+
+
-
+
-
+
+
+
+
+
+
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
+
+
+
+
-
+
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
+
+
-
+
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
+
-
+
-
+
-
+
-
+
-
+
+
+
+
-
-
+
+
-
+
-
+
+
+
+
-
-
+
+
-
+
-
-
+
+
-
-
+
+
-
+
-
+
-
+
-
+
-
+
|
;;
;;======================================================================
;;======================================================================
;; M I S C
;;======================================================================
(define (rmt:login)
(rmt:send-receive 'login (list *toppath* megatest-version *my-client-signature*)))
(define (rmt:login run-id)
(rmt:send-receive 'login run-id (list *toppath* megatest-version *my-client-signature*)))
(define (rmt:kill-server)
(rmt:send-receive 'kill-server '()))
(define (rmt:kill-server run-id)
(rmt:send-receive 'kill-server run-id (list run-id)))
;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible
;;
(define (rmt:general-call stmtname run-id . params)
(rmt:send-receive 'general-call (append (list stmtname run-id) params)))
(rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
(define (rmt:sync-inmem->db)
(rmt:send-receive 'sync-inmem->db '()))
(define (rmt:sync-inmem->db run-id)
(rmt:send-receive 'sync-inmem->db run-id '()))
(define (rmt:sdb-qry qry val)
(define (rmt:sdb-qry qry val run-id)
;; add caching if qry is 'getid or 'getstr
(rmt:send-receive 'sdb-qry (list qry val)))
(rmt:send-receive 'sdb-qry run-id (list qry val)))
;; NOT COMPLETED
(define (rmt:runtests user run-id testpatt params)
(rmt:send-receive 'runtests run-id testpatt))
;;======================================================================
;; K E Y S
;;======================================================================
;; These should not require run-id but it is more consistent to have it.
;; run-id can theoretically be #f but how to handle that is not yet done.
(define (rmt:get-key-val-pairs run-id)
(rmt:send-receive 'get-key-val-pairs (list run-id)))
(rmt:send-receive 'get-key-val-pairs run-id (list run-id)))
(define (rmt:get-keys)
(rmt:send-receive 'get-keys '()))
(rmt:send-receive 'get-keys #f '()))
;;======================================================================
;; T E S T S
;;======================================================================
(define (rmt:get-test-id run-id testname item-path)
(rmt:send-receive 'get-test-id (list run-id testname item-path)))
(rmt:send-receive 'get-test-id run-id (list run-id testname item-path)))
(define (rmt:get-test-info-by-id run-id test-id)
(if (and (number? run-id)(number? test-id))
(rmt:send-receive 'get-test-info-by-id (list run-id test-id))
(rmt:send-receive 'get-test-info-by-id run-id (list run-id test-id))
(begin
(debug:print 0 "ERROR: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
(print-call-chain)
#f)))
(define (rmt:test-get-rundir-from-test-id run-id test-id)
(rmt:send-receive 'test-get-rundir-from-test-id (list run-id test-id)))
(rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
(let* ((test-path (if (string? work-area)
work-area
(rmt:test-get-rundir-from-test-id run-id test-id))))
(debug:print 3 "TEST PATH: " test-path)
(open-test-db test-path)))
;; WARNING: This currently bypasses the transaction wrapped writes system
(define (rmt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
(rmt:send-receive 'test-set-state-status-by-id (list run-id test-id newstate newstatus newcomment)))
(rmt:send-receive 'test-set-state-status-by-id run-id (list run-id test-id newstate newstatus newcomment)))
(define (rmt:set-tests-state-status run-id testnames currstate currstatus newstate newstatus)
(rmt:send-receive 'set-tests-state-status (list run-id testnames currstate currstatus newstate newstatus)))
(rmt:send-receive 'set-tests-state-status run-id (list run-id testnames currstate currstatus newstate newstatus)))
(define (rmt:get-tests-for-run run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals)
(if (number? run-id)
(rmt:send-receive 'get-tests-for-run (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals))
(rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals))
(begin
(debug:print "ERROR: rmt:get-tests-for-run called with bad run-id=" run-id)
(print-call-chain)
'())))
(define (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in)
(let ((run-id-list (if run-ids
run-ids
(rmt:get-all-run-ids))))
(apply append (map (lambda (run-id)
(rmt:send-receive 'get-tests-for-runs-mindata (list run-ids testpatt states status not-in)))
(rmt:send-receive 'delete-test-records (list run-id test-id)))
(rmt:send-receive 'delete-test-records run-id (list run-id test-id)))
(define (rmt:test-set-status-state run-id test-id status state msg)
(rmt:send-receive 'test-set-status-state (list run-id test-id status state msg)))
(rmt:send-receive 'test-set-status-state run-id (list run-id test-id status state msg)))
(define (rmt:get-previous-test-run-record run-id test-name item-path)
(rmt:send-receive 'get-previous-test-run-record (list run-id test-name item-path)))
(rmt:send-receive 'get-previous-test-run-record run-id (list run-id test-name item-path)))
(define (rmt:get-matching-previous-test-run-records run-id test-name item-path)
(rmt:send-receive 'get-matching-previous-test-run-records (list run-id test-name item-path)))
(rmt:send-receive 'get-matching-previous-test-run-records run-id (list run-id test-name item-path)))
(define (rmt:test-get-logfile-info run-id test-name)
(rmt:send-receive 'test-get-logfile-info (list run-id test-name)))
(rmt:send-receive 'test-get-logfile-info run-id (list run-id test-name)))
(define (rmt:test-get-records-for-index-file run-id test-name)
(rmt:send-receive 'test-get-records-for-index-file (list run-id test-name)))
(rmt:send-receive 'test-get-records-for-index-file run-id (list run-id test-name)))
(define (rmt:get-testinfo-state-status run-id test-id)
(rmt:send-receive 'get-testinfo-state-status (list run-id test-id)))
(rmt:send-receive 'get-testinfo-state-status run-id (list run-id test-id)))
(define (rmt:test-set-log! run-id test-id logf)
(if (string? logf)(rmt:general-call 'test-set-log run-id logf test-id)))
(define (rmt:test-get-paths-matching-keynames-target-new keynames target res testpatt statepatt statuspatt runname)
(let ((run-ids (rmt:get-run-ids-matching keynames target res)))
(apply append (lambda (run-id)
(rmt:send-receive 'test-get-paths-matching-keynames-target-new (list keynames target res testpatt statepatt statuspatt runname)))
(rmt:send-receive 'test-get-paths-matching-keynames-target-new (list keynames target res testpatt statepatt statuspatt runname)))
run-ids)))
(define (rmt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal))
(rmt:send-receive 'get-prereqs-not-met (list run-id waitons ref-item-path mode)))
(rmt:send-receive 'get-prereqs-not-met run-id (list run-id waitons ref-item-path mode)))
(define (rmt:get-count-tests-running-for-run-id run-id)
(rmt:send-receive 'get-count-tests-running-for-run-id (list run-id)))
(rmt:send-receive 'get-count-tests-running-for-run-id run-id (list run-id)))
;; Statistical queries
(define (rmt:get-count-tests-running run-id)
(rmt:send-receive 'get-count-tests-running (list run-id)))
(rmt:send-receive 'get-count-tests-running run-id (list run-id)))
(define (rmt:get-count-tests-running-in-jobgroup run-id jobgroup)
(rmt:send-receive 'get-count-tests-running-in-jobgroup (list run-id jobgroup)))
(rmt:send-receive 'get-count-tests-running-in-jobgroup run-id (list run-id jobgroup)))
(define (rmt:roll-up-pass-fail-counts run-id test-name item-path status)
(rmt:send-receive 'roll-up-pass-fail-counts (list run-id test-name item-path status)))
(rmt:send-receive 'roll-up-pass-fail-counts run-id (list run-id test-name item-path status)))
(define (rmt:update-pass-fail-counts run-id test-name)
(rmt:general-call 'update-fail-pass-counts (list run-id test-name run-id test-name run-id test-name)))
(rmt:general-call 'update-fail-pass-counts run-id (list run-id test-name run-id test-name run-id test-name)))
;;======================================================================
;; R U N S
;;======================================================================
(define (rmt:get-run-info run-id)
(rmt:send-receive 'get-run-info (list run-id)))
(rmt:send-receive 'get-run-info run-id (list run-id)))
;; Use the special run-id == #f scenario here since there is no run yet
(define (rmt:register-run keyvals runname state status user)
(rmt:send-receive 'register-run (list keyvals runname state status user)))
(rmt:send-receive 'register-run #f (list keyvals runname state status user)))
(define (rmt:get-run-name-from-id run-id)
(rmt:send-receive 'get-run-name-from-id (list run-id)))
(rmt:send-receive 'get-run-name-from-id run-id (list run-id)))
(define (rmt:delete-run run-id)
(rmt:send-receive 'delete-run (list run-id)))
(rmt:send-receive 'delete-run run-id (list run-id)))
(define (rmt:delete-old-deleted-test-records)
(rmt:send-receive 'delete-old-deleted-test-records '()))
(rmt:send-receive 'delete-old-deleted-test-records #f '()))
(define (rmt:get-runs runpatt count offset keypatts)
(rmt:send-receive 'get-runs (list runpatt count offset keypatts)))
(rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
(define (rmt:get-runs runpatt count offset keypatts)
(rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit)
(rmt:send-receive 'get-runs-by-patt (list keys runnamepatt targpatt offset limit)))
(define (rmt:get-all-run-ids)
(rmt:send-receive 'get-all-run-ids #f '()))
(define (rmt:lock/unlock-run run-id lock unlock user)
(rmt:send-receive 'lock/unlock-run (list run-id lock unlock user)))
(rmt:send-receive 'lock/unlock-run #f (list run-id lock unlock user)))
(define (rmt:update-run-event_time run-id)
(rmt:send-receive 'update-run-event_time (list run-id)))
(rmt:send-receive 'update-run-event_time #f (list run-id)))
(define (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit)
(rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit)))
;;======================================================================
;; S T E P S
;;======================================================================
;; Getting steps is more complicated.
;;
;; If given work area
;; 1. Find the testdat.db file
;; 2. Open the testdat.db file and do the query
;; If not given the work area
;; 1. Do a remote call to get the test path
;; 2. Continue as above
;;
(define (rmt:get-steps-for-test test-id)
(rmt:send-receive 'get-steps-data (list test-id)))
(define (rmt:get-steps-for-test run-id test-id)
(rmt:send-receive 'get-steps-data run-id (list test-id)))
(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
(let* ((state (items:check-valid-items "state" state-in))
(status (items:check-valid-items "status" status-in)))
(if (or (not state)(not status))
(debug:print 3 "WARNING: Invalid " (if status "status" "state")
" value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
(rmt:send-receive 'teststep-set-status! (list run-id test-id teststep-name state-in status-in comment logfile))))
(rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))
(define (rmt:get-steps-for-test test-id)
(rmt:send-receive 'get-steps-for-test (list test-id)))
(define (rmt:get-steps-for-test run-id test-id)
(rmt:send-receive 'get-steps-for-test run-id (list test-id)))
;;======================================================================
;; T E S T D A T A
;;======================================================================
(define (rmt:read-test-data test-id categorypatt #!key (work-area #f))
(let ((tdb (rmt:open-test-db-by-test-id test-id work-area: work-area)))
(define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f))
(let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area)))
(if tdb
(tdb:read-test-data tdb test-id categorypatt)
'())))
(define (rmt:testmeta-add-record testname)
(rmt:send-receive 'testmeta-add-record (list testname)))
(rmt:send-receive 'testmeta-add-record #f (list testname)))
(define (rmt:testmeta-get-record testname)
(rmt:send-receive 'testmeta-get-record (list testname)))
(rmt:send-receive 'testmeta-get-record #f (list testname)))
(define (rmt:testmeta-update-field test-name fld val)
(rmt:send-receive 'testmeta-update-field (list test-name fld val)))
(rmt:send-receive 'testmeta-update-field #f (list test-name fld val)))
(define (rmt:test-data-rollup run-id test-id status)
(rmt:send-receive 'test-data-rollup (list run-id test-id status)))
(rmt:send-receive 'test-data-rollup run-id (list run-id test-id status)))
(define (rmt:csv->test-data run-id test-id csvdata)
(rmt:send-receive 'csv->test-data (list run-id test-id csvdata)))
(rmt:send-receive 'csv->test-data run-id (list run-id test-id csvdata)))
|
Modified runs.scm
from [ace0f064f9]
to [d850da5471].
| ︙ | | |
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
|
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
|
-
+
+
+
+
+
-
-
+
+
-
|
(define (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs)
(thread-sleep! (cond
((> *runs:can-run-more-tests-count* 20) 2);; obviously haven't had any work to do for a while
(else 0)))
(let* ((num-running (rmt:get-count-tests-running run-id))
(num-running-in-jobgroup (rmt:get-count-tests-running-in-jobgroup run-id jobgroup))
(job-group-limit (config-lookup *configdat* "jobgroups" jobgroup)))
(job-group-limit (let ((jobg-count (config-lookup *configdat* "jobgroups" jobgroup)))
(if (string? jobg-count)
(string->number jobg-count)
jobg-count))))
(if (> (+ num-running num-running-in-jobgroup) 0)
(set! *runs:can-run-more-tests-count* (+ *runs:can-run-more-tests-count* 1)))
(if (not (eq? *last-num-running-tests* num-running))
(begin
(debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running)
(set! *last-num-running-tests* num-running)))
(if (not (eq? 0 *globalexitstatus*))
(list #f num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)
(let ((can-not-run-more (cond
;; if max-concurrent-jobs is set and the number running is greater
;; than it than cannot run more jobs
((and max-concurrent-jobs (>= num-running max-concurrent-jobs))
(if (runs:lownoise "mcj msg" 60)
(debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running
", max_concurrent_jobs: " max-concurrent-jobs))
#t)
;; if job-group-limit is set and number of jobs in the group is greater
;; than the limit then cannot run more jobs of this kind
((and job-group-limit
(>= num-running-in-jobgroup job-group-limit))
(if (runs:lownoise (conc "maxjobgroup " jobgroup) 60)
(debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup
" in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record))
(debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup
" in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit))
#t)
(else #f))))
(list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)))))
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
(define (runs:run-tests target runname test-patts user flags) ;; test-names
(common:clear-caches) ;; clear all caches
|
| ︙ | | |
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
|
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
|
-
+
|
;; (set! last-time-incomplete (current-seconds))
;; (cdb:remote-run db:find-and-mark-incomplete #f)))
;; (print "Top of loop, hed=" hed ", tal=" tal " ,reruns=" reruns)
(let* ((test-record (hash-table-ref test-records hed))
(test-name (tests:testqueue-get-testname test-record))
(tconfig (tests:testqueue-get-testconfig test-record))
(jobgroup (config-lookup tconfig "requirements" "jobgroup"))
(jobgroup (config-lookup tconfig "test_meta" "jobgroup"))
(testmode (let ((m (config-lookup tconfig "requirements" "mode")))
(if m (string->symbol m) 'normal)))
(waitons (tests:testqueue-get-waitons test-record))
(priority (tests:testqueue-get-priority test-record))
(itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f
(items (tests:testqueue-get-items test-record))
(item-path (item-list->path itemdat))
|
| ︙ | | |
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
|
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
|
-
+
-
+
+
|
;;======================================================================
;; Update the test_meta table for this test
(define (runs:update-test_meta test-name test-conf)
(let ((currrecord (rmt:testmeta-get-record test-name)))
(if (not currrecord)
(begin
(set! currrecord (make-vector 10 #f))
(set! currrecord (make-vector 11 #f))
(rmt:testmeta-add-record test-name)))
(for-each
(lambda (key)
(let* ((idx (cadr key))
(fld (car key))
(val (config-lookup test-conf "test_meta" fld)))
;; (debug:print 5 "idx: " idx " fld: " fld " val: " val)
(if (and val (not (equal? (vector-ref currrecord idx) val)))
(begin
(print "Updating " test-name " " fld " to " val)
(rmt:testmeta-update-field test-name fld val)))))
'(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)))))
'(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))
;; Update test_meta for all tests
(define (runs:update-all-test_meta db)
(let ((test-names (tests:get-all))) ;; (tests:get-valid-tests)))
(for-each
(lambda (test-name)
(let* ((test-conf (mt:lazy-read-test-config test-name)))
(if test-conf (runs:update-test_meta test-name test-conf))))
(hash-table-keys test-names))))
;; This could probably be refactored into one complex query ...
;; NOT PORTED - DO NOT USE YET
;;
(define (runs:rollup-run keys runname user keyvals)
(debug:print 4 "runs:rollup-run, keys: " keys " :runname " runname " user: " user)
(let* ((db #f)
;; register run operates on the main db
(new-run-id (rmt:register-run keyvals runname "new" "n/a" user))
(prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%"))
(curr-tests (mt:get-tests-for-run new-run-id "%/%" '() '()))
(curr-tests-hash (make-hash-table)))
(rmt:update-run-event_time new-run-id)
;; index the already saved tests by testname and itemdat in curr-tests-hash
(for-each
|
| ︙ | | |
Modified server.scm
from [ddc244d255]
to [29b0c253ff].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
-
+
|
;; Copyright 2006-2012, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(require-extension (srfi 18) extras tcp s11n)
(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils)
;; (use zmq)
(use spiffy uri-common intarweb http-client spiffy-request-vars)
(declare (unit server))
(declare (uses common))
|
| ︙ | | |
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
|
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
|
-
+
-
-
+
+
|
;; S E R V E R
;;======================================================================
;; Call this to start the actual server
;;
;; all routes though here end in exit ...
(define (server:launch transport)
(define (server:launch transport run-id)
(if (not *toppath*)
(if (not (setup-for-run))
(begin
(debug:print 0 "ERROR: cannot find megatest.config, exiting")
(exit))))
(debug:print-info 2 "Starting server using " transport " transport")
(set! *transport-type* transport)
(case transport
;; ((fs) (exit)) ;; there is no "fs" server transport
((fs http) (http-transport:launch))
((zmq) (zmq-transport:launch))
((fs http) (http-transport:launch run-id))
((zmq) (zmq-transport:launch run-id))
(else
(debug:print "WARNING: unrecognised transport " transport)
(exit))))
;;======================================================================
;; Q U E U E M A N A G E M E N T
;;======================================================================
|
| ︙ | | |
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
|
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
|
-
-
+
+
-
+
+
+
-
+
|
(let ((pub-socket (vector-ref *runremote* 1)))
(send-message pub-socket return-addr send-more: #t)
(send-message pub-socket (db:obj->string (vector success/fail query-sig result)))))
(else
(debug:print 0 "ERROR: unrecognised transport type: " *transport-type*)
result)))
(define (server:ensure-running)
(let loop ((servers (open-run-close tasks:get-best-server tasks:open-db))
(define (server:ensure-running run-id)
(let loop ((servers (open-run-close tasks:get-server tasks:open-db run-id))
(trycount 0))
(if (or (not servers)
(null? servers))
(begin
(if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds)
(let ((cmdln (conc (if (getenv "MT_MEGATEST") (getenv "MT_MEGATEST") "megatest")
" -server - -daemonize")))
" -server - -run-id " run-id " &> " *toppath* "/db/" run-id ".log &")))
(debug:print 0 "INFO: Starting server (" cmdln ") as none running ...")
;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))
;; no need to use fork, no need to do the list-servers trick. Just start the damn server, it will exit on it's own
;; if there is an existing server
(push-directory *toppath*)
(system cmdln)
(pop-directory)
(thread-sleep! 3)
;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http")))
)
(begin
(debug:print-info 0 "Waiting for server to start")
(thread-sleep! 4)))
(if (< trycount 10)
(loop (open-run-close tasks:get-best-server tasks:open-db)
(loop (open-run-close tasks:get-server tasks:open-db run-id)
(+ trycount 1))
(debug:print 0 "WARNING: Couldn't start or find a server.")))
(debug:print 2 "INFO: Server(s) running " servers)
)))
|
Modified tasks.scm
from [c9fadd13bc]
to [db6ec670d8].
| ︙ | | |
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
-
+
-
|
(begin
(sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER PRIMARY KEY,
action TEXT DEFAULT '',
owner TEXT,
state TEXT DEFAULT 'new',
target TEXT DEFAULT '',
name TEXT DEFAULT '',
test TEXT DEFAULT '',
testpatt TEXT DEFAULT '',
item TEXT DEFAULT '',
|
| ︙ | | |
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
-
-
+
+
|
pubport INTEGER,
start_time TIMESTAMP,
priority INTEGER,
state TEXT,
mt_version TEXT,
heartbeat TIMESTAMP,
transport TEXT,
run_id INTEGER,
CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));")
run_id INTEGER);")
;; CONSTRAINT servers_constraint UNIQUE (pid,hostname,port));")
(sqlite3:execute mdb "CREATE TABLE IF NOT EXISTS clients (id INTEGER PRIMARY KEY,
server_id INTEGER,
pid INTEGER,
hostname TEXT,
cmdline TEXT,
login_time TIMESTAMP,
logout_time TIMESTAMP DEFAULT -1,
|
| ︙ | | |
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
|
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
|
-
-
-
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
-
-
-
-
-
-
-
+
+
+
+
+
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
-
+
-
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
-
-
+
+
-
-
+
-
-
-
-
+
-
-
-
-
+
|
(define (tasks:hostinfo-get-interface vec) (vector-ref vec 1))
(define (tasks:hostinfo-get-port vec) (vector-ref vec 2))
(define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3))
(define (tasks:hostinfo-get-transport vec) (vector-ref vec 4))
(define (tasks:hostinfo-get-pid vec) (vector-ref vec 5))
(define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6))
;; state: 'live, 'shutting-down, 'dead
(define (tasks:server-register mdb pid interface port priority state transport #!key (pubport -1))
(debug:print-info 11 "tasks:server-register " pid " " interface " " port " " priority " " state)
"INSERT OR REPLACE INTO servers (pid,hostname,port,pubport,start_time,priority,state,mt_version,heartbeat,interface,transport)
VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?, strftime('%s','now'),?,?);"
pid (get-host-name) port pubport priority (conc state)
(common:version-signature)
interface
(conc transport))
"INSERT INTO servers (pid,hostname,port,pubport,start_time, priority,state,mt_version,heartbeat, interface,transport,run_id)
VALUES(?, ?, ?, ?, strftime('%s','now'), ?, ?, ?, strftime('%s','now'),?, ?, ?);"
(current-process-id) ;; pid
(get-host-name) ;; hostname
-1 ;; port
-1 ;; pubport
(random 1000) ;; priority (used a tiebreaker on get-available)
"available" ;; state
(common:version-signature) ;; mt_version
-1 ;; interface
"http" ;; transport
(vector
(tasks:server-get-server-id mdb (get-host-name) interface port pid)
interface
port
pubport
transport
;; NB// two servers with same pid on different hosts will be removed from the list if pid: is used!
(define (tasks:server-deregister mdb hostname #!key (port #f)(pid #f)(action 'delete))
(debug:print-info 11 "server-deregister " hostname ", port " port ", pid " pid)
(if *db-write-access*
(if pid
(case action
((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE pid=?;" pid))
(else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE pid=?;" pid)))
(if port
(case action
((delete)(sqlite3:execute mdb "DELETE FROM servers WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port))
(else (sqlite3:execute mdb "UPDATE servers SET state='dead' WHERE (interface=? or hostname=?) AND port=?;" hostname hostname port)))
(debug:print 0 "ERROR: tasks:server-deregister called with neither pid nor port specified")))))
(define (tasks:server-deregister-self mdb hostname)
(define (tasks:server-set-interface-port mdb server-id interface port)
(tasks:server-deregister mdb hostname pid: (current-process-id)))
;; need a simple call for robustly removing records given host and port
(define (tasks:server-delete mdb hostname port)
(tasks:server-deregister mdb hostname port: port action: 'delete))
(define (tasks:server-get-server-id mdb hostname iface port pid)
(debug:print-info 12 "tasks:server-get-server-id " mdb " " hostname " " iface " " port " " pid)
(let ((res #f))
(lambda (id)
(set! res id))
(lambda (a . b)
(set! res (cons (apply vector a b) res)))
mdb
(cond
((and hostname pid) "SELECT id FROM servers WHERE hostname=? AND pid=?;")
((and iface port) "SELECT id FROM servers WHERE interface=? AND port=?;")
((and hostname port) "SELECT id FROM servers WHERE hostname=? AND port=?;")
(else
(begin
(debug:print 0 "ERROR: tasks:server-get-server-id needs (hostname and pid) OR (iface and port) OR (hostname and port)")
"SELECT id FROM servers WHERE pid=-999;")))
(if hostname hostname iface)(if pid pid port))
res))
|
| ︙ | | |
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
|
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
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
-
-
-
-
-
+
-
-
-
-
-
+
+
-
-
+
-
-
-
+
+
+
-
-
-
-
+
-
-
-
+
+
-
-
-
+
+
+
-
-
-
-
-
-
-
-
-
+
+
-
-
-
-
+
+
+
+
-
-
-
-
-
+
+
+
+
|
(heartbeat-delta 99e9))
(sqlite3:for-each-row
(lambda (delta)
(set! heartbeat-delta delta))
mdb "SELECT strftime('%s','now')-heartbeat FROM servers WHERE id=?;" server-id)
(< heartbeat-delta 10)))
(define (tasks:client-register mdb pid hostname cmdline)
(sqlite3:execute
mdb
"INSERT OR REPLACE INTO clients (server_id,pid,hostname,cmdline,login_time) VALUES(?,?,?,?,strftime('%s','now'));")
(tasks:server-get-server-id mdb hostname #f #f pid)
pid hostname cmdline)
(define (tasks:client-logout mdb pid hostname cmdline)
(sqlite3:execute
mdb
"UPDATE clients SET logout_time=strftime('%s','now') WHERE pid=? AND hostname=? AND cmdline=?;"
pid hostname cmdline))
(define (tasks:get-logged-in-clients mdb server-id)
(let ((res '()))
(sqlite3:for-each-row
(lambda (id server-id pid hostname cmdline login-time logout-time)
(set! res (cons (vector id server-id pid hostname cmdline login-time lougout-time) res)))
mdb
"SELECT id,server_id,pid,hostname,cmdline,login_time,logout_time FROM clients WHERE server_id=?;"
server-id)))
(define (tasks:have-clients? mdb server-id)
(null? (tasks:get-logged-in-clients mdb server-id)))
;; ping each server in the db and return first found that responds.
;; remove any others. will not necessarily remove all!
(define (tasks:get-best-server mdb)
(let ((res '())
(best #f)
(transport (if (and *transport-type*
(not (eq? *transport-type* 'fs)))
(conc *transport-type*)
"%")))
(set! res (cons (vector id interface port pubport transport pid hostname) res))
(set! res (vector id interface port pubport transport pid hostname)))
;;(debug:print-info 2 "Found existing server " hostname ":" port " registered in db"))
)
AND mt_version=? AND transport LIKE ?
ORDER BY start_time DESC LIMIT 1;" (common:version-signature) transport)
AND mt_version=? AND run_id=? AND state='running'
ORDER BY start_time DESC LIMIT 1;" (common:version-signature) run-id)
;; for now we are keeping only one server registered in the db, return #f or first server found
(if (null? res) #f (car res))))
;; BUG: This logic is probably needed unless methodology changes completely...
;;
;; (if (null? res) #f
;; (let loop ((hed (car res))
;; (tal (cdr res)))
;; ;; (print "hed=" hed ", tal=" tal)
;; (let* ((host (list-ref hed 0))
;; (iface (list-ref hed 1))
;; (port (list-ref hed 2))
;; (pid (list-ref hed 4))
;; (alive (open-run-close tasks:server-alive? tasks:open-db #f hostname: host port: port)))
;; (if alive
;; (begin
;; (debug:print-info 2 "Found an existing, alive, server " host ", " port ".")
;; (list host iface port))
;; (begin
;; (debug:print-info 1 "Marking " host ":" port " as dead in server registry.")
;; (if port
;; (open-run-close tasks:server-deregister tasks:open-db host port: port)
;; (open-run-close tasks:server-deregister tasks:open-db host pid: pid))
;; (if (null? tal)
;; #f
;; (loop (car tal)(cdr tal))))))))))
(define (tasks:remove-server-records mdb)
(sqlite3:execute mdb "DELETE FROM servers;"))
(define (tasks:get-all-servers mdb)
(let ((res '()))
(sqlite3:for-each-row
(lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport)
(define (tasks:mark-server hostname port pid state transport)
(if port
(open-run-close tasks:server-deregister tasks:open-db hostname port: port)
(open-run-close tasks:server-deregister tasks:open-db hostname pid: pid)))
|
| ︙ | | |
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
|
257
258
259
260
261
262
263
264
265
266
267
268
269
270
|
-
-
-
-
-
-
-
-
-
-
-
-
|
(begin
(debug:print-info 1 "Sending signal/term to " pid " on " hostname)
(process-signal pid signal/term) ;; local machine, send sig term
(thread-sleep! 5) ;; give it five seconds to die peacefully then do a brutal kill
(process-signal pid signal/kill))
(debug:print 0 "WARNING: Can't kill frozen server on remote host " hostname))))))
(define (tasks:get-all-servers mdb)
(let ((res '()))
(sqlite3:for-each-row
(lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport)
(set! res (cons (vector id pid hostname interface port pubport start-time priority state mt-version last-update transport) res)))
mdb
"SELECT id,pid,hostname,interface,port,pubport,start_time,priority,state,mt_version,strftime('%s','now')-heartbeat AS last_update,transport FROM servers ORDER BY start_time DESC;")
res))
|
| ︙ | | |
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
|
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
|
-
-
+
+
|
(set! res count))
mdb
"SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;"
(car (user-information (current-user-id))))
res))
;; register a task
(define (tasks:add mdb action owner target runname test item params)
(sqlite3:execute mdb "INSERT INTO tasks_queue (action,owner,state,target,name,test,item,params,creation_time,execution_time)
(define (tasks:add mdb action owner target runname testpatt params)
(sqlite3:execute mdb "INSERT INTO tasks_queue (action,owner,state,target,name,testpatt,params,creation_time,execution_time)
VALUES (?,?,'new',?,?,?,?,?,strftime('%s','now'),0);"
action
owner
target
runname
test
item
|
| ︙ | | |
Modified tests/Makefile
from [7520ced67a]
to [f03136dea1].
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
|
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
|
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
-
+
|
#
# run some tests
BINPATH=$(shell readlink -m $(PWD)/../bin)
MEGATEST=$(BINPATH)/megatest
DASHBOARD=$(BINPATH)/dashboard
PATH := $(BINPATH):$(PATH)
RUNNAME := $(shell date +w%V.%u.%H.%M)
IPADDR := "-"
# Set SERVER to "-server -"
SERVER =
DEBUG = 1
LOGGING =
BINPATH = $(shell readlink -m $(PWD)/../bin)
MEGATEST = $(BINPATH)/megatest
DASHBOARD = $(BINPATH)/dashboard
PATH := $(BINPATH):$(PATH)
RUNNAME := $(shell date +w%V.%u.%H.%M)
IPADDR := "-"
RUNID := 1
SERVER =
DEBUG = 1
LOGGING =
OS = $(shell grep ID /etc/*-release|cut -d= -f2)
FS = $(shell df -T .|tail -1|awk '{print $$2}')
VER = $(shell fsl info|grep checkout|awk '{print $$2}'|cut -c 1-5)
# The NEWTARGET causes some tests to fail. Do not use until this is fixed.
NEWTARGET = "$(OS)/$(FS)/$(VER)"
TARGET = "ubuntu/nfs/none"
all : test1 test2 test3 test4 test5 test6 test7 test8 test9
server :
cd ..;make;make install
cd fullrun;../../bin/megatest -server - -debug 22
cd fullrun;../../bin/megatest -server - -debug 22 -run-id $(RUNID)
stopserver :
cd ..;make && make install
cd fullrun;$(MEGATEST) -stop-server 0
repl :
cd ..;make && make install
|
| ︙ | | |
Modified tests/fullrun/config/mt_include_1.config
from [4c90d470ad]
to [22a36f6bc8].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
-
-
+
+
|
[setup]
# exectutable /path/to/megatest
max_concurrent_jobs 250
linktree #{getenv MT_RUN_AREA_HOME}/tmp/mt_links
[jobtools]
useshell yes
# ## launcher launches jobs, the job is managed on the target host
## by megatest, comment out launcher to run local
# workhosts localhost hermes
# launcher exec nbfake
launcher nbfake
# launcher nbfake
launcher loadrunner
# launcher echo
# launcher nbfind
# launcher nodanggood
## use "xterm -e csi -- " as a launcher to examine the launch environment.
## exit with (exit)
|
| ︙ | | |
Modified tests/fullrun/megatest.config
from [eb4e1b22b2]
to [394e6d468f].
| ︙ | | |
119
120
121
122
123
124
125
|
119
120
121
122
123
124
125
126
127
128
129
|
+
+
+
+
|
## -or-
## name /path/to/area
[disks]
disk0 /foobarbazz
[include config/mt_include_2.config]
[include #{getenv USER}_testing.config]
[jobgroups]
sqlite3 6
blockz 10
|
Modified tests/fullrun/tests/blocktestxz/testconfig
from [ea79db52b2]
to [689bce3544].
| ︙ | | |
14
15
16
17
18
19
20
|
14
15
16
17
18
19
20
21
22
|
+
+
|
description This test will fail causing the dependent test "testxz"\
to never run. This triggers the code that must determine\
that a test will never be run and thus remove it from\
the queue of tests to be run.
tags first,single
reviewed 1/1/1965
jobgroup blockz
|
Modified tests/fullrun/tests/priority_1/testconfig
from [a4d944cb23]
to [737fc2258c].
1
2
3
4
5
6
7
8
9
10
11
12
13
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
|
+
|
[setup]
runscript main.sh
[requirements]
priority 1
[test_meta]
jobgroup sqlite3
author matt
owner bob
description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS
tags first,single
reviewed 09/10/2011, by Matt
|
Modified tests/fullrun/tests/priority_2/testconfig
from [6cbcfb8c99]
to [7fc8d055ec].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
|
+
|
[setup]
runscript main.sh
[requirements]
priority 2
# runtimelim 1d 1h 1m 10s
runtimelim 20s
[test_meta]
jobgroup sqlite3
author matt
owner bob
description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS
tags first,single
reviewed 09/10/2011, by Matt
|
Modified tests/fullrun/tests/priority_3/testconfig
from [3693d6b2ed]
to [392fa56879].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
|
+
|
[setup]
runscript main.sh
[requirements]
priority 3
[test_meta]
jobgroup sqlite3
author matt
owner bob
description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS
tags first,single
reviewed 09/10/2011, by Matt
|
Modified tests/fullrun/tests/priority_4/testconfig
from [331e061c45]
to [0f3ea908bb].
1
2
3
4
5
6
7
8
9
10
11
12
13
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
|
+
|
[setup]
runscript main.sh
[requirements]
priority 4
[test_meta]
jobgroup sqlite3
author matt
owner bob
description This test checks that a multi-lineitem test with mix of pass and non-fail rolls up a PASS
tags first,single
reviewed 09/10/2011, by Matt
|
Modified tests/fullrun/tests/sqlitespeed/testconfig
from [a64305aaab]
to [d7b60872d2].
1
2
3
4
5
6
7
8
9
10
11
|
1
2
3
4
5
6
7
8
9
10
11
12
13
|
+
+
|
[setup]
runscript runscript.rb
tags non important,dumb junk
[requirements]
waiton runfirst
[items]
MANYITEMS [system (env > envfile.txt;echo aa ab ac ad ae af ag ah ai)]
# BORKED
[test_meta]
jobgroup sqlite3
|
Modified tests/fullrun/tests/test_mt_vars/currentisblah.sh
from [f9e79a0076]
to [e891695e2f].
1
2
3
|
1
2
3
|
-
+
|
#!/usr/bin/env bash
grep -e '^CURRENT' megatest.sh | grep /tmp/nada
grep -e '^export CURRENT' megatest.sh | grep /tmp/nada
|
Added tests/watch-monitor.sh version [408ccfb929].
|
1
2
3
4
5
6
7
8
|
+
+
+
+
+
+
+
+
|
#!/bin/bash
sqlite3 fullrun/db/monitor.db << EOF
.header on
.mode column
select * from servers;
.q
EOF
|
| | | | | | |
Modified utils/installall.sh
from [e3bee64528]
to [e265334564].
| ︙ | | |
300
301
302
303
304
305
306
307
308
309
310
311
312
313
|
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
|
+
+
+
+
+
+
|
# disabled zmq # make install
# disabled zmq # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX zmq
# disabled zmq # # CSC_OPTIONS="-I$PREFIX/include -L$CSCLIBS" $CHICKEN_INSTALL $PROX -deploy -prefix $DEPLOYTARG zmq
# disabled zmq # fi
# disabled zmq # fi # if zmq is in /usr/lib
# disabled zmq #
cd $BUILDHOME
git clone https://bitbucket.org/DerGuteMoritz/zmq/commits/branch/3.2 zmq-3.2
cd zmq-3.2
chicken-install
cd $BUILDHOME
## WEBKIT=WebKit-r131972
## if ! [[ -e ${WEBKIT}.tar.bz2 ]] ; then
## # http://builds.nightly.webkit.org/files/trunk/src/WebKit-r131972.tar.bz2
## wget http://builds.nightly.webkit.org/files/trunk/src/${WEBKIT}.tar.bz2
## fi
##
|
| ︙ | | |
Added utils/loadrunner version [4b5138d43f].
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
#!/bin/bash
# load=`uptime|awk '{print $10}'|cut -d, -f1`
load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'`
if which cpucheck > /dev/null;then
numcpu=`cpucheck|tail -1|awk '{print $6}'`
elif which lscpu > /dev/null;then
numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'`
else
numcpu=2
fi
# NB// max_load is in units of percent.
#
lperc=`echo "100 * $load / $numcpu"|bc`
if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then
max_load=100
else
max_load=$MAX_ALLOWED_LOAD
fi
if [[ $lperc -lt $max_load ]];then
echo "Load acceptable: lperc=$lperc %, max_load=$max_load %, load=$load, numcpu=$numcpu, MAX_ALLOWED_LOAD=$MAX_ALLOWED_LOAD %"
echo "Starting command: \"$@\""
nbfake "$@"
else
# echo "Load too high: lperc=$lperc, max_load=$max_load, waiting two minutes before trying to run command: \"$@\""
echo "nbload $@" | at now + 2 minutes 2> /dev/null
fi
|
| | | | | | | | | | | | | | | | | | | | | | | | | | | |
Modified utils/mtgetfile
from [325e266edf]
to [071134089a].
| ︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
-
+
|
(key-vals (if target (keys:target->keyval keys target) #f))
(errmsg (cond
((not key-vals) "missing -target")
((not target) "missing -target")
((not scriptn) "missing file name to find")
(else #f))))
(if errmsg
(begin
(begin
(print "THEPATH: Missing required switch: " errmsg)
(print "THEPATH: Usage: mtgetfile -target target scriptname [searchpath]")
(exit)))
(print "THEPATH: key-vals=" key-vals " path=" path " scriptn=" scriptn))
EOF
}
|
| ︙ | | |
Deleted utils/nbload version [02152a07a2].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
#!/bin/bash
# load=`uptime|awk '{print $10}'|cut -d, -f1`
load=`uptime|perl -pe 's/.*: (\d+.\d+),.*/$1/'`
if which cpucheck > /dev/null;then
numcpu=`cpucheck|tail -1|awk '{print $6}'`
else
numcpu=`lscpu|grep "CPU.s.:"|awk '{print $2}'`
fi
lperc=`echo "100 * $load / $numcpu"|bc`
if [[ "x$MAX_ALLOWED_LOAD" == "x" ]]; then
max_load=50
else
max_load=$MAX_ALLOWED_LOAD
fi
if [[ $lperc -lt $max_load ]];then
echo "$@" | at now + 0 minutes
elif [[ "x$NBLAUNCHER" == "x" ]];then
echo "nbfind $@" | at now + 2 minutes
else
$NBLAUNCHER "$@"
fi
|
