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
|
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
|
-
+
-
-
+
-
-
|
;;======================================================================
;; 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.
;;======================================================================
(use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack
matchable)
matchable regex posix srfi-18 extras
(require-extension regex posix)
pkts (prefix dbi dbi:))
(require-extension (srfi 18) extras tcp rpc)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit common))
(declare (uses keys))
(include "common_records.scm")
;; (require-library margs)
;; (include "margs.scm")
;; (define old-exit exit)
|
︙ | | |
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
|
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
|
+
+
+
+
+
-
+
+
+
+
+
+
-
+
-
-
+
+
|
(define (common:get-last-run-version-number)
(string->number
(substring (common:get-last-run-version) 0 6)))
(define (common:set-last-run-version)
(rmt:set-var "MEGATEST_VERSION" (common:version-signature)))
;; postive number if megatest version > db version
;; negative number if megatest version < db version
(define (common:version-db-delta)
(- megatest-version (common:get-last-run-version-number)))
(define (common:version-changed?)
(not (equal? (common:get-last-run-version)
(common:version-signature))))
(common:version-signature))))
(define (common:api-changed?)
(not (equal? (substring (->string megatest-version) 0 4)
(substring (common:get-last-run-version) 0 4))))
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct)
(db:multi-db-sync
dbstruct
'schema
;; 'new2old
'killservers
'dejunk
;; 'adj-testids
'adj-target
;; 'old2new
'new2old
'schema)
(if (common:version-changed?)
)
(if (common:api-changed?)
(common:set-last-run-version)))
;; Rotate logs, logic:
;; if > 500k and older than 1 week:
;; remove previous compressed log and compress this log
;; WARNING: This proc operates assuming that it is in the directory above the
;; logs directory you wish to log-rotate.
|
︙ | | |
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
|
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
|
-
+
-
+
|
"logs"))
;; Force a megatest cleanup-db if version is changed and skip-version-check not specified
;; Do NOT check if not on homehost!
;;
(define (common:exit-on-version-changed)
(if (common:on-homehost?)
(if (common:version-changed?)
(if (common:api-changed?)
(let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
(dbfile (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.db"))
(read-only (not (file-write-access? dbfile)))
(dbstruct (db:setup)))
(dbstruct (db:setup #t)))
(debug:print 0 *default-log-port*
"WARNING: Version mismatch!\n"
" expected: " (common:version-signature) "\n"
" got: " (common:get-last-run-version))
(cond
((get-environment-variable "MT_SKIP_DB_MIGRATE") #t)
((and (file-exists? mtconf) (file-exists? dbfile) (not read-only)
|
︙ | | |
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
|
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
|
+
-
+
+
-
-
-
-
+
+
+
+
+
-
+
|
#f ;; I don't really care why this failed (at least for now)
(delete-file* fname)))
;;======================================================================
;; S T A T E S A N D S T A T U S E S
;;======================================================================
;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls
(define *common:std-states*
(define *common:std-states* ;; for toggle buttons in dashboard
'((0 "ARCHIVED")
(1 "STUCK")
(2 "KILLREQ")
(3 "KILLED")
(4 "NOT_STARTED")
(5 "COMPLETED")
(6 "LAUNCHED")
(7 "REMOTEHOSTSTART")
(8 "RUNNING")
))
;; BBnote: *common:std-statuses* dashboard filter control and test control status buttons defined here; used in set-fields-panel and dboard:make-controls
(define *common:std-statuses*
'(;; (0 "DELETED")
(1 "n/a")
(2 "PASS")
(3 "CHECK")
(4 "SKIP")
(5 "WARN")
(6 "WAIVED")
(3 "SKIP")
(4 "WARN")
(5 "WAIVED")
(6 "CHECK")
(7 "STUCK/DEAD")
(8 "FAIL")
(9 "ABORT")))
(define *common:ended-states* ;; states which indicate the test is stopped and will not proceed
'("COMPLETED" "ARCHIVED" "KILLED" "KILLREQ" "STUCK" "INCOMPLETE"))
(define *common:badly-ended-states* ;; these roll up as CHECK, i.e. results need to be checked
'("KILLED" "KILLREQ" "STUCK" "INCOMPLETE" "DEAD"))
;; BBnote: *common:running-states* used from db:set-state-status-and-roll-up-items
(define *common:running-states* ;; test is either running or can be run
'("RUNNING" "REMOTEHOSTSTART" "LAUNCHED"))
'("RUNNING" "REMOTEHOSTSTART" "LAUNCHED" "STARTED"))
(define *common:cant-run-states* ;; These are stopping conditions that prevent a test from being run
'("COMPLETED" "KILLED" "UNKNOWN" "INCOMPLETE" "ARCHIVED"))
(define *common:not-started-ok-statuses* ;; if not one of these statuses when in not_started state treat as dead
'("n/a" "na" "PASS" "FAIL" "WARN" "CHECK" "WAIVED" "DEAD" "SKIP"))
|
︙ | | |
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
|
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
|
-
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(getenv "MT_TESTSUITE_NAME")
(if (string? *toppath* )
(pathname-file *toppath*)
#f))) ;; (pathname-file (current-directory)))))
(define common:get-area-name common:get-testsuite-name)
(define (common:get-db-tmp-area)
(define (common:get-db-tmp-area . junk)
(if *db-cache-path*
*db-cache-path*
(if *toppath*
(let ((dbpath (create-directory (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
(common:get-testsuite-name) "/"
(string-translate *toppath* "/" ".")) #t)))
(set! *db-cache-path* dbpath)
dbpath)
(if *toppath* ;; common:get-create-writeable-dir
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
(exit 1))
(let ((dbpath (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
(common:get-testsuite-name) "/"
(string-translate *toppath* "/" ".")))))) ;; #t))))
(set! *db-cache-path* dbpath)
dbpath))
#f)))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
(define (common:get-signature str)
(message-digest-string (md5-primitive) str))
|
︙ | | |
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
|
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
|
-
+
|
(if (common:low-noise-print 30)
(debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id)" this-wd-num="this-wd-num)))))))
;; TODO: for multiple areas, we will have multiple watchdogs; and multiple threads to manage
(define (common:watchdog)
(debug:print-info 13 *default-log-port* "common:watchdog entered.")
(if (common:on-homehost?)
(let ((dbstruct (db:setup)))
(let ((dbstruct (db:setup #t)))
(debug:print-info 13 *default-log-port* "after db:setup with dbstruct="dbstruct)
(cond
((dbr:dbstruct-read-only dbstruct)
(debug:print-info 13 *default-log-port* "loading read-only watchdog")
(common:readonly-watchdog dbstruct))
(else
(debug:print-info 13 *default-log-port* "loading writable-watchdog.")
|
︙ | | |
967
968
969
970
971
972
973
974
975
976
977
978
979
980
|
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
|
+
+
+
+
|
(define (common:args-get-testpatt rconf)
(let* (;; (tagexpr (args:get-arg "-tagexpr"))
;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f))
(testpatt-key (if (args:get-arg "--modepatt") (args:get-arg "--modepatt") "TESTPATT"))
(args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%"))
(rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f)))
(cond
((args:get-arg "--modepatt") ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig
(if rconf
(runconfigs-get rconf testpatt-key)
#f)) ;; We do NOT fall back to "%"
;; (tags-testpatt
;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt)
;; tags-testpatt)
((and (equal? args-testpatt "%") rtestpatt)
(debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt)
rtestpatt)
(else args-testpatt))))
|
︙ | | |
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
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
-
-
-
+
+
+
+
+
-
+
|
(define (common:directory-exists? path-string)
;;;; TODO: catch permission denied exceptions and emit appropriate warnings, eg: system error while trying to access file: "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/randy-slow/reproduce/q...
(common:false-on-exception (lambda () (directory-exists? path-string))
message: (conc "Unable to access path: " path-string)
))
;; does the directory exist and do we have write access?
;;
;; returns the directory or #f
;;
(define (common:directory-writable? path-string)
(handle-exceptions
exn
#f
(if (and (directory-exists? path-string)
(file-write-access? path-string))
path-string
#f)))
(define (common:get-linktree)
(or (getenv "MT_LINKTREE")
(or (and *configdat*
(configf:lookup *configdat* "setup" "linktree"))
(if *configdat*
(configf:lookup *configdat* "setup" "linktree")
(if *toppath*
(conc *toppath* "/lt")
(if (file-exists? "megatest.config") ;; we are in the toppath (new area, mtutils compatible)
(conc (current-directory) "/lt")
#f)))))
#f))))
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
(define (common:get-fields cfgdat)
(let ((fields (hash-table-ref/default cfgdat "fields" '())))
(map car fields)))
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
(let* ((keys (if (hash-table? *configdat*) (keys:config-get-fields *configdat*) '()))
(let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
(getenv "MT_TARGET")))
(tlist (if target (string-split target "/" #t) '()))
(valid (if target
(or (null? keys) ;; probably don't know our keys yet
|
︙ | | |
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
|
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
|
+
+
+
+
+
+
+
+
+
+
|
target)
(if target
(begin
(debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
(if exit-if-bad (exit 1))
#f)
#f))))
;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
(if (getenv "MT_TEST_NAME")
(if (and (getenv "MT_ITEMPATH")
(not (equal? (getenv "MT_ITEMPATH") "")))
(getenv "MT_TEST_NAME")
(conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH")))
#f))
;; logic for getting homehost. Returns (host . at-home)
;; IF *toppath* is not set, wait up to five seconds trying every two seconds
;; (this is to accomodate the watchdog)
;;
(define (common:get-homehost #!key (trynum 5))
;; called often especially at start up. use mutex to eliminate collisions
|
︙ | | |
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
|
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
|
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
|
(if hh
(cdr hh)
#f)))
;; do we honor the caches of the config files?
;;
(define (common:use-cache?)
(not (or (args:get-arg "-no-cache")
(and *configdat*
(equal? (configf:lookup *configdat* "setup" "use-cache") "no")))))
(let ((res #t)) ;; priority by order of evaluation
(if *configdat*
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "no")
(set! res #f)
(if (equal? (configf:lookup *configdat* "setup" "use-cache") "yes")
(set! res #t))))
(if (args:get-arg "-no-cache")(set! res #f)) ;; overrides setting in "setup"
(if (getenv "MT_USE_CACHE")
(if (equal? (getenv "MT_USE_CACHE") "yes")
(set! res #t)
(if (equal? (getenv "MT_USE_CACHE") "no")
(set! res #f)))) ;; overrides -no-cache switch
res))
;; force use of server?
;;
(define (common:force-server?)
(let* ((force-setting (configf:lookup *configdat* "server" "force"))
(force-type (if force-setting (string->symbol force-setting) #f))
(force-result (case force-type
((#f) #f)
((always) #t)
((test) (if (args:get-arg "-execute") ;; we are in a test
#t
#f))
(else
(debug:print 0 *default-log-port* "ERROR: Bad server force setting " force-setting ", forcing server.")
#t)))) ;; default to requiring server
(if force-result
(begin
(debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".")
#t)
#f)))
;; do we honor the caches of the config files?
;;
(define (common:use-cache?)
(not (or (args:get-arg "-no-cache")
(and *configdat*
(equal? (configf:lookup *configdat* "setup" "use-cache") "no")))))
;;======================================================================
;; M I S C L I S T S
;;======================================================================
;; items in lista are matched value and position in listb
;; return the remaining items in listb or #f
;;
|
︙ | | |
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
|
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
|
-
-
-
-
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
((equal? status "WARN") "orange")
((equal? status "KILLED") "orange")
((equal? status "KILLREQ") "purple")
((equal? status "RUNNING") "blue")
((equal? status "ABORT") "brown")
(else "black")))
;;======================================================================
;; N A N O M S G C L I E N T
;;======================================================================
;; ;;======================================================================
;; ;; N A N O M S G C L I E N T
;; ;;======================================================================
;;
(define (server:get-best-guess-address hostname)
(let ((res #f))
(for-each
(lambda (adr)
(if (not (eq? (u8vector-ref adr 0) 127))
(set! res adr)))
;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
(vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
(string-intersperse
(map number->string
(u8vector->list
(if res res (hostname->ip hostname)))) ".")))
(define (common:send-dboard-main-changed)
(let* ((dashboard-ips (mddb:get-dashboards)))
(for-each
(lambda (ipadr)
(let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
(msg (conc "main " *toppath*))
(res (common:nm-send-receive-timeout soc msg)))
(if (not res) ;; couldn't reach that dashboard - remove it from db
(print "ERROR: couldn't reach dashboard " ipadr))
res))
dashboard-ips)))
;;======================================================================
;; D A S H B O A R D D B
;;======================================================================
(define (mddb:open-db)
(let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
(set-busy-handler! db (busy-timeout 10000))
(for-each
(lambda (qry)
(exec (sql db qry)))
(list
"CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
"CREATE TABLE IF NOT EXISTS dashboards (
id INTEGER PRIMARY KEY,
pid INTEGER,
username TEXT,
hostname TEXT,
ipaddr TEXT,
portnum INTEGER,
start_time TIMESTAMP DEFAULT (strftime('%s','now')),
CONSTRAINT hostport UNIQUE (hostname,portnum)
);"
))
db))
;; register a dashboard
;;
(define (mddb:register-dashboard port)
(let* ((pid (current-process-id))
(hostname (get-host-name))
(ipaddr (server:get-best-guess-address hostname))
(username (current-user-name)) ;; (car userinfo)))
(db (mddb:open-db)))
(print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
(exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
pid username hostname ipaddr port)
(close-database db)))
;; unregister a monitor
;;
(define (mddb:unregister-dashboard host port)
(let* ((db (mddb:open-db)))
(print "Register unregister monitor, host:port=" host ":" port)
(exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
(close-database db)))
;; get registered dashboards
;;
(define (mddb:get-dashboards)
(let ((db (mddb:open-db)))
(query fetch-column
(sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
;;
;;
;; (define (common:send-dboard-main-changed)
;; (let* ((dashboard-ips (mddb:get-dashboards)))
;; (for-each
;; (lambda (ipadr)
;; (let* ((soc (common:open-nm-req (conc "tcp://" ipadr)))
;; (msg (conc "main " *toppath*))
;; (res (common:nm-send-receive-timeout soc msg)))
;; (if (not res) ;; couldn't reach that dashboard - remove it from db
;; (print "ERROR: couldn't reach dashboard " ipadr))
;; res))
;; dashboard-ips)))
;;
;;
;; ;;======================================================================
;; ;; D A S H B O A R D D B
;; ;;======================================================================
;;
;; (define (mddb:open-db)
;; (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db"))))
;; (set-busy-handler! db (busy-timeout 10000))
;; (for-each
;; (lambda (qry)
;; (exec (sql db qry)))
;; (list
;; "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));"
;; "CREATE TABLE IF NOT EXISTS dashboards (
;; id INTEGER PRIMARY KEY,
;; pid INTEGER,
;; username TEXT,
;; hostname TEXT,
;; ipaddr TEXT,
;; portnum INTEGER,
;; start_time TIMESTAMP DEFAULT (strftime('%s','now')),
;; CONSTRAINT hostport UNIQUE (hostname,portnum)
;; );"
;; ))
;; db))
;;
;; ;; register a dashboard
;; ;;
;; (define (mddb:register-dashboard port)
;; (let* ((pid (current-process-id))
;; (hostname (get-host-name))
;; (ipaddr (server:get-best-guess-address hostname))
;; (username (current-user-name)) ;; (car userinfo)))
;; (db (mddb:open-db)))
;; (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username)
;; (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);")
;; pid username hostname ipaddr port)
;; (close-database db)))
;;
;; ;; unregister a monitor
;; ;;
;; (define (mddb:unregister-dashboard host port)
;; (let* ((db (mddb:open-db)))
;; (print "Register unregister monitor, host:port=" host ":" port)
;; (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port)
;; (close-database db)))
;;
;; ;; get registered dashboards
;; ;;
;; (define (mddb:get-dashboards)
;; (let ((db (mddb:open-db)))
;; (query fetch-column
;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;"))))
;;======================================================================
;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S
;;======================================================================
;;
;; [hosts]
;; arm cubie01 cubie02
|
︙ | | |
2275
2276
2277
2278
2279
2280
2281
2282
|
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(mthome-cfgfile (conc *toppath* "/.mtviews.config")))
(if (file-exists? mthome-cfgfile)
(read-config mthome-cfgfile view-cfgdat #t))
;; we load the home dir file AFTER the MTRAH file so the user can clobber settings when running the dashboard in read-only areas
(if (file-exists? home-cfgfile)
(read-config home-cfgfile view-cfgdat #t))
view-cfgdat))
;;======================================================================
;; Manage pkts, used in servers, tests and likely other contexts so put
;; in common
;;======================================================================
(define common:pkt-spec
'((server . ((action . a)
(pid . d)
(ipaddr . i)
(port . p)))
(test . ((cpuuse . c)
(diskuse . d)
(item-path . i)
(runname . r)
(state . s)
(target . t)
(status . u)))))
(define (common:get-pkts-dirs mtconf use-lt)
(let* ((pktsdirs-str (or (configf:lookup mtconf "setup" "pktsdirs")
(and use-lt
(conc *toppath* "/lt/.pkts"))))
(pktsdirs (if pktsdirs-str
(string-split pktsdirs-str " ")
#f)))
pktsdirs))
(define (common:with-queue-db mtconf proc #!key (use-lt #f)(toppath-in #f))
(let* ((pktsdirs (common:get-pkts-dirs mtconf use-lt))
(pktsdir (if pktsdirs (car pktsdirs) #f))
(toppath (or (configf:lookup mtconf "scratchdat" "toppath")
toppath-in))
(pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir)))
(if (not (and pktsdir toppath pdbpath))
(begin
(print "ERROR: settings are missing in your megatest.config for area management.")
(print " you need to have pktsdir in the [setup] section."))
(let* ((pdb (open-queue-db pdbpath "pkts.db"
schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
(proc pktsdirs pktsdir pdb)
(dbi:close pdb)))))
(define (common:load-pkts-to-db mtconf)
(common:with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(for-each
(lambda (pktsdir) ;; look at all
(if (and (file-exists? pktsdir)
(directory? pktsdir)
(file-read-access? pktsdir))
(let ((pkts (glob (conc pktsdir "/*.pkt"))))
(for-each
(lambda (pkt)
(let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
(exists (lookup-by-uuid pdb uuid #f)))
(if (not exists)
(let* ((pktdat (string-intersperse
(with-input-from-file pkt read-lines)
"\n"))
(apkt (pkt->alist pktdat))
(ptype (alist-ref 'T apkt)))
(add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
(debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
(debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
)))
pkts))))
pktsdirs))))
(define (common:get-pkt-alists pkts)
(map (lambda (x)
(alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
pkts))
;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending
;; also delete duplicates by target i.e. (car pkt)
;;
(define (common:get-pkt-times pkts)
(delete-duplicates
(sort
(map (lambda (x)
`(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
pkts)
(lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending
(lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target
|
︙ | | |
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
|
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
|
+
+
+
+
+
+
+
+
|
"-guimonitor"
"-main"
"-v"
"-q"
"-use-db-cache"
"-skip-version-check"
"-repl"
"-rh5.11" ;; fix to allow running on rh5.11
)
args:arg-hash
0))
(if (not (null? remargs))
(begin
(print "Unrecognised arguments: " (string-intersperse remargs " "))
(exit)))
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
;; TODO: Move this inside (main)
;;
(if (not (launch:setup))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
;; deal with RH 5.11 gtk lib or iup lib missing detachbox feature
;; first check for the switch
;;
(if (or (args:get-arg "-rh5.11")
(configf:lookup *configdat* "dashboard" "no-detachbox"))
(set! iup:detachbox iup:vbox))
(if (not (common:on-homehost?))
(begin
(debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost))))
;; RA => Might require revert for filters
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
|
︙ | | |
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
|
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
|
-
+
+
+
-
+
|
;; runs
((allruns '()) : list) ;; list of dboard:rundat records
((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records
((done-runs '()) : list) ;; list of runs already drawn
((not-done-runs '()) : list) ;; list of runs not yet drawn
(header #f) ;; header for decoding the run records
(keys #f) ;; keys for this run (i.e. target components)
((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;;
((numruns (string->number (or (args:get-arg "-cols")
(configf:lookup *configdat* "dashboard" "cols")
"8"))) : number) ;;
((tot-runs 0) : number)
((last-data-update 0) : number) ;; last time the data in allruns was updated
((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree
(runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects
((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id
((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id
((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files
;; Runs view
((buttondat (make-hash-table)) : hash-table) ;;
((item-test-names '()) : list) ;; list of itemized tests
((run-keys (make-hash-table)) : hash-table)
(runs-matrix #f) ;; used in newdashboard
((start-run-offset 0) : number) ;; left-right slider value
((start-test-offset 0) : number) ;; up-down slider value
((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12
((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8
((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50
((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "50")) : string) ;; was 50
((all-test-names '()) : list)
;; Canvas and drawing data
(cnv #f)
(cnv-obj #f)
(drawing #f)
((run-start-row 0) : number)
|
︙ | | |
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
|
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
|
+
|
"190 190 190"
))
(dboard:tabdat-filters-changed-set! tabdat #t)))
(define (update-search commondat tabdat x val)
(hash-table-set! (dboard:tabdat-searchpatts tabdat) x val)
(dboard:tabdat-filters-changed-set! tabdat #t)
(mark-for-update tabdat)
(set-bg-on-filter commondat tabdat))
;; force ALL updates to zero (effectively)
;;
(define (mark-for-update tabdat)
(dboard:tabdat-last-db-update-set! tabdat (make-hash-table)))
|
︙ | | |
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
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
|
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
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
|
-
+
+
+
+
+
-
+
+
+
-
+
|
;; #:value 300
;; Target, testpatt, state and status input boxes
;;
(iup:vbox
;; Command to run, placed over the top of the canvas
(dcommon:command-action-selector commondat tabdat tab-num: tab-num)
(dboard:runs-tree-browser commondat tabdat)
(dboard:runs-tree-browser commondat tabdat)
(dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
(dcommon:command-testname-selector commondat tabdat update-keyvals))
;; key-listboxes))
(dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state))))
(tb (dboard:tabdat-runs-tree tabdat)))
(dboard:commondat-add-updater
commondat
(lambda ()
(if (dashboard:database-changed? commondat tabdat context-key: 'run-control)
(dashboard:update-tree-selector tabdat)))
tab-num: tab-num)
result)))
;;(iup:frame
;; #:title "Logs" ;; To be replaced with tabs
;; (let ((logs-tb (iup:textbox #:expand "YES"
;; #:multiline "YES")))
;; (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
;; logs-tb))
;; browse runs as a tree. Used in both "Runs" tab and
;; in the runs control panel.
;;
(define (dboard:runs-tree-browser commondat tabdat)
(let* (
(let* ((txtbox (iup:textbox #:action (lambda (val a b)
(txtbox (iup:textbox #:action (lambda (val a b)
(debug:catch-and-dump
(lambda ()
;; for the Runs view we put the list of keyvals into tabdat target
;; for the Run Controls we put then update the run-command
(if b (dboard:tabdat-target-set! tabdat (string-split b "/")))
(dashboard:update-run-command tabdat))
"command-testname-selector tb action"))
#:value (dboard:test-patt->lines
(dboard:tabdat-test-patts-use tabdat))
#:expand "HORIZONTAL"
;; #:size "10x30"
))
(tb
(iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
#:addexpanded "YES"
#:size "10x"
#:selection-cb
(lambda (obj id state)
(debug:catch-and-dump
(lambda ()
(let* ((run-path (tree:node->path obj id))
(run-id (tree-path->run-id tabdat (cdr run-path))))
|
︙ | | |
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
|
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
|
+
-
+
+
+
|
(dboard:tabdat-curr-run-id-set! tabdat run-id)
(dboard:tabdat-view-changed-set! tabdat #t))
(debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
"treebox"))
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
)))
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:detachbox
(iup:vbox tb txtbox)))
(iup:vbox
tb
txtbox))))
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;
|
︙ | | |
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
|
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
|
-
+
|
(dcommon:command-runname-selector commondat tabdat tab-num: tab-num)
(dcommon:command-testname-selector commondat tabdat update-keyvals))
(iup:vbox
(iup:split
#:orientation "HORIZONTAL"
#:value 800
(let* ((cnv-obj (iup:canvas
;; #:size "500x400"
;; #:size "250x250" ;; "500x400"
#:expand "YES"
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
#:action (make-canvas-action
(lambda (c xadj yadj)
(debug:catch-and-dump
|
︙ | | |
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
|
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
|
-
+
-
+
|
)))
cnv-obj)
(let* ((hb1 (iup:hbox))
(graph-cell-table (dboard:tabdat-graph-cell-table tabdat))
(changed #f)
(graph-matrix (iup:matrix
#:alignment1 "ALEFT"
#:expand "YES" ;; "HORIZONTAL"
;; #:expand "YES" ;; "HORIZONTAL"
#:scrollbar "YES"
#:numcol 10
#:numlin 20
#:numcol-visible (min 8)
#:numcol-visible 5 ;; (min 8)
#:numlin-visible 1
#:click-cb
(lambda (obj row col status)
(let*
((graph-cell (conc row ":" col))
(graph-dat (hash-table-ref/default graph-cell-table graph-cell #f))
(graph-flag (dboard:graph-dat-flag graph-dat)))
|
︙ | | |
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
|
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
|
-
+
|
;;
;; General info about the run(s) and megatest area
(define (dashboard:summary commondat tabdat #!key (tab-num #f))
(let* ((rawconfig (read-config (conc *toppath* "/megatest.config") #f #f)) ;; changed to #f since I want #{} to be expanded by [system ...] to NOT be expanded. WAS: 'return-string)))
(changed #f))
(iup:vbox
(iup:split
#:value 500
#:value 300
(iup:frame
#:title "General Info"
(iup:vbox
(iup:hbox
(iup:label "Area Path")
(iup:textbox #:value *toppath* #:expand "HORIZONTAL"))
(iup:hbox
|
︙ | | |
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
|
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
|
-
+
|
;;
(define (dashboard:runs-summary commondat tabdat #!key (tab-num #f))
(let* ((update-mutex (dboard:commondat-update-mutex commondat))
(tb (iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
#:addexpanded "YES"
#:selection-cb
(lambda (obj id state)
(debug:catch-and-dump
(lambda ()
;; (print "obj: " obj ", id: " id ", state: " state)
(let* ((run-path (tree:node->path obj id))
(run-id (tree-path->run-id tabdat (cdr run-path))))
|
︙ | | |
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
|
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
run-matrix)
(dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))
;;======================================================================
;; R U N S
;;======================================================================
(define (dboard:squarify toggles size)
(let loop ((hed (car toggles))
(tal (cdr toggles))
(cur '())
(res '()))
(let* ((ovrflo (>= (length cur) size))
(newcur (if ovrflo
(list hed)
(cons hed cur)))
(newres (if ovrflo
(cons cur res)
res)))
(if (null? tal)
(if ovrflo
newres
(cons newcur res))
(loop (car tal)(cdr tal) newcur newres)))))
(define (dboard:make-controls commondat tabdat #!key (extra-widget #f) )
(let ((btn-fontsz (dboard:tabdat-runs-btn-fontsz tabdat)))
(iup:hbox
(iup:vbox
(iup:frame
#:title "filter test and items"
(iup:vbox
|
︙ | | |
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
|
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
|
-
-
-
-
-
-
-
+
+
+
+
+
+
+
|
#:action (lambda (obj val index lbstate)
(set! *tests-sort-reverse* index)
(mark-for-update tabdat))))
(default-cmd (car (list-ref *tests-sort-type-index* *tests-sort-reverse*))))
(iuplistbox-fill-list sort-lb cmds-list selected-item: default-cmd)
(set! hide-empty (iup:button "HideEmpty"
;; #:expand HORIZONTAL"
#:expand "NO" #:size "80x15"
#:action (lambda (obj)
(dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat)))
(iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
(mark-for-update tabdat))))
;; (set! hide-empty (iup:button "HideEmpty"
;; ;; #:expand HORIZONTAL"
;; #:expand "NO" #:size "80x15"
;; #:action (lambda (obj)
;; (dboard:tabdat-hide-empty-runs-set! tabdat (not (dboard:tabdat-hide-empty-runs tabdat)))
;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-empty-runs tabdat) "+HideE" "-HideE"))
;; (mark-for-update tabdat))))
(set! hide (iup:button "Hide"
#:expand "NO" #:size "40x15" ;; #:expand "HORIZONTAL"
#:action (lambda (obj)
(dboard:tabdat-hide-not-hide-set! tabdat #t) ;; (not (dboard:tabdat-hide-not-hide tabdat)))
;; (iup:attribute-set! obj "TITLE" (if (dboard:tabdat-hide-not-hide tabdat) "HideTests" "NotHide"))
(iup:attribute-set! hide "BGCOLOR" sel-color)
(iup:attribute-set! show "BGCOLOR" nonsel-color)
|
︙ | | |
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
|
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
|
(iup:hbox)) ;; empty widget
)))
(iup:frame
#:title "state/status filter"
(iup:vbox
(apply
iup:hbox
(map (lambda (status)
(iup:toggle (conc status " ")
#:fontsize btn-fontsz ;; "10"
#:expand "HORIZONTAL"
#:action (lambda (obj val)
(mark-for-update tabdat)
(if (eq? val 1)
(hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t)
(hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status))
(set-bg-on-filter commondat tabdat))))
(map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
(let* ((status-toggles (map (lambda (status)
(iup:toggle (conc status)
#:fontsize 8 ;; btn-fontsz ;; "10"
;; #:expand "HORIZONTAL"
#:action (lambda (obj val)
(mark-for-update tabdat)
(if (eq? val 1)
(hash-table-set! (dboard:tabdat-status-ignore-hash tabdat) status #t)
(hash-table-delete! (dboard:tabdat-status-ignore-hash tabdat) status))
(set-bg-on-filter commondat tabdat))))
(map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP")))
(apply
iup:hbox
(map (lambda (state)
(iup:toggle (conc state " ")
#:fontsize btn-fontsz
#:expand "HORIZONTAL"
#:action (lambda (obj val)
(mark-for-update tabdat)
(if (eq? val 1)
(hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t)
(hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state))
(set-bg-on-filter commondat tabdat))))
(map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
(oldmax (string->number (iup:attribute obj "MAX")))
(maxruns (dboard:tabdat-tot-runs tabdat)))
(dboard:tabdat-start-run-offset-set! tabdat val)
(mark-for-update tabdat)
(debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
(iup:attribute-set! obj "MAX" (* maxruns 10))))
#:expand "HORIZONTAL"
#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
#:min 0
#:step 0.01)))
;;(iup:button "inc rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (+ (dboard:tabdat-num-tests tabdat) 1))))
(state-toggles (map (lambda (state)
(iup:toggle (conc state)
#:fontsize 8 ;; btn-fontsz
;; #:expand "HORIZONTAL"
#:action (lambda (obj val)
(mark-for-update tabdat)
(if (eq? val 1)
(hash-table-set! (dboard:tabdat-state-ignore-hash tabdat) state #t)
(hash-table-delete! (dboard:tabdat-state-ignore-hash tabdat) state))
(set-bg-on-filter commondat tabdat))))
(map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED")))
(num-toggle-cols (inexact->exact (round (/ (max (length status-toggles)(length state-toggles)) 3)))))
(iup:vbox
(iup:hbox
(iup:frame
#:title "states"
(apply
iup:hbox
(map (lambda (colgrp)
(apply iup:vbox colgrp))
(dboard:squarify state-toggles 3))))
(iup:frame
#:title "statuses"
(apply
iup:hbox
(map (lambda (colgrp)
(apply iup:vbox colgrp))
(dboard:squarify status-toggles 3)))))
;;
;; (iup:frame
;; #:title "state/status filter"
;; (iup:vbox
;; (apply
;; iup:hbox
;; (map
;; (lambda (status-toggle state-toggle)
;; (iup:vbox
;; status-toggle
;; state-toggle))
;; status-toggles state-toggles))
;; horizontal slider was here
)))))
(define (dashboard:runs-horizontal-slider tabdat )
(iup:valuator #:valuechanged_cb (lambda (obj)
(let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10))))
(oldmax (string->number (iup:attribute obj "MAX")))
(maxruns (dboard:tabdat-tot-runs tabdat)))
(dboard:tabdat-start-run-offset-set! tabdat val)
(mark-for-update tabdat)
(debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
(iup:attribute-set! obj "MAX" (* maxruns 10))))
#:expand "HORIZONTAL"
#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
#:min 0
#:step 0.01))
;(iup:button "dec rows" #:action (lambda (obj)(dboard:tabdat-num-tests-set! tabdat (if (> (dboard:tabdat-num-tests tabdat) 0)(- (dboard:tabdat-num-tests tabdat) 1) 0))))
)))
(define (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path test-info)
(iup:menu
(iup:menu-item
"Test Control Panel"
#:action
(lambda (obj)
|
︙ | | |
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
|
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
|
+
+
+
|
(iup:label) ;; (iup:valuator)
(apply iup:vbox
(map (lambda (x)
(let ((res (iup:hbox #:expand "HORIZONTAL"
(iup:label x #:size (conc 40 btn-height) #:fontsize btn-fontsz #:expand "NO") ;; "HORIZONTAL")
(iup:textbox #:size (conc 35 btn-height) #:fontsize btn-fontsz #:value "%" #:expand "NO" ;; "HORIZONTAL"
#:action (lambda (obj unk val)
;; each field (field name is "x" var) live updates
;; the search filter as it is typed
(dboard:tabdat-target-set! runs-dat #f) ;; ensure the fields text boxes are used and not the info from the tree
(mark-for-update runs-dat)
(update-search commondat runs-dat x val))))))
(set! i (+ i 1))
res))
keynames)))))
(let loop ((testnum 0)
(res '()))
|
︙ | | |
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
|
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
|
-
+
+
+
-
+
+
|
(iup:show
(iup:dialog
#:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
#:menu (dcommon:main-menu)
(let* ((runs-view (iup:vbox
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
#:value 150
#:value 100
(dboard:runs-tree-browser commondat runs-dat)
(iup:split
#:value 100
;; left most block, including row names
(apply iup:vbox lftlst)
;; right hand block, including cells
(iup:vbox
#:expand "YES"
;; the header
(apply iup:hbox (reverse hdrlst))
(apply iup:hbox (reverse bdylst)))))
(apply iup:hbox (reverse bdylst))
(dashboard:runs-horizontal-slider runs-dat))))
controls
))
(views-cfgdat (common:load-views-config))
(additional-tabnames '())
(tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
;; (data (dboard:tabdat-init (make-d:data)))
(additional-views ;; process views-dat
|
︙ | | |
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
|
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
|
+
|
"tabchangepos"))
(dashboard:summary commondat stats-dat tab-num: 0)
runs-view
(dashboard:runs-summary commondat onerun-dat tab-num: 2)
;; (dashboard:new-view db data new-view-dat tab-num: 3)
(dashboard:run-controls commondat runcontrols-dat tab-num: 3)
(dashboard:run-times commondat runtimes-dat tab-num: 4)
;; (dashboard:runs-summary commondat onerun-dat tab-num: 4)
additional-views)))
;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
(iup:attribute-set! tabs "TABTITLE0" "Summary")
(iup:attribute-set! tabs "TABTITLE1" "Runs")
(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
(iup:attribute-set! tabs "TABTITLE3" "Run Control")
(iup:attribute-set! tabs "TABTITLE4" "Run Times")
|
︙ | | |
︙ | | |
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
-
-
+
-
-
-
-
-
-
-
|
;; (filedb:get-path db id)))
;; NB// #f => return dbdir only
;; (was planned to be; zeroth db with name=main.db)
;;
;; If run-id is #f return to create and retrieve the path where the db will live.
;;
(define (db:dbfile-path . junk) ;; run-id)
(let* ((dbdir (common:get-db-tmp-area)))
(define db:dbfile-path common:get-db-tmp-area)
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
(exit 1))
(if (not (directory? dbdir))(create-directory dbdir #t)))
dbdir))
(define (db:set-sync db)
(let ((syncprag (configf:lookup *configdat* "setup" "sychronous")))
(sqlite3:execute db (conc "PRAGMA synchronous = " (or syncprag 0) ";"))))
;; open an sql database inside a file lock
;; returns: db existed-prior-to-opening
|
︙ | | |
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
|
-
+
|
(sqlite3:set-busy-handler! db (make-busy-timeout 136000))
(sqlite3:execute db "PRAGMA synchronous = 0;")
(if (not file-exists)
(begin
(if (and (configf:lookup *configdat* "setup" "use-wal")
(string-match "^/tmp/.*" fname)) ;; this is a file in /tmp
(sqlite3:execute db "PRAGMA journal_mode=WAL;")
(print "Creating " fname " in NON-WAL mode."))
(debug:print 2 *default-log-port* "Creating " fname " in NON-WAL mode."))
(initproc db)))
(if (not readyexists)
(begin
(common:simple-file-release-lock lockfname)
(with-output-to-file
readyfname
(lambda ()
|
︙ | | |
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
|
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
|
-
+
|
;; (dbr:dbstruct-olddb-set! dbstruct olddb)
;; ;;; (mutex-unlock! *rundb-mutex*) ;;; why did we need a mutex on opening db's?
;; (db:sync-tables db:sync-tests-only *megatest-db* db)
;; db))
;; This routine creates the db if not already present. It is only called if the db is not already opened
;;
(define (db:open-db dbstruct #!key (areapath #f)) ;; TODO: actually use areapath
(define (db:open-db dbstruct #!key (areapath #f)(do-sync #t)) ;; TODO: actually use areapath
(let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct
(if (stack? tmpdb-stack)
(db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used
(let* ((dbpath (db:dbfile-path )) ;; path to tmp db area
(dbexists (file-exists? dbpath))
(tmpdbfname (conc dbpath "/megatest.db"))
(dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
|
︙ | | |
335
336
337
338
339
340
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
371
372
373
374
375
376
377
|
327
328
329
330
331
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
357
358
359
360
361
362
363
364
365
366
367
368
369
|
-
-
-
+
+
+
+
-
+
-
-
+
|
(dbr:dbstruct-read-only-set! dbstruct #t)))
(dbr:dbstruct-mtdb-set! dbstruct mtdb)
(dbr:dbstruct-tmpdb-set! dbstruct tmpdb)
(dbr:dbstruct-dbstack-set! dbstruct (make-stack)) ;; BB: why a stack? Why would the number of db's be indeterminate? Is this a legacy of 1.db 2.db .. ?
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb) ;; olddb is already a (cons db path)
(dbr:dbstruct-refndb-set! dbstruct refndb)
;; (mutex-unlock! *rundb-mutex*)
(if (or (not dbfexists)
(and modtimedelta
(> modtimedelta 10))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
(if (and (or (not dbfexists)
(and modtimedelta
(> modtimedelta 10))) ;; if db in tmp is over ten seconds older than the file in MTRA then do a sync back
do-sync)
(begin
(debug:print 4 *default-log-port* "filling db " (db:dbdat-get-path tmpdb) " with data \n from " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta)
(db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb refndb tmpdb)
(debug:print-info 13 *default-log-port* "db:sync-all-tables-list done.")
)
(debug:print 4 *default-log-port* " db, " (db:dbdat-get-path tmpdb) " already exists or fresh enough, not propogating data from\n " (db:dbdat-get-path mtdb) " mod time delta: " modtimedelta) )
;; (db:multi-db-sync dbstruct 'old2new)) ;; migrate data from megatest.db automatically
tmpdb))))
;; Make the dbstruct, setup up auxillary db's and call for main db at least once
;;
;; called in http-transport and replicated in rmt.scm for *local* access.
;;
(define (db:setup #!key (areapath #f))
(define (db:setup do-sync #!key (areapath #f))
;;
(cond
(*dbstruct-db* *dbstruct-db*);; TODO: when multiple areas are supported, this optimization will be a hazard
(else ;;(common:on-homehost?)
(debug:print-info 13 *default-log-port* "db:setup entered (first time, not cached.)")
(let* ((dbstruct (make-dbr:dbstruct)))
(when (not *toppath*)
(debug:print-info 13 *default-log-port* "in db:setup, *toppath* not set; calling launch:setup")
(launch:setup areapath: areapath))
(debug:print-info 13 *default-log-port* "Begin db:open-db")
(db:open-db dbstruct areapath: areapath)
(db:open-db dbstruct areapath: areapath do-sync: do-sync)
(debug:print-info 13 *default-log-port* "Done db:open-db")
(set! *dbstruct-db* dbstruct)
;;(debug:print-info 13 *default-log-port* "new dbstruct = "(dbr:dbstruct->alist dbstruct))
dbstruct))))
;; (else
;; (debug:print 0 *default-log-port* "ERROR: attempt to open database when not on homehost. Exiting. Homehost: " (common:get-homehost))
;; (exit 1))))
|
︙ | | |
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
|
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
|
-
+
|
(define (db:sync-tables tbls last-update fromdb todb . slave-dbs)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable in db:sync-tables.")
(print-call-chain (current-error-port))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print "exn=" (condition->list exn))
(debug:print 5 *default-log-port* "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
(debug:print 0 *default-log-port* " src db: " (db:dbdat-get-path fromdb))
(for-each (lambda (dbdat)
(let ((dbpath (db:dbdat-get-path dbdat)))
(debug:print 0 *default-log-port* " dbpath: " dbpath)
(if (not (db:repair-db dbdat))
(begin
|
︙ | | |
834
835
836
837
838
839
840
841
842
843
844
845
846
847
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(sqlite3:execute maindb "CREATE TRIGGER IF NOT EXISTS update_run_stats_trigger AFTER UPDATE ON run_stats
FOR EACH ROW
BEGIN
UPDATE run_stats SET last_update=(strftime('%s','now'))
WHERE id=old.id;
END;"))
(define (db:adj-target db)
(let ((fields (configf:get-section *configdat* "fields"))
(field-num 0))
;; because we will be refreshing the keys table it is best to clear it here
(sqlite3:execute db "DELETE FROM keys;")
(for-each
(lambda (field)
(let ((column (car field))
(spec (cadr field)))
(handle-exceptions
exn
(if (string-match ".*duplicate.*" ((condition-property-accessor 'exn 'message) exn))
(debug:print 0 *default-log-port* "Target field " column " already exists in the runs table")
(db:general-sqlite-error-dump exn "alter table runs ..." #f "none"))
;; Add the column if needed
(sqlite3:execute
db
(conc "ALTER TABLE runs ADD COLUMN " column " " spec)))
;; correct the entry in the keys column
(sqlite3:execute
db
"INSERT INTO keys (id,fieldname,fieldtype) VALUES (?,?,?);"
field-num column spec)
;; fill in blanks (not allowed as it would be part of the path
(sqlite3:execute
db
(conc "UPDATE runs SET " column "='x' WHERE " column "='';"))
(set! field-num (+ field-num 1))))
fields)))
(define *global-db-store* (make-hash-table))
(define (db:get-access-mode)
(if (args:get-arg "-use-db-cache") 'cached 'rmt))
;; Add db direct
;;
|
︙ | | |
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
|
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
|
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
-
-
+
-
-
-
-
-
-
-
-
-
-
+
+
+
-
-
-
-
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
|
(debug:print 0 *default-log-port* "ERROR: not able to setup up for megatest.")
(let* ((mtdb (dbr:dbstruct-mtdb dbstruct))
(tmpdb (db:get-db dbstruct))
(refndb (dbr:dbstruct-refndb dbstruct))
(allow-cleanup #t) ;; (if run-ids #f #t))
(servers (server:get-list *toppath*)) ;; (tasks:get-all-servers (db:delay-if-busy tdbdat)))
(data-synced 0)) ;; count of changed records (I hope)
;; kill servers
(if (member 'killservers options)
(for-each
(lambda (server)
(match-let (((mod-time host port start-time pid) server))
(if (and host pid)
(tasks:kill-server host pid))))
servers))
(for-each
(lambda (option)
(case option
;; kill servers
((killservers)
(for-each
(lambda (server)
(match-let (((mod-time host port start-time pid) server))
(if (and host pid)
(tasks:kill-server host pid))))
servers))
;; clear out junk records
;;
(if (member 'dejunk options)
;; clear out junk records
;;
((dejunk)
(begin
(db:delay-if-busy mtdb) ;; ok to delay on mtdb
(db:clean-up mtdb)
(db:clean-up tmpdb)
(db:clean-up refndb)))
(db:clean-up refndb))
;; adjust test-ids to fit into proper range
;;
;; (if (member 'adj-testids options)
;; (begin
;; (db:delay-if-busy mtdb)
;; (db:prep-megatest.db-for-migration mtdb)))
;; sync runs, test_meta etc.
;;
(if (member 'old2new options)
;; sync runs, test_meta etc.
;;
((old2new)
;; (begin
(set! data-synced
(+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)
data-synced)))
(set! data-synced
(+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f mtdb tmpdb refndb)
data-synced)))
;; (db:sync-main-list mtdb) mtdb (db:get-db dbstruct #f))
;; (for-each
;; (lambda (run-id)
;; (db:delay-if-busy mtdb)
;; (let ((testrecs (db:get-all-tests-info-by-run-id mtdb run-id)))
;; ;; (dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
;; (debug:print 0 *default-log-port* "INFO: Propagating " (length testrecs) " records for run-id=" run-id " to run specific db")
;; (db:replace-test-records dbstruct run-id testrecs)
;; (sqlite3:finalize! (db:dbdat-get-db (dbr:dbstruct-rundb dbstruct)))))
;; run-ids)))
;; now ensure all newdb data are synced to megatest.db
;; do not use the run-ids list passed in to the function
;;
(if (member 'new2old options)
(set! data-synced
(+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)
data-synced)))
;; now ensure all newdb data are synced to megatest.db
;; do not use the run-ids list passed in to the function
;;
((new2old)
(set! data-synced
(+ (db:sync-tables (db:sync-all-tables-list dbstruct) #f tmpdb refndb mtdb)
data-synced)))
(if (member 'schema options)
((adj-target)
(db:adj-target (db:dbdat-get-db mtdb))
(db:adj-target (db:dbdat-get-db tmpdb))
(db:adj-target (db:dbdat-get-db refndb)))
((schema)
(begin
(db:patch-schema-maindb (db:dbdat-get-db mtdb))
(db:patch-schema-maindb (db:dbdat-get-db tmpdb))
(db:patch-schema-maindb (db:dbdat-get-db refndb))
(db:patch-schema-rundb (db:dbdat-get-db mtdb))
(db:patch-schema-rundb (db:dbdat-get-db tmpdb))
(db:patch-schema-rundb (db:dbdat-get-db refndb))))
;; (let* ((maindb (make-dbr:dbstruct path: toppath local: #t))
;; (src-run-ids (if run-ids run-ids (db:get-all-run-ids (db:dbdat-get-db (db:get-db maindb 0)))))
;; (all-run-ids (sort (delete-duplicates (cons 0 src-run-ids)) <))
;; (count 1)
;; (total (length all-run-ids))
;; (dead-runs '()))
;; ;; first fix schema if needed
;; (map
;; (lambda (th)
;; (thread-join! th))
;; (map
;; (lambda (run-id)
;; (thread-start!
;; (make-thread
;; (lambda ()
;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
;; (if (member 'schema options)
;; (if (eq? run-id 0)
;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f))))
;; (db:patch-schema-maindb run-id maindb))
;; (db:patch-schema-rundb run-id frundb)))
;; (set! count (+ count 1))
;; (debug:print 0 *default-log-port* "Finished patching schema for " (if (eq? run-id 0) " main.db " (conc run-id ".db")) ", " count " of " total)))))
;; all-run-ids))
;; ;; Then sync and fix db's
;; (set! count 0)
;; (process-fork
;; (lambda ()
;; (map
;; (lambda (th)
;; (thread-join! th))
;; (map
;; (lambda (run-id)
;; (thread-start!
;; (make-thread
;; (lambda ()
;; (let* ((fromdb (if toppath (make-dbr:dbstruct path: toppath local: #t) #f))
;; (frundb (db:dbdat-get-db (db:get-db fromdb run-id))))
;; (if (eq? run-id 0)
;; (let ((maindb (db:dbdat-get-db (db:get-db fromdb #f))))
;; (db:sync-tables (db:sync-main-list dbstruct) #f (db:get-db fromdb #f) mtdb)
;; (set! dead-runs (db:clean-up-maindb (db:get-db fromdb #f))))
;; (begin
;; ;; NB// must sync first to ensure deleted tests get marked as such in megatest.db
;; (db:sync-tables db:sync-tests-only #f (db:get-db fromdb run-id) mtdb)
;; (db:clean-up-rundb (db:get-db fromdb run-id)))))
;; (set! count (+ count 1))
;; (debug:print 0 *default-log-port* "Finished clean up of "
;; (if (eq? run-id 0)
;; " main.db " (conc run-id ".db")) ", " count " of " total)))))
;; all-run-ids))))
;; removed deleted runs
;; (let ((dbdir (tasks:get-task-db-path)))
;; (for-each (lambda (run-id)
;; (let ((fullname (conc dbdir "/" run-id ".db")))
;; (if (file-exists? fullname)
;; (begin
;; (debug:print 0 *default-log-port* "Removing database file for deleted run " fullname)
;; (delete-file fullname)))))
;; dead-runs))))
;;
;; (db:close-all dbstruct)
;; (sqlite3:finalize! mdb)
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb)
(stack-push! (dbr:dbstruct-dbstack dbstruct) tmpdb))
options)
data-synced)))
;; keeping it around for debugging purposes only
(define (open-run-close-no-exception-handling proc idb . params)
(debug:print-info 11 *default-log-port* "open-run-close-no-exception-handling START given a db=" (if idb "yes " "no ") ", params=" params)
(print "I don't work anymore. open-run-close-no-exception-handling needs fixing or removing...")
(exit)
|
︙ | | |
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
|
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
|
-
+
-
+
-
+
|
(err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
(case err-status
((busy)
(thread-sleep! sleep-time))
(else
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print "exn=" (condition->list exn))
(debug:print 5 *default-log-port* "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
(print-call-chain (current-error-port))
(thread-sleep! sleep-time)
(debug:print-info 0 *default-log-port* "trying db call one more time....this may never recover, if necessary kill process " (current-process-id) " on host " (get-host-name) " to clean up")))
(apply open-run-close-exception-handling proc idb params))
(apply open-run-close-no-exception-handling proc idb params)))
;; (define open-run-close
(define open-run-close open-run-close-exception-handling)
;; open-run-close-no-exception-handling
;; open-run-close-exception-handling)
;;)
(define (db:initialize-main-db dbdat)
(when (not *configinfo*)
(launch:setup)) ;; added because Elena was getting stack dump because *configinfo* below was #f.
(let* ((configdat (car *configinfo*)) ;; tut tut, global warning...
(keys (keys:config-get-fields configdat))
(havekeys (> (length keys) 0))
(keystr (keys->keystr keys))
(fieldstr (keys->key/field keys))
(fieldstr (keys:make-key/field-string configdat))
(db (db:dbdat-get-db dbdat)))
(for-each (lambda (key)
(let ((keyn key))
(if (member (string-downcase keyn)
(list "runname" "state" "status" "owner" "event_time" "comment" "fail_count"
"pass_count"))
"pass_count" "contour"))
(begin
(print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table, you must remove your megatest.db and <linktree>/.db before trying again.")
(exit 1)))))
keys)
(sqlite3:with-transaction
db
(lambda ()
|
︙ | | |
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
|
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
|
+
+
|
;; state is the priority rollup of all states
;; status is the priority rollup of all completed statesfu
;;
;; if test-name is an integer work off that instead of test-name test-path
;;
(define (db:set-state-status-and-roll-up-items dbstruct run-id test-name item-path state status comment)
;; establish info on incoming test followed by info on top level test
;; BBnote - for mode itemwait, linkage between upstream test & matching item status is propagated to run queue in db:prereqs-not-met
(let* ((testdat (if (number? test-name)
(db:get-test-info-by-id dbstruct run-id test-name) ;; test-name is actually a test-id
(db:get-test-info dbstruct run-id test-name item-path)))
(test-id (db:test-get-id testdat))
(test-name (if (number? test-name)
(db:test-get-testname testdat)
test-name))
|
︙ | | |
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
|
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
|
+
-
+
+
+
-
+
+
+
+
+
+
+
+
-
+
+
-
-
+
+
+
+
-
+
|
*common:not-started-ok-statuses*))))
state-status-counts)))
;; (non-completes (filter (lambda (x)
;; (not (equal? (dbr:counts-state x) "COMPLETED")))
;; state-status-counts))
(all-curr-states (common:special-sort ;; worst -> best (sort of)
(delete-duplicates
(if (not (equal? state "DELETED"))
(cons state (map dbr:counts-state state-status-counts)))
(cons state (map dbr:counts-state state-status-counts))
(map dbr:counts-state state-status-counts)))
*common:std-states* >))
(all-curr-statuses (common:special-sort ;; worst -> best
(delete-duplicates
(if (not (equal? state "DELETED"))
(cons status (map dbr:counts-status state-status-counts)))
(cons status (map dbr:counts-status state-status-counts))
(map dbr:counts-status state-status-counts)))
*common:std-statuses* >))
(non-completes (filter (lambda (x)
(not (equal? x "COMPLETED")))
all-curr-states))
(num-non-completes (length non-completes))
(newstate (cond
((> running 0)
"RUNNING") ;; anything running, call the situation running
((> bad-not-started 0) ;; we have an ugly situation, it is completed in the sense we cannot do more.
"COMPLETED")
((> (length non-completes) 0) ;;
((> num-non-completes 0) ;;
(car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states)))
;; only rollup DELETED if all DELETED
(else
(car all-curr-states))))
;; (if (> running 0)
;; "RUNNING"
;; (if (> bad-not-started 0)
;; "COMPLETED"
;; (car all-curr-states))))
(newstatus (if (> bad-not-started 0)
"CHECK"
(newstatus (if (or (> bad-not-started 0)
(and (equal? newstate "NOT_STARTED")
(> num-non-completes 0)))
"STARTED"
(car all-curr-statuses))))
;; (print "bad-not-supported: " bad-not-support " all-curr-states: " all-curr-states " all-curr-statuses: " all-curr-states)
;; " newstate: " newstate " newstatus: " newstatus)
;; NB// Pass the db so it is part of the transaction
(db:test-set-state-status db run-id tl-test-id newstate newstatus #f)))))))
(mutex-unlock! *db-transaction-mutex*)
(if (and test-id state status (equal? status "AUTO"))
(db:test-data-rollup dbstruct run-id test-id status))
tr-res)))))
;; BBnote: db:get-all-state-status-counts-for-test returns dbr:counts object aggregating state and status of items of a given test, *not including rollup state/status*
(define (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)
(db:with-db
dbstruct #f #f
(lambda (db)
(sqlite3:map-row
(lambda (state status count)
(make-dbr:counts state: state status: status count: count))
|
︙ | | |
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
|
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
|
+
|
;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED)
;; mode 'toplevel means that tests must be COMPLETED only
;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]]
;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING
;;
;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode)
(define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f))
;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items
(append
(if (member 'exclusive mode)
(let ((running-tests (db:get-tests-for-run dbstruct
#f ;; run-id of #f means for all runs.
(if (string=? ref-item-path "") ;; testpatt
ref-test-name
(conc ref-test-name "/" ref-item-path))
|
︙ | | |
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
|
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
|
-
+
-
+
|
;; and related sub items
;; next should be using mt:get-tests-for-run?
(let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name))
(ever-seen #f)
(parent-waiton-met #f)
(item-waiton-met #f))
(for-each
(lambda (test)
(lambda (test) ;; BB- this is the upstream test
;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ...
(let* ((state (db:test-get-state test))
(status (db:test-get-status test))
(item-path (db:test-get-item-path test))
(item-path (db:test-get-item-path test)) ;; BB- this is the upstream itempath
(is-completed (equal? state "COMPLETED"))
(is-running (equal? state "RUNNING"))
(is-killed (equal? state "KILLED"))
(is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP")))
;; testname-b path-a path-b
(same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path)))
(set! ever-seen #t)
|
︙ | | |
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
|
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
|
-
-
+
+
|
(set! parent-waiton-met #t))
;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met
((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ?????
;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items
same-itempath)
(if (and is-completed is-ok)
(set! item-waiton-met #t))
(if (and (equal? item-path "")
(or is-completed is-running));; this is the parent, set it to run if completed or running
(if (and (equal? item-path "") ;; if upstream rollup test is completed, parent-waiton-met is set
(or is-completed is-running));; this is the parent, set it to run if completed or running ;; BB1
(set! parent-waiton-met #t)))
;; normal checking of parent items, any parent or parent item not ok blocks running
((and is-completed
(or is-ok
(member 'toplevel mode)) ;; toplevel does not block on FAIL
(and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok
(set! item-waiton-met #t)))))
|
︙ | | |
︙ | | |
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
|
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
|
-
+
|
(use regex typed-records matchable)
(declare (unit dcommon))
(declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
(declare (uses synchash))
;; (declare (uses synchash))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
;; yes, this is non-ideal
|
︙ | | |
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
|
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
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; 1. Make "data" hash-table hierarchial store of all displayed data
;; 2. Update synchash to understand "get-runs", "get-tests" etc.
;; 3. Add extraction of filters to synchash calls
;;
;; NOTE: Used in newdashboard
;;
;; Mode is 'full or 'incremental for full refresh or incremental refresh
(define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id)
(let* (;; count and offset => #f so not used
;; the synchash calls modify the "data" hash
(changed #f)
(get-runs-sig (conc (client:get-signature) " get-runs"))
(get-tests-sig (conc (client:get-signature) " get-tests"))
(get-details-sig (conc (client:get-signature) " get-test-details"))
;; test-ids to get and display are indexed on window-id in curr-test-ids hash
(test-ids (hash-table-values (dboard:tabdat-curr-test-ids data)))
;; run-id is #f in next line to send the query to server 0
(run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts))
(tests-detail-changes (if (not (null? test-ids))
(synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids)
'()))
;; Now can calculate the run-ids
(run-hash (hash-table-ref/default data get-runs-sig #f))
(run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '()))
(all-test-changes (let ((res (make-hash-table)))
(for-each (lambda (run-id)
(if (> run-id 0)
(hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f))))
run-ids)
res))
(runs-hash (hash-table-ref/default data get-runs-sig #f))
(header (hash-table-ref/default runs-hash "header" #f))
(run-ids (sort (filter number? (hash-table-keys runs-hash))
(lambda (a b)
(let* ((record-a (hash-table-ref runs-hash a))
(record-b (hash-table-ref runs-hash b))
(time-a (db:get-value-by-header record-a header "event_time"))
(time-b (db:get-value-by-header record-b header "event_time")))
(> time-a time-b)))
))
(runid-to-col (hash-table-ref *cachedata* "runid-to-col"))
(testname-to-row (hash-table-ref *cachedata* "testname-to-row"))
(colnum 1)
(rownum 0)
(cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header
;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes)
;; tests related stuff
;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes))))
;; Given a run-id and testname/item_path calculate a cell R:C
;; NOTE: Also build the test tree browser and look up table
;;
;; Each run is unique on its keys and runname or run-id, store in hash on colnum
(for-each (lambda (run-id)
(let* ((run-record (hash-table-ref/default runs-hash run-id #f))
(key-vals (map (lambda (key)(db:get-value-by-header run-record header key))
keys))
(run-name (db:get-value-by-header run-record header "runname"))
(col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
(run-path (append key-vals (list run-name))))
(hash-table-set! (dboard:tabdat-run-keys data) run-id run-path)
;; modify cell - but only if changed
(set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed))
(hash-table-set! runid-to-col run-id (list colnum run-record))
;; Here we update the tests treebox and tree keys
(tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name))
userdata: (conc "run-id: " run-id))
(set! colnum (+ colnum 1))))
run-ids)
;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table
;; Do this analysis in the order of the run-ids, the most recent run wins
(for-each (lambda (run-id)
(let* ((run-path (hash-table-ref (dboard:tabdat-run-keys data) run-id))
(test-changes (hash-table-ref all-test-changes run-id))
(new-test-dat (car test-changes))
(removed-tests (cadr test-changes))
(tests (sort (map cadr (filter (lambda (testrec)
(eq? run-id (db:mintest-get-run_id (cadr testrec))))
new-test-dat))
(lambda (a b)
(let ((time-a (db:mintest-get-event_time a))
(time-b (db:mintest-get-event_time b)))
(> time-a time-b)))))
;; test-changes is a list of (( id record ) ... )
;; Get list of test names sorted by time, remove tests
(test-names (delete-duplicates (map (lambda (t)
(let ((i (db:mintest-get-item_path t))
(n (db:mintest-get-testname t)))
(if (string=? i "")
(conc " " i)
n)))
tests)))
(colnum (car (hash-table-ref runid-to-col run-id))))
;; for each test name get the slot if it exists and fill in the cell
;; or take the next slot and fill in the cell, deal with items in the
;; run view panel? The run view panel can have a tree selector for
;; browsing the tests/items
;; SWITCH THIS TO USING CHANGED TESTS ONLY
(for-each (lambda (test)
(let* ((test-id (db:mintest-get-id test))
(state (db:mintest-get-state test))
(status (db:mintest-get-status test))
(testname (db:mintest-get-testname test))
(itempath (db:mintest-get-item_path test))
(fullname (conc testname "/" itempath))
(dispname (if (string=? itempath "") testname (conc " " itempath)))
(rownum (hash-table-ref/default testname-to-row fullname #f))
(test-path (append run-path (if (equal? itempath "")
(list testname)
(list testname itempath))))
(tb (dboard:tabdat-tests-tree data)))
(print "INFONOTE: run-path: " run-path)
(tree:add-node (dboard:tabdat-tests-tree data) "Runs"
test-path
userdata: (conc "test-id: " test-id))
(let ((node-num (tree:find-node tb (cons "Runs" test-path)))
(color (car (gutils:get-color-for-state-status state status))))
(debug:print 0 *default-log-port* "node-num: " node-num ", color: " color)
(set! changed (dcommon:modifiy-if-different
tb
(conc "COLOR" node-num)
color changed))
;; (iup:attribute-set! tb (conc "COLOR" node-num) color)
;; (define (dcommon:run-update keys data runname keypatts testpatt states statuses mode window-id)
;; (let* (;; count and offset => #f so not used
;; ;; the synchash calls modify the "data" hash
;; (changed #f)
;; (get-runs-sig (conc (client:get-signature) " get-runs"))
;; (get-tests-sig (conc (client:get-signature) " get-tests"))
;; (get-details-sig (conc (client:get-signature) " get-test-details"))
;;
;; ;; test-ids to get and display are indexed on window-id in curr-test-ids hash
;; (test-ids (hash-table-values (dboard:tabdat-curr-test-ids data)))
;; ;; run-id is #f in next line to send the query to server 0
;; (run-changes (synchash:client-get 'db:get-runs get-runs-sig (length keypatts) data #f runname #f #f keypatts))
;; (tests-detail-changes (if (not (null? test-ids))
;; (synchash:client-get 'db:get-test-info-by-ids get-details-sig 0 data #f test-ids)
;; '()))
;;
;; ;; Now can calculate the run-ids
;; (run-hash (hash-table-ref/default data get-runs-sig #f))
;; (run-ids (if run-hash (filter number? (hash-table-keys run-hash)) '()))
;;
;; (all-test-changes (let ((res (make-hash-table)))
;; (for-each (lambda (run-id)
;; (if (> run-id 0)
;; (hash-table-set! res run-id (synchash:client-get 'db:get-tests-for-run-mindata get-tests-sig 0 data run-id 1 testpatt states statuses #f))))
;; run-ids)
;; res))
;; (runs-hash (hash-table-ref/default data get-runs-sig #f))
;; (header (hash-table-ref/default runs-hash "header" #f))
;; (run-ids (sort (filter number? (hash-table-keys runs-hash))
;; (lambda (a b)
;; (let* ((record-a (hash-table-ref runs-hash a))
;; (record-b (hash-table-ref runs-hash b))
;; (time-a (db:get-value-by-header record-a header "event_time"))
;; (time-b (db:get-value-by-header record-b header "event_time")))
;; (> time-a time-b)))
;; ))
;; (runid-to-col (hash-table-ref *cachedata* "runid-to-col"))
;; (testname-to-row (hash-table-ref *cachedata* "testname-to-row"))
;; (colnum 1)
;; (rownum 0)
;; (cellname (conc rownum ":" colnum))) ;; rownum = 0 is the header
;; ;; (debug:print 0 *default-log-port* "test-ids " test-ids ", tests-detail-changes " tests-detail-changes)
;;
;; ;; tests related stuff
;; ;; (all-testnames (delete-duplicates (map db:test-get-testname test-changes))))
;;
;; ;; Given a run-id and testname/item_path calculate a cell R:C
;;
;; ;; NOTE: Also build the test tree browser and look up table
;; ;;
;; ;; Each run is unique on its keys and runname or run-id, store in hash on colnum
;; (for-each (lambda (run-id)
;; (let* ((run-record (hash-table-ref/default runs-hash run-id #f))
;; (key-vals (map (lambda (key)(db:get-value-by-header run-record header key))
;; keys))
;; (run-name (db:get-value-by-header run-record header "runname"))
;; (col-name (conc (string-intersperse key-vals "\n") "\n" run-name))
;; (run-path (append key-vals (list run-name))))
;; (hash-table-set! (dboard:tabdat-run-keys data) run-id run-path)
;; ;; modify cell - but only if changed
;; (set! changed (dcommon:modifiy-if-different (dboard:tabdat-runs-matrix data) cellname col-name changed))
;; (hash-table-set! runid-to-col run-id (list colnum run-record))
;; ;; Here we update the tests treebox and tree keys
;; (tree:add-node (dboard:tabdat-tests-tree data) "Runs" (append key-vals (list run-name))
;; userdata: (conc "run-id: " run-id))
;; (set! colnum (+ colnum 1))))
;; run-ids)
;;
;; ;; Scan all tests to be displayed and organise all the test names, respecting what is in the hash table
;; ;; Do this analysis in the order of the run-ids, the most recent run wins
;; (for-each (lambda (run-id)
;; (let* ((run-path (hash-table-ref (dboard:tabdat-run-keys data) run-id))
;; (test-changes (hash-table-ref all-test-changes run-id))
;; (new-test-dat (car test-changes))
;; (removed-tests (cadr test-changes))
;; (tests (sort (map cadr (filter (lambda (testrec)
;; (eq? run-id (db:mintest-get-run_id (cadr testrec))))
;; new-test-dat))
;; (lambda (a b)
;; (let ((time-a (db:mintest-get-event_time a))
;; (time-b (db:mintest-get-event_time b)))
;; (> time-a time-b)))))
;; ;; test-changes is a list of (( id record ) ... )
;; ;; Get list of test names sorted by time, remove tests
;; (test-names (delete-duplicates (map (lambda (t)
;; (let ((i (db:mintest-get-item_path t))
;; (n (db:mintest-get-testname t)))
;; (if (string=? i "")
;; (conc " " i)
;; n)))
;; tests)))
;; (colnum (car (hash-table-ref runid-to-col run-id))))
;; ;; for each test name get the slot if it exists and fill in the cell
;; ;; or take the next slot and fill in the cell, deal with items in the
;; ;; run view panel? The run view panel can have a tree selector for
;; ;; browsing the tests/items
;;
;; ;; SWITCH THIS TO USING CHANGED TESTS ONLY
;; (for-each (lambda (test)
;; (let* ((test-id (db:mintest-get-id test))
;; (state (db:mintest-get-state test))
;; (status (db:mintest-get-status test))
;; (testname (db:mintest-get-testname test))
;; (itempath (db:mintest-get-item_path test))
;; (fullname (conc testname "/" itempath))
;; (dispname (if (string=? itempath "") testname (conc " " itempath)))
;; (rownum (hash-table-ref/default testname-to-row fullname #f))
;; (test-path (append run-path (if (equal? itempath "")
;; (list testname)
;; (list testname itempath))))
;; (tb (dboard:tabdat-tests-tree data)))
;; (print "INFONOTE: run-path: " run-path)
;; (tree:add-node (dboard:tabdat-tests-tree data) "Runs"
;; test-path
;; userdata: (conc "test-id: " test-id))
;; (let ((node-num (tree:find-node tb (cons "Runs" test-path)))
;; (color (car (gutils:get-color-for-state-status state status))))
;; (debug:print 0 *default-log-port* "node-num: " node-num ", color: " color)
;;
;; (set! changed (dcommon:modifiy-if-different
;; tb
;; (conc "COLOR" node-num)
;; color changed))
;;
;; ;; (iup:attribute-set! tb (conc "COLOR" node-num) color)
)
(hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id)
(if (not rownum)
(let ((rownums (hash-table-values testname-to-row)))
(set! rownum (if (null? rownums)
;; )
;; (hash-table-set! (dboard:tabdat-path-test-ids data) test-path test-id)
;; (if (not rownum)
;; (let ((rownums (hash-table-values testname-to-row)))
;; (set! rownum (if (null? rownums)
1
(+ 1 (common:max rownums))))
(hash-table-set! testname-to-row fullname rownum)
;; create the label
(set! changed (dcommon:modifiy-if-different
(dboard:tabdat-runs-matrix data)
(conc rownum ":" 0)
dispname
changed))
;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; (conc rownum ":" 0) dispname)
))
;; set the cell text and color
;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status)
(set! changed (dcommon:modifiy-if-different
(dboard:tabdat-runs-matrix data)
(conc rownum ":" colnum)
(if (member state '("ARCHIVED" "COMPLETED"))
status
state)
changed))
;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; (conc rownum ":" colnum)
;; (if (member state '("ARCHIVED" "COMPLETED"))
;; status
;; state))
(set! changed (dcommon:modifiy-if-different
(dboard:tabdat-runs-matrix data)
(conc "BGCOLOR" rownum ":" colnum)
(car (gutils:get-color-for-state-status state status))
changed))
;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; (conc "BGCOLOR" rownum ":" colnum)
;; (car (gutils:get-color-for-state-status state status)))
))
tests)))
run-ids)
(let ((updater (hash-table-ref/default (dboard:commondat-updaters commondat) window-id #f)))
(if updater (updater (hash-table-ref/default data get-details-sig #f))))
(if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL"))
;; (debug:print 2 *default-log-port* "run-changes: " run-changes)
;; (debug:print 2 *default-log-port* "test-changes: " test-changes)
(list run-changes all-test-changes)))
;; 1
;; (+ 1 (common:max rownums))))
;; (hash-table-set! testname-to-row fullname rownum)
;; ;; create the label
;; (set! changed (dcommon:modifiy-if-different
;; (dboard:tabdat-runs-matrix data)
;; (conc rownum ":" 0)
;; dispname
;; changed))
;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; ;; (conc rownum ":" 0) dispname)
;; ))
;; ;; set the cell text and color
;; ;; (debug:print 2 *default-log-port* "rownum:colnum=" rownum ":" colnum ", state=" status)
;; (set! changed (dcommon:modifiy-if-different
;; (dboard:tabdat-runs-matrix data)
;; (conc rownum ":" colnum)
;; (if (member state '("ARCHIVED" "COMPLETED"))
;; status
;; state)
;; changed))
;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; ;; (conc rownum ":" colnum)
;; ;; (if (member state '("ARCHIVED" "COMPLETED"))
;; ;; status
;; ;; state))
;; (set! changed (dcommon:modifiy-if-different
;; (dboard:tabdat-runs-matrix data)
;; (conc "BGCOLOR" rownum ":" colnum)
;; (car (gutils:get-color-for-state-status state status))
;; changed))
;; ;; (iup:attribute-set! (dboard:tabdat-runs-matrix data)
;; ;; (conc "BGCOLOR" rownum ":" colnum)
;; ;; (car (gutils:get-color-for-state-status state status)))
;; ))
;; tests)))
;; run-ids)
;;
;; (let ((updater (hash-table-ref/default (dboard:commondat-updaters commondat) window-id #f)))
;; (if updater (updater (hash-table-ref/default data get-details-sig #f))))
;;
;; (if changed (iup:attribute-set! (dboard:tabdat-runs-matrix data) "REDRAW" "ALL"))
;; ;; (debug:print 2 *default-log-port* "run-changes: " run-changes)
;; ;; (debug:print 2 *default-log-port* "test-changes: " test-changes)
;; (list run-changes all-test-changes)))
(define (dcommon:runsdat-get-col-num dat target runname force-set)
(let* ((runs-index (dboard:runsdat-runs-index dat))
(col-name (conc target "/" runname))
(res (hash-table-ref/default runs-index col-name #f)))
(if res
res
|
︙ | | |
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
|
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
|
-
+
|
;; Section to table
(define (dcommon:section-matrix rawconfig sectionname varcolname valcolname #!key (title #f))
(let* ((curr-row-num 1)
(key-vals (configf:section-vars rawconfig sectionname))
(section-matrix (iup:matrix
#:alignment1 "ALEFT"
#:expand "YES" ;; "HORIZONTAL"
;; #:expand "YES" ;; "HORIZONTAL"
#:numcol 1
#:numlin (length key-vals)
#:numcol-visible 1
#:numlin-visible (min 10 (length key-vals))
#:scrollbar "YES")))
(iup:attribute-set! section-matrix "0:0" varcolname)
(iup:attribute-set! section-matrix "0:1" valcolname)
|
︙ | | |
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
|
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
|
-
+
|
(hash-table-set! tests-draw-state 'scalef (+ scalef
(if (> step 0)
(* scalef 0.01)
(* scalef -0.01))))
(if the-cnv
(dashboard:draw-tests the-cnv last-xadj last-yadj tests-draw-state sorted-testnames test-records))
))
;; #:size "50x50"
;; #:size "250x250"
#:expand "YES"
#:scrollbar "YES"
#:posx "0.5"
#:posy "0.5"
#:button-cb (lambda (obj btn pressed x y status)
;; (print "obj: " obj ", pressed " pressed ", status " status)
; (print "canvas-origin: " (canvas-origin the-cnv))
|
︙ | | |
︙ | | |
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
|
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
|
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
|
integrating and or running a complex suite of tests for release
qualification.</p></div>
</div>
</div>
<div class="sect1">
<h2 id="_megatest_design_philosophy">Megatest Design Philosophy</h2>
<div class="sectionbody">
<div class="paragraph"><p>Megatest is intended to provide the minimum needed resources to make
writing a suite of tests and tasks for implementing continuous build
for software, design engineering or process control (via owlfs for
example) without being specialized for any specific problem
space. Megatest in of itself does not know what constitutes a PASS or
FAIL of a test or task. In most cases megatest is best used in
conjunction with logpro or a similar tool to parse, analyze and decide
<div class="paragraph"><p>Megatest is a distributed system intended to provide the minimum needed
resources to make writing a suite of tests and tasks for implementing
continuous build for software, design engineering or process control (via
owlfs for example) without being specialized for any specific problem
space. Megatest in of itself does not know what constitutes a PASS or FAIL
of a test or task. In most cases megatest is best used in conjunction with
logpro or a similar tool to parse, analyze and decide on the test outcome.</p></div>
on the test outcome.</p></div>
<div class="ulist"><ul>
<li>
<p>
Self-checking -Repeatable strive for directed or self-checking test
as opposed to delta based tests
</p>
</li>
|
︙ | | |
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
|
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
|
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
+
|
<h3 id="_architecture_refactor">Architecture Refactor</h3>
<div class="sect3">
<h4 id="_goals">Goals</h4>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Reduce load on the file system. Sqlite3 files on network filesystem can be
a burden.
a burden. <span class="green">[DONE]</span>
</p>
</li>
<li>
<p>
Reduce number of servers and frequency of start/stop. This is mostly an
issue of clutter but also a reduction in "moving parts".
issue of clutter but also a reduction in "moving parts". <span class="green">[DONE]</span>
</p>
</li>
<li>
<p>
Coalesce activities to a single home host where possible. Give the user
feedback that they have started the dashboard on a host other than the
home host.
home host. <span class="green">[DONE]</span>
</p>
</li>
<li>
<p>
Reduce number of processes involved in managing running tests.
</p>
</li>
</ol></div>
</div>
<div class="sect3">
<h4 id="_changes_needed">Changes Needed</h4>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
ACID compliant db will be on /tmp and synced to megatest.db with a five
second max delay.
second max delay. <span class="green">[DONE]</span>
</p>
</li>
<li>
<p>
Read/writes to db for processes on homehost will go direct to /tmp
megatest.db file.
megatest.db file. <span class="green">[DONE]</span>
</p>
</li>
<li>
<p>
Read/wites fron non-homehost processes will go through one server. Bulk
reads (e.g. for dashboard or list-runs) will be cached on the current host
in /tmp and synced from the home megatest.db in the testsuite area.
in /tmp and synced from the home megatest.db in the testsuite area. <span class="green">[DONE]</span>
</p>
</li>
<li>
<p>
Db syncs rely on the target db file timestame minus some margin.
Db syncs rely on the target db file timestame minus some margin. <span class="green">[DONE]</span>
</p>
</li>
<li>
<p>
Since bulk reads do not use the server we can switch to simple RPC for the
network transport.
network transport. <span class="green">[DONE]</span>
</p>
</li>
<li>
<p>
Test running manager process extended to manage multiple running tests.
</p>
</li>
</ol></div>
</div>
</div>
<div class="sect2">
<h3 id="_current_items">Current Items</h3>
<div class="sect3">
<h4 id="_ww05_migrate_to_inmem_db">ww05 - migrate to inmem-db</h4>
<div class="olist arabic"><ol class="arabic">
<li>
<p>
Switch to inmem db with fast sync to on disk db’s [DONE]
Switch to inmem db with fast sync to on disk db’s <span class="green">[DONE]</span>
</p>
</li>
<li>
<p>
Server polls tasks table for next action
</p>
<div class="olist loweralpha"><ol class="loweralpha">
<li>
<p>
Task table used for tracking runner process [DONE]
Task table used for tracking runner process <span class="red">[Replaced by mtutil]</span>
</p>
</li>
<li>
<p>
Task table used for jobs to run
Task table used for jobs to run <span class="red">[Replaced by mtutil]</span>
</p>
</li>
<li>
<p>
Task table used for queueing runner actions (remove runs, cleanRunExecute, etc)
Task table used for queueing runner actions (remove runs,
cleanRunExecute, etc) <span class="red">[Replaced by mtutil</span>]
</p>
</li>
</ol></div>
</li>
</ol></div>
<div class="paragraph"><p>shifting, note that the preceding blank line is needed.</p></div>
</div>
|
︙ | | |
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
|
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
|
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
<div class="listingblock">
<div class="content monospaced">
<pre>[items]
A a b c
B d e f</pre>
</div></div>
<div class="paragraph"><p>Then the config file would effectively appear to contain an items section
exactly like the output from the script. This is extremely useful when
dynamically creating items, itemstables and other config structures. You can
see the expansion of the call by looking in the cached files (look in your
linktree for megatest.config and runconfigs.config cache files and in your
test run areas for the expanded and cached testconfig).</p></div>
exactly like the output from the script. This is useful when dynamically
creating items, itemstables and other config structures. You can see the
expansion of the call by looking in the cached files (look in your linktree
for megatest.config and runconfigs.config cache files and in your test run
areas for the expanded and cached testconfig).</p></div>
<div class="paragraph"><p>Wildcards and regexes in Targets</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[a/2/b]
VAR1 VAL1
[a/%/b]
VAR1 VAL2</pre>
</div></div>
<div class="paragraph"><p>Will result in:</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[a/2/b]
VAR1 VAL2</pre>
</div></div>
<div class="paragraph"><p>Can use either wildcard of "%" or a regular expression:</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre>[/abc.*def/]</pre>
</div></div>
<div class="sect3">
<h4 id="_disk_space_checks">Disk Space Checks</h4>
<div class="paragraph"><p>Some parameters you can put in the [setup] section of megatest.config:</p></div>
<div class="listingblock">
<div class="content monospaced">
<pre># minimum space required in a run disk
minspace 10000000
|
︙ | | |
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
|
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
<table><tr>
<td class="icon">
<img src="/nfs/pdx/disks/ice.disk.002/icfadm/pkgs/asciidoc/8.6.7/images/icons/note.png" alt="Note">
</td>
<td class="content">There is a trailing space after the --</td>
</tr></table>
</div>
<div class="paragraph"><p>There are a number of environment variables available to the trigger script
but since triggers can be called in various contexts not all variables are
available at all times. The trigger script should check for the variable and
fail gracefully if it doesn’t exist.</p></div>
<table class="tableblock frame-topbot grid-all"
style="
width:90%;
">
<caption class="title">Table 4. Environment variables visible to the trigger script</caption>
<col style="width:33%;">
<col style="width:66%;">
<thead>
<tr>
<th class="tableblock halign-center valign-top" >Variable </th>
<th class="tableblock halign-left valign-top" > Purpose</th>
</tr>
</thead>
<tbody>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_TEST_RUN_DIR</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">The directory where Megatest ran this test</p></td>
</tr>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_CMDINFO</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Encoded command data for the test</p></td>
</tr>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_DEBUG_MODE</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Used to pass the debug mode to nested calls to Megatest</p></td>
</tr>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_RUN_AREA_HOME</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Megatest home area</p></td>
</tr>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_TESTSUITENAME</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">The name of this testsuite or area</p></td>
</tr>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_TEST_NAME</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">The name of this test</p></td>
</tr>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_ITEM_INFO</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">The variable and values for the test item</p></td>
</tr>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_MEGATEST</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">Which Megatest binary is being used by this area</p></td>
</tr>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_TARGET</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">The target variable values, separated by <em>/</em></p></td>
</tr>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_LINKTREE</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">The base of the link tree where all run tests can be found</p></td>
</tr>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_ITEMPATH</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">The values of the item path variables, separated by <em>/</em></p></td>
</tr>
<tr>
<td class="tableblock halign-center valign-top" ><p class="tableblock">MT_RUNNAME</p></td>
<td class="tableblock halign-left valign-top" ><p class="tableblock monospaced">The name of the run</p></td>
</tr>
</tbody>
</table>
</div>
<div class="sect2">
<h3 id="_override_the_toplevel_html_file">Override the Toplevel HTML File</h3>
<div class="paragraph"><p>Megatest generates a simple html file summary for top level tests of
iterated tests. The generation can be overridden. NOTE: the output of
the script is captured from stdout to create the html.</p></div>
<div class="listingblock">
|
︙ | | |
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
|
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
|
-
+
|
<h2 id="_programming_api">Programming API</h2>
<div class="sectionbody">
<div class="paragraph"><p>These routines can be called from the megatest repl.</p></div>
<table class="tableblock frame-topbot grid-all"
style="
width:70%;
">
<caption class="title">Table 4. API Keys Related Calls</caption>
<caption class="title">Table 5. API Keys Related Calls</caption>
<col style="width:14%;">
<col style="width:28%;">
<col style="width:28%;">
<col style="width:28%;">
<thead>
<tr>
<th class="tableblock halign-center valign-top" >API Call </th>
|
︙ | | |
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
|
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
|
-
+
|
</div>
</div>
</div>
<div id="footnotes"><hr></div>
<div id="footer">
<div id="footer-text">
Version 1.0<br>
Last updated 2016-12-12 13:03:08 PST
Last updated 2017-05-10 08:25:49 PDT
</div>
</div>
</body>
</html>
|
︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
-
-
-
|
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
(declare (unit launch))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
;; (declare (uses sdb))
(declare (uses tdb))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
;;======================================================================
;; ezsteps
|
︙ | | |
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
|
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
|
-
+
|
(debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed")
(exit))))
(debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
(set! keys (rmt:get-keys))
;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process
;; one of these is defunct/redundant ...
(if (not (launch:setup force: #t))
(if (not (launch:setup force-reread: #t))
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
;; (sqlite3:finalize! db)
;; (sqlite3:finalize! tdb)
(exit 1)))
(change-directory *toppath*)
|
︙ | | |
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
|
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
|
-
+
+
|
(tests:summarize-items run-id test-id test-name #f))
(tests:summarize-test run-id test-id) ;; don't force - just update if no
(rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id)))
(mutex-unlock! m)
(debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area "
work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n")
(if (not (launch:einf-exit-status exit-info))
(exit 4)))))))
(exit 4))))
)))
(define (launch:cache-config)
;; if we have a linktree and -runtests and -target and the directory exists dump the config
;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg
(if (and *configdat*
(or (args:get-arg "-run")
(args:get-arg "-runtests")
|
︙ | | |
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
|
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
|
-
+
-
+
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
-
-
-
-
-
+
+
+
-
-
-
+
-
-
-
-
+
-
-
+
+
+
+
-
+
+
+
+
|
;; returns:
;; *toppath*
;; side effects:
;; sets; *configdat* (megatest.config info)
;; *runconfigdat* (runconfigs.config info)
;; *configstatus* (status of the read data)
;;
(define (launch:setup #!key (force #f) (areapath #f))
(define (launch:setup #!key (force-reread #f) (areapath #f))
(mutex-lock! *launch-setup-mutex*)
(if (and *toppath*
(eq? *configstatus* 'fulldata)) ;; got it all
(eq? *configstatus* 'fulldata) (not force-reread)) ;; got it all
(begin
(debug:print 0 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata")
(debug:print 2 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata")
(mutex-unlock! *launch-setup-mutex*)
*toppath*)
(let ((res (launch:setup-body force: force areapath: areapath)))
(let ((res (launch:setup-body force-reread: force-reread areapath: areapath)))
(mutex-unlock! *launch-setup-mutex*)
res)))
;; return paths depending on what info is available.
;;
(define (launch:get-cache-file-paths areapath toppath target mtconfig)
(let* ((use-cache (common:use-cache?))
(runname (common:args-get-runname))
(linktree (common:get-linktree))
(testname (common:get-full-test-name))
(rundir (if (and runname target linktree)
(common:directory-writable? (conc linktree "/" target "/" runname))
#f))
(testdir (if (and rundir testname)
(common:directory-writable? (conc rundir "/" testname))
#f))
(cachedir (or testdir rundir))
(mtcachef (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
(rccachef (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))))
(debug:print-info 6 *default-log-port*
"runname=" runname
"\n linktree=" linktree
"\n testname=" testname
"\n rundir=" rundir
"\n testdir=" testdir
"\n cachedir=" cachedir
"\n mtcachef=" mtcachef
"\n rccachef=" rccachef)
(cons mtcachef rccachef)))
(define (launch:setup-body #!key (force-reread #f) (areapath #f))
(if (and (eq? *configstatus* 'fulldata)
*toppath*
(not force-reread)) ;; no need to reprocess
*toppath* ;; return toppath
(let* ((use-cache (common:use-cache?))
(let* ((use-cache (common:use-cache?)) ;; BB- use-cache checks *configdat* for use-cache setting. We do not have *configdat*. Bootstrapping problem here.
(toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath
(runname (common:args-get-runname))
(target (common:args-get-target))
(linktree (common:get-linktree))
(contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour"))
(sections (if target (list "default" target) #f)) ;; for runconfigs
(mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config
(rundir (if (and runname target linktree)
(conc linktree (if contour (conc "/" contour) "") "/" target "/" runname)
#f))
(mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
(rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))
(cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
(mtcachef (car cachefiles)) ;; (and cachedir (conc cachedir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash)))
(rccachef (cdr cachefiles)) ;; (and cachedir (conc cachedir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))
(cancreate (and rundir (common:file-exists? rundir)(file-write-access? rundir) (not (common:in-running-test?)))))
;; (cxt (hash-table-ref/default *contexts* toppath #f)))
) ;; (cancreate (and cachedir (common:file-exists? cachedir)(file-write-access? cachedir) (not (common:in-running-test?)))))
;; create our cxt for this area if it doesn't already exist
;; (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt)))
;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef)
(set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource
;;(BB> "launch:setup-body -- cachefiles="cachefiles)
(cond
;; if mtcachef exists just read it, however we need to assume toppath is available in $MT_RUN_AREA_HOME
((and mtcachef (common:file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME") use-cache)
(set! *configdat* (configf:read-alist mtcachef))
((and (not force-reread) mtcachef (common:file-exists? mtcachef) (get-environment-variable "MT_RUN_AREA_HOME") use-cache)
;;(BB> "launch:setup-body -- cond branch 1 - use-cache")
(set! *configdat* (configf:read-alist mtcachef))
;;(BB> "launch:setup-body -- 1 set! *configdat*="*configdat*)
(set! *runconfigdat* (configf:read-alist rccachef))
(set! *configinfo* (list *configdat* (get-environment-variable "MT_RUN_AREA_HOME")))
(set! *configstatus* 'fulldata)
(set! *toppath* (get-environment-variable "MT_RUN_AREA_HOME"))
*toppath*)
;; we have all the info needed to fully process runconfigs and megatest.config
(mtcachef
((and (not force-reread) mtcachef) ;; BB- why are we doing this without asking if caching is desired?
;;(BB> "launch:setup-body -- cond branch 2")
(let* ((first-pass (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
mtconfig
environ-patt: "env-override"
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"))
(first-rundat (let ((toppath (if toppath
toppath
(car first-pass))))
(read-config ;; (conc toppath "/runconfigs.config") ;; this should be converted to runconfig:read but it is non-trivial, leaving it for now.
(conc (if (string? toppath)
toppath
(get-environment-variable "MT_RUN_AREA_HOME"))
"/runconfigs.config")
*runconfigdat* #t
sections: sections))))
(set! *runconfigdat* first-rundat)
(if first-pass ;;
(begin
;;(BB> "launch:setup-body -- \"first-pass\"=first-pass")
(set! *configdat* (car first-pass))
;;(BB> "launch:setup-body -- 2 set! *configdat*="*configdat*)
(set! *configinfo* first-pass)
(set! *toppath* (or toppath (cadr first-pass))) ;; use the gathered data unless already have it
(set! toppath *toppath*)
(if (not *toppath*)
(begin
(debug:print-error 0 *default-log-port* "you are not in a megatest area!")
(exit 1)))
|
︙ | | |
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
|
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
|
-
-
+
+
+
+
+
-
-
+
+
-
+
+
+
+
-
+
+
|
given-toppath: toppath
pathenvvar: "MT_RUN_AREA_HOME"))
(runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config
(for-each (lambda (kt)
(setenv (car kt) (cadr kt)))
key-vals)
(read-config (conc toppath "/runconfigs.config") *runconfigdat* #t ;; consider using runconfig:read some day ...
sections: sections))))
(if cancreate (configf:write-alist runconfigdat rccachef))
sections: sections)))
(cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
(mtcachef (car cachefiles))
(rccachef (cdr cachefiles)))
(if rccachef (configf:write-alist runconfigdat rccachef))
(set! *runconfigdat* runconfigdat)
(if cancreate (configf:write-alist *configdat* mtcachef))
(if cancreate (set! *configstatus* 'fulldata))))
(if mtcachef (configf:write-alist *configdat* mtcachef))
(if (and rccachef mtcachef) (set! *configstatus* 'fulldata))))
;; no configs found? should not happen but let's try to recover gracefully, return an empty hash-table
(set! *configdat* (make-hash-table))
(begin (set! *configdat* (make-hash-table))
;;(BB> "launch:setup-body -- 3 set! *configdat*="*configdat*)
)
)))
;; else read what you can and set the flag accordingly
(else
;;(BB> "launch:setup-body -- cond branch 3 - else")
(let* ((cfgdat (find-and-read-config
(or (args:get-arg "-config") "megatest.config")
environ-patt: "env-override"
given-toppath: (get-environment-variable "MT_RUN_AREA_HOME")
pathenvvar: "MT_RUN_AREA_HOME")))
(if cfgdat
(if (and cfgdat (list? cfgdat) (> (length cfgdat) 0) (hash-table? (car cfgdat)))
(let* ((toppath (or (get-environment-variable "MT_RUN_AREA_HOME")(cadr cfgdat)))
(rdat (read-config (conc toppath ;; convert this to use runconfig:read!
"/runconfigs.config") *runconfigdat* #t sections: sections)))
(set! *configinfo* cfgdat)
(set! *configdat* (car cfgdat))
(set! *runconfigdat* rdat)
(set! *toppath* toppath)
|
︙ | | |
949
950
951
952
953
954
955
956
957
958
959
960
961
962
|
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
|
+
+
+
+
+
+
+
+
+
|
(setenv "MT_TESTSUITENAME" (common:get-testsuite-name)))
(begin
(debug:print-error 0 *default-log-port* "failed to find the top path to your Megatest area.")
;;(exit 1)
(set! *toppath* #f) ;; force it to be false so we return #f
#f
))
;; one more attempt to cache the configs for future reading
(let* ((cachefiles (launch:get-cache-file-paths areapath toppath target mtconfig))
(mtcachef (car cachefiles))
(rccachef (cdr cachefiles)))
(if (and rccachef *runconfigdat*) (configf:write-alist *runconfigdat* rccachef))
(if (and mtcachef *configdat*) (configf:write-alist *configdat* mtcachef))
(if (and rccachef mtcachef *runconfigdat* *configdat*)
(set! *configstatus* 'fulldata)))
;; if have -append-config then read and append here
(let ((cfname (args:get-arg "-append-config")))
(if (and cfname
(file-read-access? cfname))
(read-config cfname *configdat* #t))) ;; values are added to the hash, no need to do anything special.
*toppath*)))
|
︙ | | |
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
|
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
|
-
+
|
;; - could be netbatch
;; (launch-test db (cadr status) test-conf))
(define (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat params)
(mutex-lock! *launch-setup-mutex*) ;; setting variables and processing the testconfig is NOT thread-safe, reuse the launch-setup mutex
(let* ((item-path (item-list->path itemdat))
(contour #f)) ;; NOT READY FOR THIS (args:get-arg "-contour")))
(let loop ((delta (- (current-seconds) *last-launch*))
(launch-delay (string->number (or (configf:lookup *configdat* "setup" "launch-delay") "5"))))
(launch-delay (configf:lookup-number *configdat* "setup" "launch-delay" default: 1)))
(if (> launch-delay delta)
(begin
(debug:print-info 0 *default-log-port* "Delaying launch of " test-name " for " (- launch-delay delta) " seconds")
(thread-sleep! (- launch-delay delta))
(loop (- (current-seconds) *last-launch*) launch-delay))))
(change-directory *toppath*)
(alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute", *maybe* - the longer they are set the longer each launch takes (must be non-overlapping with the vars)
|
︙ | | |
︙ | | |
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
+
-
-
+
+
-
-
-
|
;; (include "common.scm")
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
http-client srfi-18 extras format) ;; zmq extras)
readline apropos json http-client directory-utils typed-records
http-client srfi-18 extras format)
;; Added for csv stuff - will be removed
;;
(use sparse-vectors)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(import (prefix rpc rpc:))
(require-library mutils)
;; (use zmq)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
|
︙ | | |
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
-
+
|
-test-paths : get the test paths matching target, runname, item and test
patterns.
-list-disks : list the disks available for storing runs
-list-targets : list the targets in runconfigs.config
-list-db-targets : list the target combinations used in the db
-show-config : dump the internal representation of the megatest.config file
-show-runconfig : dump the internal representation of the runconfigs.config file
-dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc.
-dumpmode MODE : dump in MODE format instead of sexpr, MODE=json,ini,sexp etc. (add -debug 0,9 to see which file contributes each line)
-show-cmdinfo : dump the command info for a test (run in test environment)
-section sectionName
-var varName : for config and runconfig lookup value for sectionName varName
-since N : get list of runs changed since time N (Unix seconds)
-fields fieldspec : fields to include in json dump; runs:id,runame+tests:testname+steps
-sort fieldname : in -list-runs sort tests by this field
|
︙ | | |
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
436
437
438
439
440
441
442
443
|
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
436
437
438
439
440
441
442
443
444
445
|
-
+
+
-
+
+
+
+
-
+
-
+
|
"-server"
"-list-disks"
"-list-targets"
"-show-runconfig"
;;"-list-db-targets"
"-show-runconfig"
"-show-config"
"-show-cmdinfo"))
"-show-cmdinfo"
"-cleanup-db"))
(no-watchdog-args-vals (filter (lambda (x) x)
(map args:get-arg no-watchdog-args)))
(start-watchdog (null? no-watchdog-args-vals)))
;;(BB> "no-watchdog-args="no-watchdog-args "no-watchdog-args-vals="no-watchdog-args-vals)
(if start-watchdog
(thread-start! *watchdog*)))
;; bracket open-output-file with code to make leading directory if it does not exist and handle exceptions
(define (open-logfile logpath)
(condition-case
(let* ((log-dir (or (pathname-directory logpath) ".")))
(if (not (directory-exists? log-dir))
(system (conc "mkdir -p " log-dir)))
(open-output-file logpath))
(exn ()
(debug:print-error 0 *default-log-port* "Could not open log file for write: "logpath)
(define *didsomething* #t)
(exit 1))))
;; this segment will run launch:setup only if -log is not set. This is fairly safe as servers are not
;; manually started and thus should never be started in a non-megatest area. Thus no need to handle situation
;; where (launch:setup) returns #f?
;;
(if (or (args:get-arg "-log")(args:get-arg "-server")) ;; redirect the log always when a server
(handle-exceptions
exn
(begin
(print "ERROR: Failed to switch to log output. " ((conition-property-accessor 'exn 'message) exn))
(print "ERROR: Failed to switch to log output. " ((condition-property-accessor 'exn 'message) exn))
)
(let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server
(let* ((tl (or (args:get-arg "-log")(launch:setup))) ;; run launch:setup if -server, ensure we do NOT run launch:setup if -log specified
(logf (or (args:get-arg "-log") ;; use -log unless we are a server, then craft a logfile name
(conc tl "/logs/server-" (current-process-id) "-" (get-host-name) ".log")))
(oup (open-logfile logf)))
(if (not (args:get-arg "-log"))
(hash-table-set! args:arg-hash "-log" logf)) ;; fake out future queries of -log
(debug:print-info 0 *default-log-port* "Sending log output to " logf)
(set! *default-log-port* oup))))
|
︙ | | |
492
493
494
495
496
497
498
499
500
501
502
503
504
505
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(process:children #f))
(original-exit exit-code)))))
;; for some switches always print the command to stderr
;;
(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status")
(debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
;; some switches imply homehost. Exit here if not on homehost
;;
(let ((homehost-required (list "-cleanup-db" "-server")))
(if (apply args:any? homehost-required)
(if (not (common:on-homehost?))
(for-each
(lambda (switch)
(if (args:get-arg switch)
(begin
(debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
(exit 1))))
homehost-required))))
;;======================================================================
;; Misc setup stuff
;;======================================================================
(debug:setup)
|
︙ | | |
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
|
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
|
-
+
|
(if (and rundir ;; have all needed variabless
(directory-exists? rundir)
(file-write-access? rundir))
(begin
(if (not (common:in-running-test?))
(configf:write-alist data cfgf))
;; force re-read of megatest.config - this resolves circular references between megatest.config
(launch:setup force: #t)
(launch:setup force-reread: #t)
(launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig
data))))
(if (args:get-arg "-show-runconfig")
(let ((tl (launch:setup)))
(push-directory *toppath*)
(let ((data (full-runconfigs-read)))
|
︙ | | |
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
|
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
|
-
+
|
(for-each
(lambda (test)
(common:debug-handle-exceptions #f
exn
(begin
(debug:print-error 0 *default-log-port* "Bad data in test record? " test)
(print "exn=" (condition->list exn))
(debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port)))
(let* ((test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test))
(testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test))
(itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test))
(comment (if (member "comment" tests-spec)(get-value-by-fieldname test test-field-index "comment" ) #f)) ;; (db:test-get-comment test))
(tstate (if (member "state" tests-spec)(get-value-by-fieldname test test-field-index "state" ) #f)) ;; (db:test-get-state test))
|
︙ | | |
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
|
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
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
|
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; run all tests are are Not COMPLETED and PASS or CHECK
(if (or (args:get-arg "-runall")
(args:get-arg "-run")
(args:get-arg "-rerun-clean")
(args:get-arg "-rerun-all")
(args:get-arg "-runtests"))
(let ((need-clean (or (args:get-arg "-rerun-clean")
(args:get-arg "-rerun-all"))))
(general-run-call
"-runall"
"run all tests"
(lambda (target runname keys keyvals)
(if (args:get-arg "-rerun-clean") ;; first set states/statuses correct
(let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
"KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
(statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
"FAIL,INCOMPLETE,ABORT,CHECK")))
(hash-table-set! args:arg-hash "-preclean" #t)
(runs:operate-on 'set-state-status
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
"%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
state: states
;; status: statuses
new-state-status: "NOT_STARTED,n/a")
(runs:clean-cache target runname *toppath*)
(runs:operate-on 'set-state-status
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
"%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;; state: states
status: statuses
new-state-status: "NOT_STARTED,n/a")))
;; RERUN ALL
(if (args:get-arg "-rerun-all") ;; first set states/statuses correct
(begin
(hash-table-set! args:arg-hash "-preclean" #t)
(runs:operate-on 'set-state-status
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
"%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
state: #f
;; status: statuses
new-state-status: "NOT_STARTED,n/a")
(runs:clean-cache target runname *toppath*)
(runs:operate-on 'set-state-status
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
"%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;; state: states
status: #f
new-state-status: "NOT_STARTED,n/a")))
(runs:run-tests target
runname
#f ;; (common:args-get-testpatt #f)
;; (or (args:get-arg "-testpatt")
;; "%")
user
args:arg-hash))))
(general-run-call
"-runall"
"run all tests"
(lambda (target runname keys keyvals)
(if (args:get-arg "-rerun-clean") ;; first set states/statuses correct
(let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states")
"KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED"))
(statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses")
"FAIL,INCOMPLETE,ABORT,CHECK")))
(hash-table-set! args:arg-hash "-preclean" #t)
(runs:operate-on 'set-state-status
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
"%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
state: states
;; status: statuses
new-state-status: "NOT_STARTED,n/a")
(runs:clean-cache target runname *toppath*)
(runs:operate-on 'set-state-status
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
"%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;; state: states
status: statuses
new-state-status: "NOT_STARTED,n/a")))
;; RERUN ALL
(if (args:get-arg "-rerun-all") ;; first set states/statuses correct
(begin
(hash-table-set! args:arg-hash "-preclean" #t)
(runs:operate-on 'set-state-status
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
"%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
state: #f
;; status: statuses
new-state-status: "NOT_STARTED,n/a")
(runs:clean-cache target runname *toppath*)
(runs:operate-on 'set-state-status
target
(common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
"%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
;; state: states
status: #f
new-state-status: "NOT_STARTED,n/a")))
(runs:run-tests target
runname
#f ;; (common:args-get-testpatt #f)
;; (or (args:get-arg "-testpatt")
;; "%")
user
args:arg-hash)))))
;;======================================================================
;; run one test
;;======================================================================
;; 1. find the config file
;; 2. change to the test directory
|
︙ | | |
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
|
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
|
-
+
|
(if (args:get-arg "-cleanup-db")
(begin
(if (not (launch:setup))
(begin
(debug:print 0 *default-log-port* "Failed to setup, exiting")
(exit 1)))
(let ((dbstruct (db:setup *toppath*)))
(let ((dbstruct (db:setup #f areapath: *toppath*)))
(common:cleanup-db dbstruct))
(set! *didsomething* #t)))
(if (args:get-arg "-mark-incompletes")
(begin
(if (not (launch:setup))
(begin
|
︙ | | |
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
|
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
|
-
+
|
(if (or (getenv "MT_RUNSCRIPT")
(args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup))
(dbstruct (if (and toppath
(common:on-homehost?))
(db:setup)
(db:setup #t)
#f))) ;; make-dbr:dbstruct path: toppath local: (args:get-arg "-local")) #f)))
(if *toppath*
(cond
((getenv "MT_RUNSCRIPT")
;; How to run megatest scripts
;;
;; #!/bin/bash
|
︙ | | |
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
|
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
|
-
+
-
+
|
;; ;; ;; redo me (db:close-all dbstruct)
;; ;; ;; redo me (list "uname" "rundir" "final_logf" "comment"))
;; ;; ;; redo me (set! *didsomething* #t)))
(if (args:get-arg "-import-megatest.db")
(begin
(db:multi-db-sync
(db:setup)
(db:setup #f)
'killservers
'dejunk
'adj-testids
'old2new
;; 'new2old
)
(set! *didsomething* #t)))
(if (args:get-arg "-sync-to-megatest.db")
(begin
(db:multi-db-sync
(db:setup)
(db:setup #f)
'new2old
)
(set! *didsomething* #t)))
(if (args:get-arg "-sync-to")
(let ((toppath (launch:setup)))
(tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to"))
|
︙ | | |
︙ | | |
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
|
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
-
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
;; (include "common.scm")
;; (include "megatest-version.scm")
;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
srfi-18 extras format pkts pkts regex regex-case
srfi-18 extras format pkts regex regex-case
(prefix dbi dbi:)) ;; zmq extras)
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
(include "megatest-fossil-hash.scm")
(require-library stml)
;; stuff for the mapper and checker functions
;;
(define *target-mappers* (make-hash-table)) ;; '())
(define *runname-mappers* (make-hash-table)) ;; '())
(define *target-mappers* (make-hash-table))
(define *runname-mappers* (make-hash-table))
(define *area-checkers* (make-hash-table))
;; helpers for mappers/checkers
(define (add-target-mapper name proc)
(hash-table-set! *target-mappers* name proc))
(define (add-runname-mapper name proc)
(hash-table-set! *runname-mappers* name proc))
(define (add-area-checker name proc)
(hash-table-set! *area-checkers* name proc))
;; given a runkey, xlatr-key and other info return one of the following:
;; list of targets, null list to skip processing
;;
(define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f))
(let* ((xlatr-key (or xlatr-key-in
(conf-get/default mtconf aval-alist 'targtrans)))
(proc (hash-table-ref/default *target-mappers* xlatr-key #f)))
(if proc
(begin
(print "Using target mapper: " area-xlatr)
(handle-exceptions
exn
(begin
(print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr)
(print " function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) )
(print " message: " ((condition-property-accessor 'exn 'message) exn))
runkey)
(proc runkey area contour)))
(begin
(if xlatr-key
(print "ERROR: Failed to find named target translator " xlatr-key ", using original target."))
`(,runkey))))) ;; no proc then use runkey
;; given mtconf and areaconf extract a translator/filter, first look at areaconf
;; then if not found look at default
;;
(define (conf-get/default mtconf areaconf keyname #!key (default #f))
(let ((res (or (alist-ref keyname areaconf)
(configf:lookup mtconf "default" (conc keyname))
default)))
(if res
(string->symbol res)
res)))
;; this needs some thought regarding security implications.
;;
;; i. Check that owner of the file and calling user are same?
;; ii. Check that we are in a legal megatest area?
;; iii. Have some form of authentication or record of the md5sum or similar of the file?
;; iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing"
;; required to use .mtutil.scm.
;;
(if (file-exists? "megatest.config")
(if (file-exists? ".mtutil.so")
(load ".mtutil.so")
(if (file-exists? ".mtutil.scm")
(load ".mtutil.scm"))))
(load ".mtutil.scm"))))
;; Disabled help items
;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s)
;; from prior runs with same keys
;; Contour actions
;; import : import pkts
;; dispatch : dispatch queued run jobs from imported pkts
;; rungen : look at input sense list in [rungen] and generate run pkts
(define help (conc "
mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright Matt Welland 2006-2017
Usage: mtutil action [options]
-h : this help
-manual : show the Megatest user manual
-version : print megatest version (currently " megatest-version ")
Actions:
run : initiate runs
remove : remove runs
rerun : register action for processing
set-ss : set state/status
archive : compress and move test data to archive disk
kill : stop tests or entire runs
db : database utilities
-h : this help
-manual : show the Megatest user manual
-version : print megatest version (currently " megatest-version ")
Actions:
run : initiate runs
remove : remove runs
rerun : register action for processing
set-ss : set state/status
archive : compress and move test data to archive disk
kill : stop tests or entire runs
db : database utilities
areas, contours, setup : show areas, contours or setup section from megatest.config
Contour actions:
process : runs import, rungen and dispatch
Selectors
-immediate : apply this action immediately, default is to queue up actions
-area areapatt1,area2... : apply this action only to the specified areas
-target key1/key2/... : run for key1, key2, etc.
-test-patt p1/p2,p3/... : % is wildcard
-run-name : required, name for this particular test run
-contour contourname : run all targets for contourname, requires -run-name, -target
-state-status c/p,c/f : Specify a list of state and status patterns
-tag-expr tag1,tag2%,.. : select tests with tags matching expression
-mode-patt key : load testpatt from <key> in runconfigs instead of default TESTPATT
if -testpatt and -tagexpr are not specified
-new state/status : specify new state/status for set-ss
Misc
-start-dir path : switch to this directory before running mtutil
-set-vars V1=1,V2=2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-log logfile : send stdout and stderr to logfile
-repl : start a repl (useful for extending megatest)
-load file.scm : load and run file.scm
-debug N|N,M,O... : enable debug messages 0-N or N and M and O ...
Utility
db pgschema : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"
process : runs import, rungen and dispatch
Selectors
-immediate : apply this action immediately, default is to queue up actions
-area areapatt1,area2... : apply this action only to the specified areas
-target key1/key2/... : run for key1, key2, etc.
-test-patt p1/p2,p3/... : % is wildcard
-run-name : required, name for this particular test run
-contour contourname : run all targets for contourname, requires -run-name, -target
-state-status c/p,c/f : Specify a list of state and status patterns
-tag-expr tag1,tag2%,.. : select tests with tags matching expression
-mode-patt key : load testpatt from <key> in runconfigs instead of default TESTPATT
if -testpatt and -tagexpr are not specified
-new state/status : specify new state/status for set-ss
Misc
-start-dir path : switch to this directory before running mtutil
-set-vars V1=1,V2=2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-log logfile : send stdout and stderr to logfile
-repl : start a repl (useful for extending megatest)
-load file.scm : load and run file.scm
-debug N|N,M,O... : enable debug messages 0-N or N and M and O ...
Utility
db pgschema : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\"
Examples:
# Start a megatest run in the area \"mytests\"
mtutil -area mytests -action run -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick
mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick
# Start a contour
mtutil run -contour quick -target v1.63/aa3e
Called as " (string-intersperse (argv) " ") "
Version " megatest-version ", built from " megatest-fossil-hash ))
|
︙ | | |
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; alist to map actions to old megatest commands
(define *action-keys*
'((run . "-run")
(sync . "")
(archive . "-archive")
(set-ss . "-set-state-status")))
;; Card types:
;;
;; A action
;; U username (Unix)
;; D timestamp
;; T card type
;; utilitarian alist for standard cards
;;
(define *additional-cards*
'(
;; Standard Cards
(A . action )
(D . timestamp )
(T . cardtype )
(U . user ) ;; username
(Z . shar1sum )
;; Extras
(a . runkey ) ;; needed for matching up pkts with target derived from runkey
))
;; inlst is an alternative input
;;
(define (lookup-param-by-key key #!key (inlst #f))
(fold (lambda (a res)
(if (eq? (cdr a) key)
(car a)
|
︙ | | |
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
|
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
|
-
-
-
-
-
-
-
-
|
(else ;; have some unrecognised junk? spit out error message
(print "ERROR: fossil timeline returned unrecognisable junk \"" inl "\"")
(loop (get-line) date node time))))
(else ;; no more datat and last node on branch not found
(close-input-port timeline-port)
(values (common:date-time->seconds (conc date " " time)) node))))))
;;======================================================================
;; GLOBALS
;;======================================================================
;; Card types:
;;
;; a action
;; u username (Unix)
;; D timestamp
;; T card type
;; process args
(define *action* (if (> (length (argv)) 1)
(cadr (argv))
#f))
(define remargs (args:get-args
(if *action* (cdr (argv)) (argv)) ;; args:get-args dumps first in argv list (the program name)
(map car *arg-keys*)
|
︙ | | |
299
300
301
302
303
304
305
306
307
308
309
310
311
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
337
338
339
340
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
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
436
437
438
439
440
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
|
359
360
361
362
363
364
365
366
367
368
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
434
435
436
437
438
439
440
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
|
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
+
+
-
-
+
+
-
+
-
-
+
+
-
+
+
+
-
-
+
+
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
|
;;
(if (and (not (null? remargs))
(not (or
(args:get-arg "-runstep")
(args:get-arg "-envcap")
(args:get-arg "-envdelta")
(member *action* '("db")) ;; very loose checks on db.
(equal? *action* "show") ;; just keep going if list
)))
(debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " ")))
(if (or (args:any? "-h" "help" "-help" "--help")
(member *action* '("-h" "-help" "--help" "help")))
(begin
(print help)
(exit 1)))
;;======================================================================
;; pkts
;;======================================================================
(define (with-queue-db mtconf proc)
(let* ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))
(toppath (configf:lookup mtconf "dyndat" "toppath"))
(pdbpath (or (configf:lookup mtconf "setup" "pdbpath") pktsdir)))
(if (not (and pktsdir toppath pdbpath))
(begin
(print "ERROR: settings are missing in your megatest.config for area management.")
(print " you need to have pktsdir in the [setup] section."))
(let* ((pdb (open-queue-db pdbpath "pkts.db"
schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
(proc pktsdirs pktsdir pdb)
(dbi:close pdb)))))
(define (load-pkts-to-db mtconf)
(with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(for-each
(lambda (pktsdir) ;; look at all
(if (and (file-exists? pktsdir)
(directory? pktsdir)
(file-read-access? pktsdir))
(let ((pkts (glob (conc pktsdir "/*.pkt"))))
(for-each
(lambda (pkt)
(let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
(exists (lookup-by-uuid pdb uuid #f)))
(if (not exists)
(let* ((pktdat (string-intersperse
(with-input-from-file pkt read-lines)
"\n"))
(apkt (pkt->alist pktdat))
(ptype (alist-ref 'T apkt)))
(add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0)
(debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
(debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
)))
pkts))))
(string-split pktsdirs)))))
(define (get-pkt-alists pkts)
(map (lambda (x)
(alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt
pkts))
;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending
;; also delete duplicates by target i.e. (car pkt)
(define (get-pkt-times pkts)
(delete-duplicates
(sort
(map (lambda (x)
`(,(alist-ref 't x) . ,(string->number (alist-ref 'D x))))
pkts)
(lambda (a b)(> (cdr a)(cdr b)))) ;; sort descending
(lambda (a b)(equal? (car a)(car b))))) ;; remove duplicates by target
;;======================================================================
;; Runs
;;======================================================================
;; make a runname
;;
(define (make-runname pre post)
(time->string
(seconds->local-time (current-seconds)) "%Yw%V.%w-%H%M"))
;; collect, translate, collate and assemble a pkt from the command-line
;;
;; sched => force the run start time to be recorded as sched Unix
;; epoch. This aligns times properly for triggers in some cases.
;;
(define (command-line->pkt action args-alist sched-in)
(define (command-line->pkt action args-alist sched-in #!key (extra-dat '()))
(let* ((sched (cond
((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time
((number? sched-in) sched-in)
(else (current-seconds))))
(args-data (if args-alist
(if (hash-table? args-alist) ;; seriously?
(hash-table->alist args-alist)
args-alist)
(hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline
(alldat (apply append (list 'T "cmd"
'a action
'A action
'U (current-user-name)
'D sched)
extra-dat
(map (lambda (x)
(let* ((param (car x))
(value (cdr x))
(pmeta (assoc param *arg-keys*)) ;; translate the card key to a megatest switch or parameter
(smeta (assoc param *switch-keys*)) ;; first lookup the key in arg-keys or switch-keys
(meta (if (or pmeta smeta)
(cdr (or pmeta smeta)) ;; found it?
#f)))
(if (or pmeta smeta) ;; construct the switch/param pair.
(list meta value)
'())))
(filter cdr args-data)))))
;; (print "Alldat: " alldat
;; " args-data: " args-data)
(print "Alldat: " alldat
" args-data: " args-data)
(add-z-card
(apply construct-sdat alldat))))
(define (simple-setup start-dir-in)
(let* ((start-dir (or start-dir-in "."))
(mtconfig (or (args:get-arg "-config") "megatest.config"))
(mtconfdat (find-and-read-config ;; NB// sets MT_RUN_AREA_HOME as side effect
mtconfig
;; environ-patt: "env-override"
given-toppath: start-dir
;; pathenvvar: "MT_RUN_AREA_HOME"
))
(mtconf (if mtconfdat (car mtconfdat) #f)))
;; we set some dynamic data in a section called "dyndata"
;; we set some dynamic data in a section called "scratchdata"
(if mtconf
(begin
(configf:section-var-set! mtconf "dyndat" "toppath" start-dir)))
;; (print "TOPPATH: " (configf:lookup mtconf "dyndat" "toppath"))
(configf:section-var-set! mtconf "scratchdat" "toppath" start-dir)))
;; (print "TOPPATH: " (configf:lookup mtconf "scratchdat" "toppath"))
mtconfdat))
;; NEED TIMESTAMP ON PKTS for efficient loading of packets into db.
;; make a run request pkt from basic data, this seriously needs to be refactored
;; i. Take the code that builds the info to submit to create-run-pkt and have it
;; generate the pkt keys directly.
;; ii. Pass the pkt keys and values to this proc and go from there.
;; iii. Maybe have an abstraction alist with meaningful names for the pkt keys
;;
;; Override the run start time record with sched. Usually #f is fine.
;;
(define (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf runtrans)
(define (create-run-pkt mtconf action area runkey target runname mode-patt
tag-expr pktsdir reason contour sched dbdest append-conf
runtrans)
(let* ((good-val (lambda (inval)(and inval (string? inval)(not (string-null? inval)))))
(area-dat (val->alist (or (configf:lookup mtconf "areas" area) "")))
(area-path (alist-ref 'path area-dat))
(area-xlatr (alist-ref 'targtrans area-dat))
(new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
;; (area-xlatr (alist-ref 'targtrans area-dat))
;; (xlatr-key (if area-xlatr (string->symbol area-xlatr) #f))
(new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f))
(mapper (if callname (hash-table-ref/default *runname-mappers* callname #f) #f)))
;; (print "callname=" callname " runtrans=" runtrans " mapper=" mapper)
(if (and callname
(not (equal? callname "auto"))
(not mapper))
(print "No mapper " callname " for area " area " using " callname " as the runname"))
(if mapper
(handle-exceptions
exn
(begin
(print-call-chain)
(print "FAILED TO RUN RUNNAME MAPPER " callname " FOR AREA " area)
(print " message: " ((condition-property-accessor 'exn 'message) exn))
runname)
(print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")")
(mapper runkey runname area area-path reason contour mode-patt))
(case callname
((auto) runname)
(else runtrans)))))
(new-target (if area-xlatr
(new-target target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour))
(let ((xlatr-key (string->symbol area-xlatr)))
(if (hash-table-exists? *target-mappers* xlatr-key)
(begin
(print "Using target mapper: " area-xlatr)
(handle-exceptions
exn
(begin
(print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr)
(print " function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) )
(print " message: " ((condition-property-accessor 'exn 'message) exn))
runkey)
((hash-table-ref *target-mappers* xlatr-key)
runkey new-runname area area-path reason contour mode-patt)))
(begin
(print "ERROR: Failed to find named target translator " xlatr-key ", using original target.")
runkey)))
runkey))
(actual-action (if action
(if (equal? action "sync-prepend")
"sync"
action)
"run"))) ;; this has gotten a bit ugly. Need a function to handle actions processing.
;; some hacks to remove switches not needed in certain cases
(case (string->symbol (or action "run"))
((sync sync-prepend)
(set! new-target #f)
(set! runame #f)))
(print "area-path: " area-path " area-xlatr: " area-xlatr " orig-target: " runkey " new-target: " new-target)
;; (print "area-path: " area-path " orig-target: " runkey " new-target: " new-target)
(let-values (((uuid pkt)
(command-line->pkt
actual-action
(append
`(("-start-dir" . ,area-path)
("-msg" . ,reason)
("-contour" . ,contour))
|
︙ | | |
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
|
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
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
'())
(if (or (not action)
(equal? action "run"))
`(("-preclean" . " ")
("-rerun-all" . " ")) ;; if run we *always* want preclean set, use single space as placeholder
'())
)
sched)))
sched
extra-dat: `(a ,runkey) ;; we need the run key for marking the run as launched
)))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt))))))
;; look for areas=a1,a2,a3 OR areafn=somefuncname
;;
(define (val-alist->areas val-alist)
(let ((areas-string (alist-ref 'areas val-alist))
(areas-procname (alist-ref 'areafn val-alist)))
(if areas-procname ;; areas-procname take precedence
areas-procname
(string-split (or areas-string "") ","))))
(define (area-allowed? area areas runkey contour)
(cond
((not areas) #t) ;; no spec
((string? areas) ;;
(let ((check-fn (hash-table-ref/default *area-checkers* areas #f)))
(if check-fn
(check-fn area runkey contour)
#f)))
((list? areas)(member area areas))
(else #f))) ;; shouldn't get here
;; (use trace)(trace create-run-pkt)
;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
(let ((std-runname (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))
(with-queue-db
(common:with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
(rgconf (car rgconfdat))
(all-areas (map car (configf:get-section mtconf "areas")))
(contours (configf:get-section mtconf "contours"))
(torun (make-hash-table)) ;; target => ( ... info ... )
|
︙ | | |
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
|
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
|
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
-
+
-
-
-
+
-
-
+
+
+
-
-
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(ruletype (if (> len-key 1)(cadr keyparts) #f))
(action (if (> len-key 2)(caddr keyparts) #f))
(optional (if (> len-key 3)(cadddr keyparts) #f))
;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params
(val-alist (val->alist val))
(runname (make-runname "" ""))
(runtrans (alist-ref 'runtrans val-alist))
;; these may or may not be defined and not all are used in each handler type in the case below
(run-name (alist-ref 'run-name val-alist))
(target (alist-ref 'target val-alist))
(crontab (alist-ref 'cron val-alist))
(areas (val-alist->areas val-alist)) ;; areas can be a single string (a reference to call an areas function), or a list of area names.
(dbdest (alist-ref 'dbdest val-alist))
(appendconf (alist-ref 'appendconf val-alist))
(file-globs (alist-ref 'glob val-alist))
(runstarts (find-pkts pdb '(runstart) `((o . ,contour)
(t . ,runkey))))
(rspkts (get-pkt-alists runstarts))
(rspkts (common:get-pkt-alists runstarts))
;; starttimes is for run start times and is used to know when the last run was launched
(starttimes (get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
(last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
0
(apply max (map cdr starttimes))))
(starttimes (common:get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target
(last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max
0
(apply max (map cdr starttimes))))
;; synctimes is for figuring out the last time a sync was done
(syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc.
(sspkts (get-pkt-alists syncstarts))
(synctimes (get-pkt-times sspkts))
(last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max
0
(apply max (map cdr synctimes))))
(syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc.
(sspkts (common:get-pkt-alists syncstarts))
(synctimes (common:get-pkt-times sspkts))
(last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max
0
(apply max (map cdr synctimes))))
)
(let ((delta (lambda (x)
(round (/ (- (current-seconds) x) 60)))))
(print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync)))
(print "val-alist=" val-alist " runtrans=" runtrans)
;; look in runstarts for matching runs by target and contour
;; get the timestamp for when that run started and pass it
;; to the rule logic here where "ruletype" will be applied
;; if it comes back "changed" then proceed to register the runs
(case (string->symbol (or ruletype "no-such-rule"))
((no-such-rule) (print "ERROR: no such rule for " sense))
;; Handle crontab like rules
;;
((scheduled)
(if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec
(print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist)
(let* ((run-name (alist-ref 'run-name val-alist))
(let* (
(target (alist-ref 'target val-alist))
(crontab (alist-ref 'cron val-alist))
;; (action (alist-ref 'action val-alist))
(cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X"))
(cron-safe-string (string-translate (string-intersperse (string-split crontab) "-") "*" "X"))
(runname std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))))
;; (print "last-run: " last-run " need-run: " need-run)
;; (if need-run
(case (string->symbol action)
((sync sync-prepend)
(if (common:extended-cron crontab #f last-sync)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":sync-" cron-safe-string))
(action . ,action)
(dbdest . ,(alist-ref 'dbdest val-alist))
(append . ,(alist-ref 'appendconf val-alist))))))
(dbdest . ,dbdest)
(append . ,appendconf)
(areas . ,areas)))))
((run)
(if (common:extended-cron crontab #f last-run)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":" cron-safe-string))
(runname . ,runname)
`((message . ,(conc ruletype ":" cron-safe-string))
(runname . ,runname)
(runtrans . ,runtrans)
(action . ,action)
(target . ,target)))))
(action . ,action)
(areas . ,areas)
(target . ,target)))))
((remove)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":" cron-safe-string))
(runname . ,runname)
(runtrans . ,runtrans)
(action . ,action)
(areas . ,areas)
(target . ,target))))
(else
(print "ERROR: action \"" action "\" has no scheduled handler")
)))))
;; script based sensors
;;
((script)
;; syntax is a little different here. It is a list of commands to run, "scriptname = extra_parameters;scriptname = ..."
;; where scriptname may be repeated multiple times. The script must return unix-epoch of last change, new-target-name and new-run-name
;; the script is called like this: scriptname contour runkey std-runname action extra_param1 extra_param2 ...
(for-each
(lambda (cmd)
(print "cmd: " cmd)
|
︙ | | |
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
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
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
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
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
|
692
693
694
695
696
697
698
699
700
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
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
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
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
|
+
-
+
+
+
+
-
-
+
+
+
-
+
+
-
-
+
+
+
-
+
+
-
+
+
+
-
-
+
-
-
+
+
-
-
+
+
+
-
-
-
+
+
+
+
-
+
-
+
+
-
-
+
-
-
+
+
+
-
-
+
+
-
+
-
-
+
+
-
-
+
+
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
+
|
(need-run (> last-change last-run)))
(print "last-run: " last-run " need-run: " need-run)
(if need-run
(let* ((key-msg `((message . ,(conc ruletype ":" message))
(runname . ,runname)
(runtrans . ,runtrans)
(action . ,action)
(areas . ,areas)
(target . ,new-target))))
(target . ,new-target) ;; overriding with result from runing the script
)))
(print "key-msg: " key-msg)
(push-run-spec torun contour
(if optional ;; we need to be able to differentiate same contour, different behavior.
(conc runkey ":" optional) ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE
runkey)
key-msg)))))))
val-alist)) ;; iterate over the param split by ;\s*
;; fossil scm based triggers
;;
((fossil)
(for-each
(lambda (fspec)
(print "fspec: " fspec)
(let* ((url (symbol->string (car fspec))) ;; THIS COULD BE TROUBLE. Add option to reading line to return as string.
(branch (cdr fspec))
(url-is-file (string-match "^(/|file:).*$" url))
(fname (conc (common:get-signature url) ".fossil"))
(fdir (conc "/tmp/" (current-user-name) "/mtutil_cache")))
;; (if (not url-is-file) ;; need to sync first --- for now, clone 'em all.
(fossil:clone-or-sync url fname fdir) ;; )
(let-values (((datetime node)
(fossil:last-change-node-and-time fdir fname branch)))
(if (null? starttimes)
(push-run-spec torun contour runkey
`((message . ,(conc "fossil:" branch "-neverrun"))
(runname . ,(conc runname "-" node))
`((message . ,(conc "fossil:" branch "-neverrun"))
(runname . ,(conc runname "-" node))
(runtrans . ,runtrans)
(areas . ,areas)
(target . ,runkey)))
;; (target . ,runkey)
))
(if (> datetime last-run) ;; change time is greater than last-run time
(push-run-spec torun contour runkey
`((message . ,(conc "fossil:" branch "-" node))
(runname . ,(conc runname "-" node))
`((message . ,(conc "fossil:" branch "-" node))
(runname . ,(conc runname "-" node))
(runtrans . ,runtrans)
(areas . ,areas)
(target . ,runkey)))))
;; (target . ,runkey)
))))
(print "Got datetime=" datetime " node=" node))))
val-alist))
;; sensor looking for one or more files newer than reference
;;
((file file-or) ;; one or more files must be newer than the reference
(let* ((file-globs (alist-ref 'glob val-alist))
(youngestdat (common:get-youngest (common:bash-glob file-globs)))
(let* ((youngestdat (common:get-youngest (common:bash-glob file-globs)))
(youngestmod (car youngestdat)))
;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
(if (null? starttimes) ;; this target has never been run
(push-run-spec torun contour runkey
`((message . "file:neverrun")
(action . ,action)
`((message . "file:neverrun")
(action . ,action)
(runtrans . ,runtrans)
(target . ,runkey)
(runname . ,runname)))
;; (target . ,runkey)
(areas . ,areas)
(runname . ,runname)))
;; (for-each
;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour
;; (if (> youngestmod (cdr starttime))
;; (begin
;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
(if (> youngestmod last-run)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":" (cadr youngestdat)))
(action . ,action)
(target . ,runkey)
`((message . ,(conc ruletype ":" (cadr youngestdat)))
(action . ,action)
;; (target . ,runkey)
(runtrans . ,runtrans)
(areas . ,areas)
(runname . ,runname)
(runname . ,runname)
))))))
;; starttimes))
;; all globbed files must be newer than the reference
;;
((file-and) ;; all files must be newer than the reference
(let* ((file-globs (alist-ref 'glob val-alist))
(youngestdat (common:get-youngest file-globs))
(let* ((youngestdat (common:get-youngest file-globs))
(youngestmod (car youngestdat))
(success #t)) ;; any cases of not true, set flag to #f for AND
;; (print "youngestmod: " youngestmod " starttimes: " starttimes)
(if (null? starttimes) ;; this target has never been run
(push-run-spec torun contour runkey
`((message . "file:neverrun")
(runname . ,runname)
`((message . "file:neverrun")
(runname . ,runname)
(runtrans . ,runtrans)
(areas . ,areas)
(target . ,runkey)
(action . ,action)))
;; (target . ,runkey)
(action . ,action)))
;; NB// I think this is wrong. It should be looking at last-run only.
(if (> youngestmod last-run)
(if (> youngestmod last-run) ;; WAIT!! Shouldn't file-and be looking at the *oldest* file (thus all are younger than ...)
;; (for-each
;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour
;; (if (< youngestmod (cdr starttime))
;; (set! success #f)))
;; starttimes))
;; (if success
;; (begin
;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod)
(push-run-spec torun contour runkey
`((message . ,(conc ruletype ":" (cadr youngestdat)))
(runname . ,runname)
`((message . ,(conc ruletype ":" (cadr youngestdat)))
(runname . ,runname)
(runtrans . ,runtrans)
(target . ,runkey)
(action . ,action)
;; (target . ,runkey)
(areas . ,areas)
(action . ,action)
))))))
(else (print "ERROR: unrecognised rule \"" ruletype)))))
keydats))) ;; sense rules
(hash-table-keys rgconf))
;; now have to run populated
(for-each
(lambda (contour)
(print "contour: " contour)
(let* ((val (or (configf:lookup mtconf "contours" contour) ""))
(val-alist (val->alist val))
(areas (string-split (or (alist-ref 'areas val-alist) "") ","))
(selector (alist-ref 'selector val-alist))
(mode-tag (and selector (string-split-fields "/" selector #:infix)))
(mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
(tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
(let* ((cval (or (configf:lookup mtconf "contours" contour) ""))
(cval-alist (val->alist cval)) ;; BEWARE ... NOT the same val-alist as above!
(areas (val-alist->areas cval-alist))
(selector (alist-ref 'selector cval-alist))
(mode-tag (and selector (string-split-fields "/" selector #:infix)))
(mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f)))
(tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag)))))
(print "contour: " contour " areas=" areas " cval=" cval)
(for-each
(lambda (runkeydatset)
;; (print "runkeydatset: ")(pp runkeydatset)
(let ((runkey (car runkeydatset))
(runkeydats (cadr runkeydatset)))
(for-each
(lambda (runkeydat)
(for-each
(lambda (area)
(if (area-allowed? area areas runkey contour) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...)
(let* ((aval (or (configf:lookup mtconf "areas" area) ""))
(aval-alist (val->alist aval))
(let ((runname (alist-ref 'runname runkeydat))
(runtrans (alist-ref 'runtrans runkeydat))
(reason (alist-ref 'message runkeydat))
(sched (alist-ref 'sched runkeydat))
(action (alist-ref 'action runkeydat))
(dbdest (alist-ref 'dbdest runkeydat))
(append (alist-ref 'append runkeydat))
(target (or (alist-ref 'target runkeydat) runkey))) ;; override with target if forced
(print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target)
(if (case (or (and action (string->symbol action)) 'noaction) ;; ensure we have the needed data to run this action
((noaction) #f)
((run) (and runname reason))
((sync sync-prepend) (and reason dbdest))
(else #f))
;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt
(create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans)
(print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest)
)))
all-areas))
(runname (alist-ref 'runname runkeydat))
(runtrans (alist-ref 'runtrans runkeydat))
(reason (alist-ref 'message runkeydat))
(sched (alist-ref 'sched runkeydat))
(action (alist-ref 'action runkeydat))
(dbdest (alist-ref 'dbdest runkeydat))
(append (alist-ref 'append runkeydat))
(targets (or (alist-ref 'target runkeydat)
(map-targets mtconf aval-alist runkey area contour)))) ;; override with target if forced
;; NEED TO EXPAND RUNKEY => ALL TARGETS MAPPED AND THEN FOREACH ....
(for-each
(lambda (target)
(print "Creating pkt for runkey=" runkey " target=" target " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt)
(if (case (or (and action (string->symbol action)) 'noaction) ;; ensure we have the needed data to run this action
((noaction) #f)
((run) (and runname reason))
((sync sync-prepend) (and reason dbdest))
(else #f))
;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt
(create-run-pkt mtconf action area runkey target runname mode-patt
tag-expr pktsdir reason contour sched dbdest append
runtrans)
(print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest)
))
targets))
(print "NOTE: skipping " runkeydat " for area \"" area "\", not in " areas)))
all-areas))
runkeydats)))
(let ((res (configf:get-section torun contour))) ;; each contour / target
;; (print "res=" res)
res))))
(hash-table-keys torun)))))))
(define (pkt->cmdline pkta)
(let ((action (or (lookup-action-by-key (alist-ref 'a pkta)) "noaction")))
(let ((action (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction")))
(fold (lambda (a res)
(let* ((key (car a)) ;; get the key name
(val (cdr a))
(par (or (lookup-param-by-key key) ;; need to check also if it is a switch
(lookup-param-by-key key inlst: *switch-keys*))))
;; (print "key: " key " val: " val " par: " par)
(if par
(conc res " " (param-translate par) " " val)
(if (member key '(a Z U D T)) ;; a is the action
(if (alist-ref key *additional-cards*) ;; these cards do not translate to parameters or switches
res
(begin
(print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"")
res)))))
(conc "megatest " (if (not (member action '("sync")))
(conc action " ")
""))
|
︙ | | |
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
|
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
|
-
+
-
+
|
exn
#f
(create-directory "logs")
#t)
#t)
"logs"
"/tmp")))
(with-queue-db
(common:with-queue-db
mtconf
(lambda (pktsdirs pktsdir pdb)
(let* ((rgconfdat (find-and-read-config (conc toppath "/runconfigs.config")))
(rgconf (car rgconfdat))
(areas (configf:get-section mtconf "areas"))
(contours (configf:get-section mtconf "contours"))
(pkts (find-pkts pdb '(cmd) '()))
(torun (make-hash-table)) ;; target => ( ... info ... )
(rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering
(for-each
(lambda (pktdat)
(let* ((pkta (alist-ref 'apkt pktdat))
(action (alist-ref 'a pkta))
(action (alist-ref 'A pkta))
(cmdline (pkt->cmdline pkta))
(uuid (alist-ref 'Z pkta))
(logf (conc logdir "/" uuid "-run.log"))
(fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline)))
(print "RUNNING: " fullcmd)
(system fullcmd)
(mark-processed pdb (list (alist-ref 'id pktdat)))
|
︙ | | |
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
|
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
|
-
+
-
+
-
+
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(if *action*
(case (string->symbol *action*)
((run remove rerun set-ss archive kill)
((run remove rerun set-ss archive kill list)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(pktsdirs (configf:lookup mtconf "setup" "pktsdirs"))
(pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))
(adjargs (hash-table-copy args:arg-hash)))
;; (for-each
;; (lambda (key)
;; (if (not (member key *legal-params*))
;; (hash-table-delete! adjargs key))) ;; we need to delete any params intended for mtutil
;; (hash-table-keys adjargs))
(let-values (((uuid pkt)
(command-line->pkt *action* adjargs #f)))
(write-pkt pktsdir uuid pkt))))
((dispatch import rungen process)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(toppath (configf:lookup mtconf "dyndat" "toppath")))
(toppath (configf:lookup mtconf "scratchdat" "toppath")))
(case (string->symbol *action*)
((process) (begin
(load-pkts-to-db mtconf)
(common:load-pkts-to-db mtconf)
(generate-run-pkts mtconf toppath)
(load-pkts-to-db mtconf)
(common:load-pkts-to-db mtconf)
(dispatch-commands mtconf toppath)))
((import) (load-pkts-to-db mtconf)) ;; import pkts
((import) (common:load-pkts-to-db mtconf)) ;; import pkts
((rungen) (generate-run-pkts mtconf toppath))
((dispatch) (dispatch-commands mtconf toppath)))))
;; misc
((show)
(if (> (length remargs) 0)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat))
(sect-dat (configf:get-section mtconf (car remargs))))
(if sect-dat
(for-each
(lambda (entry)
(if (> (length entry) 1)
(print (car entry) " " (cadr entry))
(print (car entry))))
sect-dat)
(print "No section \"" (car remargs) "\" found")))
(print "ERROR: list requires section parameter; areas, setup or contours")))
((gendot)
(let* ((mtconfdat (simple-setup (args:get-arg "-start-dir")))
(mtconf (car mtconfdat)))
(with-queue-db
mtconf
(lambda (pktsdirs pktsdir conn)
(make-report "out.dot" conn '())))))
((db)
(if (null? remargs)
(print "ERROR: missing sub command for db command")
(let ((subcmd (car remargs)))
(case (string->symbol subcmd)
((pgschema)
(let* ((install-home (common:get-install-area))
|
︙ | | |
961
962
963
964
965
966
967
|
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
|
+
+
+
+
+
+
|
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines])
(current-input-port (make-readline-port "mtutil> "))
(if (args:get-arg "-repl")
(repl)
(load (args:get-arg "-load")))))
#|
(define mtconf (car (simple-setup #f)))
(define dat (with-queue-db mtconf (lambda (conn)(get-pkts conn '()))))
(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
|#
|
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
|
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
|
-
+
-
-
|
;; Copyright 2006-2016, 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.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18)
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
posix-extras directory-utils pathname-expand typed-records format)
(import (prefix sqlite3 sqlite3:))
(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))
(declare (uses keys))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
|
︙ | | |
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
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
|
-
+
+
-
+
+
+
+
+
+
+
+
+
+
|
exn
(let ((call-chain (get-call-chain))
(msg ((condition-property-accessor 'exn 'message) exn)))
(if (< count 5)
(begin ;; this call is colliding, do some crude stuff to fix it.
(debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count)
(launch:setup force-reread: #t)
(fatal-loop (+ count 1)))
(fatal-loop (+ count 1)))
(begin
(debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg)
(debug:print 0 *default-log-port* "Call chain:")
(with-output-to-port *default-log-port*
(lambda ()(pp call-chain)))
(lambda ()
(print "*configdat* is >>"*configdat*"<<")
(pp *configdat*)
(pp call-chain)))
(exit 1))))
;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5")
(when (or (not *configdat*) (not (hash-table? *configdat*)))
(debug:print 0 *default-log-port* "WARNING: *configdat* was inaccessible! This should never happen. Brute force reread.")
;;(BB> "ERROR: *configdat* was inaccessible! This should never happen. Brute force reread.")
(thread-sleep! 2) ;; assuming nfs lag.
(launch:setup force-reread: #t))
(alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block.
;;(bb-check-path msg: "runs:set-megatest-env-vars block 2")
;; Lets use this as an opportunity to put MT_RUNNAME in the environment
(let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
(if runname
(setenv "MT_RUNNAME" runname)
(debug:print-error 0 *default-log-port* "no value for runname for id " run-id)))
|
︙ | | |
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
(if (runs:lownoise (conc "maxjobgroup " jobgroup) 60)
(debug:print 1 *default-log-port* "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)))))
(define (runs:run-pre-hook run-id)
(let* ((run-pre-hook (configf:lookup *configdat* "runs" "pre-hook"))
(existing-tests (if run-pre-hook
(rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses
#f #f ;; offset limit
#f ;; not-in
#f ;; sort-by
#f ;; sort-order
#f ;; get full data (not 'shortlist)
0 ;; (runs:gendat-inc-results-last-update *runs:general-data*) ;; last update time
'dashboard)
'()))
(log-dir (conc *toppath* "/logs"))
(log-file (conc "pre-hook-" (string-translate (getenv "MT_TARGET") "/" "-") "-" (getenv "MT_RUNNAME") ".log"))
(full-log-fname (conc log-dir "/" log-file)))
(if run-pre-hook
(if (null? existing-tests)
(let* ((use-log-dir (if (not (directory-exists? log-dir))
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "WARNING: Failed to create " log-dir)
#f)
(create-directory log-dir #t)
#t)
#t))
(start-time (current-seconds))
(actual-logf (if use-log-dir full-log-fname log-file)))
(handle-exceptions
exn
(begin
(print-call-chain *default-log-port*)
(debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 0 *default-log-port* "ERROR: failed to run pre-hook " run-pre-hook ", check the log " log-file))
(debug:print-info 0 *default-log-port* "running run-pre-hook: \"" run-pre-hook "\", log is " actual-logf)
(system (conc run-pre-hook " >> " actual-logf " 2>&1"))
(debug:print-info 0 *default-log-port* "pre-hook \"" run-pre-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))
(debug:print 0 *default-log-port* "Skipping pre-hook call \"" run-pre-hook "\" as there are existing tests for this run.")))))
;; 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 #!key (run-count 1)) ;; test-names
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
|
︙ | | |
290
291
292
293
294
295
296
297
298
299
300
301
302
303
|
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
|
+
+
+
+
+
+
|
(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keyvals target)
(begin
(debug:print 0 *default-log-port* "WARNING: You do not have a run config file: " runconfigf)
#f)))
(if (not test-patts) ;; first time in - adjust testpatt
(set! test-patts (common:args-get-testpatt runconf)))
;; if test-patts is #f at this point there is something wrong and we need to bail out
(if (not test-patts)
(begin
(debug:print 0 *default-log-port* "WARNING: there is no test pattern for this run. Exiting now.")
(exit 0)))
(if (args:get-arg "-tagexpr")
(begin
(set! allowed-tests (string-join (runs:get-tests-matching-tags (args:get-arg "-tagexpr")) ","))
(debug:print-info 0 *default-log-port* "filtering initial test list with tagexpr: " (args:get-arg "-tagexpr") " => " allowed-tests)
));; tests will be ANDed with this list
;; register this run in monitor.db
|
︙ | | |
359
360
361
362
363
364
365
366
367
368
369
370
371
372
|
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
|
+
+
+
+
|
(rmt:set-tests-state-status run-id test-names state status "NOT_STARTED" status)))
;; list of state/status pairs separated by spaces
(string-split (or (configf:lookup *configdat* "setup" "allow-auto-rerun") "")))))
;; Ensure all tests are registered in the test_meta table
(runs:update-all-test_meta #f)
;; run the run prehook if there are no tests yet run for this run:
;;
(runs:run-pre-hook run-id)
;; now add non-directly referenced dependencies (i.e. waiton)
;;======================================================================
;; refactoring this block into tests:get-full-data
;;
;; What happended, this code is now duplicated in tests!?
;;
;;======================================================================
|
︙ | | |
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
|
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
|
-
+
-
-
-
-
+
|
(let* ((run-info (rmt:get-run-info run-id))
(tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path"))
(sorted-test-names (tests:sort-by-priority-and-waiton test-records))
(test-registry (make-hash-table))
(registry-mutex (make-mutex))
(num-retries 0)
(max-retries (config-lookup *configdat* "setup" "maxretries"))
(max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs")))
(max-concurrent-jobs (configf:lookup-number *configdat* "setup" "max_concurrent_jobs" default: 50))
(if (and mcj (string->number mcj))
(string->number mcj)
1))) ;; length of the register queue ahead
(reglen (if (number? reglen-in) reglen-in 1))
(reglen (if (number? reglen-in) reglen-in 1))
(last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle
(last-time-some-running (current-seconds))
;; (tdbdat (tasks:open-db))
(runsdat (make-runs:dat
;; hed: hed
;; tal: tal
;; reg: reg
|
︙ | | |
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
|
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
|
-
|
(let* ((write-access-actions '(remove-runs set-state-status archive run-wait))
(dbfile (conc *toppath* "/megatest.db"))
(readonly-mode (not (file-write-access? dbfile))))
(when (and readonly-mode
(member action write-access-actions))
(debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .")
(exit 1)))
(debug:print-info 4 *default-log-port* "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status)
(if (> 2 (length state-status))
(begin
(debug:print-error 0 *default-log-port* "the parameter to -set-state-status is a comma delimited string. E.g. COMPLETED,FAIL")
(exit)))
(for-each
|
︙ | | |