Megatest

Check-in [a51a5d6058]
Login
Overview
Comment:wip
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80-reshape
Files: files | file ages | folders
SHA1: a51a5d6058d77d61c9238458b30449860a566cb7
User & Date: matt on 2023-01-30 20:20:41
Other Links: branch diff | manifest | tags
Context
2023-01-31
08:23
Rearranged imports and uses and now past the dreaded can't import debugprint. check-in: 474192c412 user: matt tags: v1.80-reshape
2023-01-30
22:06
removed all imports of debugprint and still can't run megatest exe check-in: 5de6734970 user: matt tags: v1.80-reshape-no-debugprint
20:20
wip check-in: a51a5d6058 user: matt tags: v1.80-reshape
2023-01-29
22:01
wip-no-compile check-in: 9f479c2454 user: matt tags: v1.80-reshape
Changes

Modified Makefile from [0820a667ed] to [7f2dc43cfa].

29
30
31
32
33
34
35
36

37
38
39
40
41

42
43
44

45
46
47
48
49
50
51
29
30
31
32
33
34
35

36
37
38
39
40

41
42
43
44
45
46
47
48
49
50
51
52







-
+




-
+



+







           cgisetup/models/pgdb.scm

# server.scm http-transport.scm client.scm rmt.scm

# module source files
MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \
            configfmod.scm servermod.scm clientmod.scm rmtmod.scm        \
            artifacts.scm 
            artifacts.scm apimod.scm

all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut

# dbmod.import.o is just a hack here
mofiles/dbfile.o     : mofiles/debugprint.o mofiles/commonmod.o # dbmod.import.o
mofiles/dbfile.o mofiles/clientmod.o mofiles/dbmod.o mofiles/rmtmod.o : mofiles/debugprint.o mofiles/commonmod.o # dbmod.import.o
db.o : dbmod.import.o
mofiles/debugprint.o : mofiles/mtargs.o
mofiles/servermod.o  : mofiles/artifacts.o
mofiles/rmtmod.o     : mofiles/apimod.o

# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm	\
#             mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm	\
#             rmtmod.scm apimod.scm

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
174
175
176
177
178
179
180
181

182
183
184
185
186
187
188
175
176
177
178
179
180
181

182
183
184
185
186
187
188
189







-
+







monitor.o dashboard.o archive.o megatest.o : db_records.scm megatest-fossil-hash.scm

tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o  : run_records.scm

db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm
db.o api.o : mofiles/dbmod.o mofiles/dbfile.o mofiles/debugprint.o mofiles/commonmod.o dbmod.import.o

tests.o tasks.o dashboard-tasks.o : task_records.scm
# tests.o tasks.o dashboard-tasks.o : task_records.scm

runs.o : test_records.scm

mofiles-made : $(MOFILES)
	make $(MOIMPFILES)

megatest.o : mofiles-made megatest-fossil-hash.scm megatest-version.scm $(MOFILES) $(MOIMPFILES)

Modified api.scm from [5d01bf138b] to [fb1ad3313e].

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
24
25
26
27
28
29
30
31
32
33
34


35
36













































































































37
38
39
40
41
42
43







+



-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








(declare (unit api))
(declare (uses rmtmod))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))
(declare (uses debugprint))

(import dbmod)
(import dbfile)
(import rmtmod)

(import rmtmod
	debugprint)
;; allow these queries through without starting a server
;;
(define api:read-only-queries
  '(get-key-val-pairs
    get-var
    get-keys
    get-key-vals
    test-toplevel-num-items
    get-test-info-by-id
    get-steps-info-by-id
    get-data-info-by-id
    test-get-rundir-from-test-id
    get-count-tests-running-for-testname
    get-count-tests-running
    get-count-tests-running-in-jobgroup
    get-previous-test-run-record
    get-matching-previous-test-run-records
    test-get-logfile-info
    test-get-records-for-index-file
    get-testinfo-state-status
    test-get-top-process-pid
    test-get-paths-matching-keynames-target-new
    get-prereqs-not-met
    get-count-tests-running-for-run-id
    get-run-info
    get-run-status
    get-run-state
    get-run-stats
    get-run-times
    get-targets
    get-target
    ;; register-run
    get-tests-tags
    get-test-times
    get-tests-for-run
    get-tests-for-run-state-status
    get-test-id
    get-tests-for-runs-mindata
    get-tests-for-run-mindata
    get-run-name-from-id
    get-runs
    simple-get-runs
    get-num-runs
    get-runs-cnt-by-patt
    get-all-run-ids
    get-prev-run-ids
    get-run-ids-matching-target
    get-runs-by-patt
    get-steps-data
    get-steps-for-test
    read-test-data
    read-test-data-varpatt
    login
    tasks-get-last
    testmeta-get-record
    have-incompletes?
    ;; synchash-get
    get-changed-record-ids
    get-run-record-ids 
    get-not-completed-cnt))

(define api:write-queries
  '(
    get-keys-write ;; dummy "write" query to force server start

    ;; SERVERS
    ;; start-server
    ;; kill-server

    ;; TESTS
    test-set-state-status-by-id
    delete-test-records
    delete-old-deleted-test-records
    test-set-state-status
    test-set-top-process-pid
    set-state-status-and-roll-up-items
    
    update-pass-fail-counts
    top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")

    ;; RUNS
    register-run
    set-tests-state-status
    delete-run
    lock/unlock-run
    update-run-event_time
    mark-incomplete
    set-state-status-and-roll-up-run
    ;; STEPS
    teststep-set-status!
    delete-steps-for-test
    ;; TEST DATA
    test-data-rollup
    csv->test-data

    ;; MISC
    sync-inmem->db
    drop-all-triggers
    create-all-triggers
    update-tesdata-on-repilcate-db 

    ;; TESTMETA
    testmeta-add-record
    testmeta-update-field

    ;; TASKS
    tasks-add
    tasks-set-state-given-param-key
    ))

(define *db-write-mutexes* (make-hash-table))

;; These are called by the server on recipt of /api calls
;;    - keep it simple, only return the actual result of the call, i.e. no meta info here
;;
;;    - returns #( flag result )

Modified apimod.scm from [a7cef484dc] to [a87fc9869a].

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31















































































































32
33
34
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







-







-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+



;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit apimod))
(declare (uses commonmod))
(declare (uses ulex))

(module apimod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import commonmod)
(import (prefix ulex ulex:))

;; allow these queries through without starting a server
;;
(define api:read-only-queries
  '(get-key-val-pairs
    get-var
    get-keys
    get-key-vals
    test-toplevel-num-items
    get-test-info-by-id
    get-steps-info-by-id
    get-data-info-by-id
    test-get-rundir-from-test-id
    get-count-tests-running-for-testname
    get-count-tests-running
    get-count-tests-running-in-jobgroup
    get-previous-test-run-record
    get-matching-previous-test-run-records
    test-get-logfile-info
    test-get-records-for-index-file
    get-testinfo-state-status
    test-get-top-process-pid
    test-get-paths-matching-keynames-target-new
    get-prereqs-not-met
    get-count-tests-running-for-run-id
    get-run-info
    get-run-status
    get-run-state
    get-run-stats
    get-run-times
    get-targets
    get-target
    ;; register-run
    get-tests-tags
    get-test-times
    get-tests-for-run
    get-tests-for-run-state-status
    get-test-id
    get-tests-for-runs-mindata
    get-tests-for-run-mindata
    get-run-name-from-id
    get-runs
    simple-get-runs
    get-num-runs
    get-runs-cnt-by-patt
    get-all-run-ids
    get-prev-run-ids
    get-run-ids-matching-target
    get-runs-by-patt
    get-steps-data
    get-steps-for-test
    read-test-data
    read-test-data-varpatt
    login
    tasks-get-last
    testmeta-get-record
    have-incompletes?
    ;; synchash-get
    get-changed-record-ids
    get-run-record-ids 
    get-not-completed-cnt))

(define api:write-queries
  '(
    get-keys-write ;; dummy "write" query to force server start

    ;; SERVERS
    ;; start-server
    ;; kill-server

    ;; TESTS
    test-set-state-status-by-id
    delete-test-records
    delete-old-deleted-test-records
    test-set-state-status
    test-set-top-process-pid
    set-state-status-and-roll-up-items
    
    update-pass-fail-counts
    top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst")

    ;; RUNS
    register-run
    set-tests-state-status
    delete-run
    lock/unlock-run
    update-run-event_time
    mark-incomplete
    set-state-status-and-roll-up-run
    ;; STEPS
    teststep-set-status!
    delete-steps-for-test
    ;; TEST DATA
    test-data-rollup
    csv->test-data

    ;; MISC
    sync-inmem->db
    drop-all-triggers
    create-all-triggers
    update-tesdata-on-repilcate-db 

    ;; TESTMETA
    testmeta-add-record
    testmeta-update-field

    ;; TASKS
    tasks-add
    tasks-set-state-given-param-key
    ))



)

Modified archive.scm from [25e6383e3d] to [7a56d0b0c3].

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
33
34
35
36
37
38







+



+
+







;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)

(declare (unit archive))
(declare (uses db))
(declare (uses common))
(declare (uses debugprint))

(include "common_records.scm")
(include "db_records.scm")

(import debugprint)

;;======================================================================
;; 
;;======================================================================

;; NOT CURRENTLY USED
;;

Name change from client.scm to attic/client.scm.

Name change from http-transport.scm to attic/http-transport.scm.

Name change from mockup-cached-writes.scm to attic/mockup-cached-writes.scm.

Name change from monitor.scm to attic/monitor.scm.

Name change from rmtdb.scm to attic/rmtdb.scm.

Name change from server.scm to attic/server.scm.

Name change from synchash.scm to attic/synchash.scm.

Name change from task_records.scm to attic/task_records.scm.

Modified clientmod.scm from [dc86555194] to [cfb1e9f3ec].

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
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







+





+
+







+



+
-
+

+



+

+
+












-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+



+


-
-
+
+

+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+

-
-
+
+
+
+
+
+



;;(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
;;     message-digest matchable spiffy uri-common intarweb http-client
;;     spiffy-request-vars uri-common intarweb directory-utils)

(declare (unit clientmod))
(declare (uses servermod))
(declare (uses artifacts))
(declare (uses debugprint))

(module clientmod
*

(import scheme
	chicken

	posix
	data-structures
	srfi-18
	typed-records

	artifacts
	servermod
	debugprint
	)

(defstruct con ;; client connection
  (hdir       #f) ;; this is the directory sdir/serverhost.serverpid
  (hdir       #f)
  (sdir       #f)
  (obj-to-str #f)
  (str-to-obj #f)
  (host       #f)
  (pid        #f)
  (sdat       #f) ;; server artifact data
  (areapath   #f)
  )

(define *my-client-signature* #f)

(define (client:find-server areapath)
  (let* ((sdir  (conc areapath"/.server"))
	 (sarfs (glob (conc sdir"/*.artifact")))) ;; server artifacts
    (if (null? sarfs)
	(begin
	  (server:launch areapath)
	  (thread-sleep! 1)
	  (client:find-server areapath))
	(let* ((sarf (car sarfs))
	       (sdat (read-artifact->alist sarf))
	       (hdir (alist-ref 'd sdat)))
	  (make-con hdir: hdir sdat: sdat)))))
	  (make-con hdir: hdir sdir: sdir sdat: sdat)))))

;; move this into artifacts
;; find the artifact with key set to val
;;
(define (client:find-artifact arfs key val)
  (let loop ((rem arfs))
    (if (null? rem) ;; didn't find a match
	#f
	(let* ((arf       (car rem))
	       (adat      (read-artifact->alist arf))
	       (val-found (alist-ref key adat)))
	  (if (equal? val-found val)
	      (cons (cons 'path arf) adat) ;; return the artifact as alist anotated with 'path
	      (loop (cdr rem)))))))

(define (client:send-receive con cmd params)
  (let* ((obj->string (con-obj-to-str con))
	 (string->obj (con-str-to-obj con))
	 (arf  `((c . ,cmd)
		 (p . ,(obj->string params))
		 (h . ,(con-host con))
		 (i . ,(con-pid  con))))
		 (h . ,(con-host con))  ;; tells server where to put response
		 (i . ,(con-pid  con))));; and is where this client looks
	 (hdir  (con-hdir con))
	 (sdir  (con-sdir con))
	 (uuid  (write-alist->artifact hdir arf ptype: 'Q)))
    
    ;; wait for a response here
	 (uuid  (write-alist->artifact hdir arf ptype: 'Q))
	 (respdir (conc sdir"/"(con-host con)"."(con-pid con)"/responses")))
    (let loop ((start (current-milliseconds)))
      (let* ((arfs (glob (conc respdir"/*.artifact")))
	     (res  (client:find-artifact arfs 'P uuid)))
	(if res ;; we found our response!
	    (let ((arf  (alist-ref 'path res))
		  (rstr (alist-ref 'r res)))
	      (delete-file arf) ;; done with it, future - move to archive area
	      (string->obj rstr))
	    (begin ;; no response yet, look again in 500ms
	      (thread-sleep! 0.5)
	      (loop (current-milliseconds))))))))

    #f
    ))
;; client:get-signature
(define (client:get-signature)
  (if *my-client-signature* *my-client-signature*
      (let ((sig (conc (get-host-name) " " (current-process-id))))
	(set! *my-client-signature* sig)
	*my-client-signature*)))

)

Modified common.scm from [c2a1a4f762] to [edacec5a50].

25
26
27
28
29
30
31


32


33
34
35
36
37
38
39
25
26
27
28
29
30
31
32
33

34
35
36
37
38
39
40
41
42







+
+
-
+
+







     (prefix nanomsg nmsg:)
     (prefix sqlite3 sqlite3:)
     pkts (prefix dbi dbi:)
     )

(declare (unit common))
(declare (uses commonmod))
(declare (uses debugprint))

(import commonmod)
(import commonmod
	debugprint)

(include "common_records.scm")


;; (require-library margs)
;; (include "margs.scm")

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
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







-
+














-
-
-







(define *db-keys* #f)

(define *pkts-info*    (make-hash-table)) ;; store stuff like the last parent here
(define *configinfo*   #f)   ;; raw results from setup, includes toppath and table from megatest.config
(define *runconfigdat* #f)   ;; run configs data
(define *configdat*    #f)   ;; megatest.config data
(define *configstatus* #f)   ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done
(define *toppath*      #f)

(define *already-seen-runconfig-info* #f)

(define *test-meta-updated* (make-hash-table))
(define *globalexitstatus*  0) ;; attempt to work around possible thread issues
(define *passnum*           0) ;; when running track calls to run-tests or similar
;; (define *alt-log-file* #f)  ;; used by -log
;; (define *common:denoise*    (make-hash-table)) ;; for low noise printing
(define *default-log-port*  (current-error-port))
(define *time-zero* (current-seconds)) ;; for the watchdog
(define *on-exit-procs* '()) ;; add procs to this list to be executed on exit
(define *default-area-tag* "local")

;; DATABASE
;; (define *dbstruct-dbs*         #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex*      (make-mutex))
;; db access
(define *db-last-access*      (current-seconds)) ;; last db access, used in server
;; (define *db-write-access*     #t)
;; db sync
;; (define *db-last-sync*        0)                 ;; last time the sync to megatest.db happened
(define *db-sync-in-progress* #f)                ;; if there is a sync in progress do not try to start another
;; (define *db-multi-sync-mutex* (make-mutex))      ;; protect access to *db-sync-in-progress*, *db-last-sync*
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
169
170
171
172
173
174
175

176
177
178
179
180
181
182







-







(define *db-api-call-time*    (make-hash-table)) ;; hash of command => (list of times)
;; no sync db
;; (define *no-sync-db*          #f)  ;; moved to dbfile

;; SERVER
(define *my-client-signature* #f)
(define *transport-type*    'http)             ;; override with [server] transport http|rpc|nmsg
(define *runremote*         #f)                ;; if set up for server communication this will hold <host port>
;; (define *max-cache-size*    0)
(define *logged-in-clients* (make-hash-table))
(define *server-id*         #f)
(define *server-info*       #f)  ;; good candidate for easily convert to non-global
(define *time-to-exit*      #f)
(define *server-run*        #t)
(define *run-id*            #f)

Modified common_records.scm from [80f9e14f2d] to [fd319a6e15].

75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208































































































































209
210
211
212
213
214
215
75
76
77
78
79
80
81































































































































82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







;;
(define-inline (with-mutex mtx accessor record . val)
  (mutex-lock! mtx)
  (let ((res (apply accessor record val)))
    (mutex-unlock! mtx)
    res))

;; this was cached based on results from profiling but it turned out the profiling
;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; in for now but can probably take it out later.
;;
(define (debug:calc-verbosity vstr)
  (or (hash-table-ref/default *verbosity-cache* vstr #f)
      (let ((res (cond
                  ((number? vstr) vstr)
                  ((not (string?  vstr))   1)
                  ;; ((string-match  "^\\s*$" vstr) 1)
                  (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
                                    (cond
                                     ((> (length debugvals) 1) debugvals)
                                     ((> (length debugvals) 0)(car debugvals))
                                     (else 1))))
                  ((args:get-arg "-v")   2)
                  ((args:get-arg "-q")    0)
                  (else                   1))))
        (hash-table-set! *verbosity-cache* vstr res)
        res)))

;; check verbosity, #t is ok
(define (debug:check-verbosity verbosity vstr)
  (if (not (or (number? verbosity)
	       (list?   verbosity)))
      (begin
	(print "ERROR: Invalid debug value \"" vstr "\"")
	#f)
      #t))

(define (debug:debug-mode n)
  (cond
   ((and (number? *verbosity*)   ;; number number
	 (number? n))
    (<= n *verbosity*))
   ((and (list? *verbosity*)     ;; list   number
	 (number? n))
    (member n *verbosity*))
   ((and (list? *verbosity*)     ;; list   list
	 (list? n))
    (not (null? (lset-intersection! eq? *verbosity* n))))
   ((and (number? *verbosity*)
	 (list? n))
    (member *verbosity* n))))

(define (debug:setup)
  (let ((debugstr (or (args:get-arg "-debug")
		      (args:get-arg "-debug-noprop")
		      (getenv "MT_DEBUG_MODE"))))
    (set! *verbosity* (debug:calc-verbosity debugstr))
    (debug:check-verbosity *verbosity* debugstr)
    ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
    (if (not *verbosity*)(set! *verbosity* 1))
    (if (and (not (args:get-arg "-debug-noprop"))
	     (or (args:get-arg "-debug")
		 (not (getenv "MT_DEBUG_MODE"))))
	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
				    (string-intersperse (map conc *verbosity*) ",")
				    (conc *verbosity*))))))
  
(define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  (if *logging*
	      (db:log-event (apply conc params))
	      (apply print params)
	      )))))

;; Brandon's debug printer shortcut (indulge me :)
(define *BB-process-starttime* (current-milliseconds))
(define (BB> . in-args)
  (let* ((stack (get-call-chain))
         (location "??"))
    (for-each
     (lambda (frame)
       (let* ((this-loc (vector-ref frame 0))
              (temp     (string-split (->string this-loc) " "))
              (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
         (if (equal? this-func "BB>")
             (set! location this-loc))))
     stack)
    (let* ((color-on "\x1b[1m")
           (color-off "\x1b[0m")
           (dp-args
            (append
             (list 0 *default-log-port*
                   (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
             in-args)))
      (apply debug:print dp-args))))

(define *BBpp_custom_expanders_list* (make-hash-table))



;; register hash tables with BBpp.
(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
                 (cons hash-table? hash-table->alist))

;; test name converter
(define (BBpp_custom_converter arg)
  (let ((res #f))
    (for-each
     (lambda (custom-type-name)
       (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
              (custom-type-test      (car custom-type-info))
              (custom-type-converter (cdr custom-type-info)))
         (when (and (not res) (custom-type-test arg))
           (set! res (custom-type-converter arg)))))
     (hash-table-keys *BBpp_custom_expanders_list*))
    (if res (BBpp_ res) arg)))

(define (BBpp_ arg)
  (cond
   ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
   ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
   ((hash-table? arg)
    (let ((al (hash-table->alist arg)))
      (BBpp_ (cons HASH_TABLE: al))))
   ((null? arg) '())
   ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
   ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
   (else (BBpp_custom_converter arg))))

;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
(define (BBpp arg)
  (pp (BBpp_ arg)))
;; ;; this was cached based on results from profiling but it turned out the profiling
;; ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching
;; ;; in for now but can probably take it out later.
;; ;;
;; (define (debug:calc-verbosity vstr)
;;   (or (hash-table-ref/default *verbosity-cache* vstr #f)
;;       (let ((res (cond
;;                   ((number? vstr) vstr)
;;                   ((not (string?  vstr))   1)
;;                   ;; ((string-match  "^\\s*$" vstr) 1)
;;                   (vstr           (let ((debugvals  (filter number? (map string->number (string-split vstr ",")))))
;;                                     (cond
;;                                      ((> (length debugvals) 1) debugvals)
;;                                      ((> (length debugvals) 0)(car debugvals))
;;                                      (else 1))))
;;                   ((args:get-arg "-v")   2)
;;                   ((args:get-arg "-q")    0)
;;                   (else                   1))))
;;         (hash-table-set! *verbosity-cache* vstr res)
;;         res)))
;; 
;; ;; check verbosity, #t is ok
;; (define (debug:check-verbosity verbosity vstr)
;;   (if (not (or (number? verbosity)
;; 	       (list?   verbosity)))
;;       (begin
;; 	(print "ERROR: Invalid debug value \"" vstr "\"")
;; 	#f)
;;       #t))
;; 
;; (define (debug:debug-mode n)
;;   (cond
;;    ((and (number? *verbosity*)   ;; number number
;; 	 (number? n))
;;     (<= n *verbosity*))
;;    ((and (list? *verbosity*)     ;; list   number
;; 	 (number? n))
;;     (member n *verbosity*))
;;    ((and (list? *verbosity*)     ;; list   list
;; 	 (list? n))
;;     (not (null? (lset-intersection! eq? *verbosity* n))))
;;    ((and (number? *verbosity*)
;; 	 (list? n))
;;     (member *verbosity* n))))
;; 
;; (define (debug:setup)
;;   (let ((debugstr (or (args:get-arg "-debug")
;; 		      (args:get-arg "-debug-noprop")
;; 		      (getenv "MT_DEBUG_MODE"))))
;;     (set! *verbosity* (debug:calc-verbosity debugstr))
;;     (debug:check-verbosity *verbosity* debugstr)
;;     ;; if we were handed a bad verbosity rule then we will override it with 1 and continue
;;     (if (not *verbosity*)(set! *verbosity* 1))
;;     (if (and (not (args:get-arg "-debug-noprop"))
;; 	     (or (args:get-arg "-debug")
;; 		 (not (getenv "MT_DEBUG_MODE"))))
;; 	(setenv "MT_DEBUG_MODE" (if (list? *verbosity*)
;; 				    (string-intersperse (map conc *verbosity*) ",")
;; 				    (conc *verbosity*))))))
;;   
;; (define (debug:print n e . params)
;;   (if (debug:debug-mode n)
;;       (with-output-to-port (or e (current-error-port))
;; 	(lambda ()
;; 	  (if *logging*
;; 	      (db:log-event (apply conc params))
;; 	      (apply print params)
;; 	      )))))
;; 
;; ;; Brandon's debug printer shortcut (indulge me :)
;; (define *BB-process-starttime* (current-milliseconds))
;; (define (BB> . in-args)
;;   (let* ((stack (get-call-chain))
;;          (location "??"))
;;     (for-each
;;      (lambda (frame)
;;        (let* ((this-loc (vector-ref frame 0))
;;               (temp     (string-split (->string this-loc) " "))
;;               (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???")))
;;          (if (equal? this-func "BB>")
;;              (set! location this-loc))))
;;      stack)
;;     (let* ((color-on "\x1b[1m")
;;            (color-off "\x1b[0m")
;;            (dp-args
;;             (append
;;              (list 0 *default-log-port*
;;                    (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off "   ")  )
;;              in-args)))
;;       (apply debug:print dp-args))))
;; 
;; (define *BBpp_custom_expanders_list* (make-hash-table))
;; 
;; 
;; 
;; ;; register hash tables with BBpp.
;; (hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE:
;;                  (cons hash-table? hash-table->alist))
;; 
;; ;; test name converter
;; (define (BBpp_custom_converter arg)
;;   (let ((res #f))
;;     (for-each
;;      (lambda (custom-type-name)
;;        (let* ((custom-type-info      (hash-table-ref *BBpp_custom_expanders_list* custom-type-name))
;;               (custom-type-test      (car custom-type-info))
;;               (custom-type-converter (cdr custom-type-info)))
;;          (when (and (not res) (custom-type-test arg))
;;            (set! res (custom-type-converter arg)))))
;;      (hash-table-keys *BBpp_custom_expanders_list*))
;;     (if res (BBpp_ res) arg)))
;; 
;; (define (BBpp_ arg)
;;   (cond
;;    ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg)))
;;    ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg)))
;;    ((hash-table? arg)
;;     (let ((al (hash-table->alist arg)))
;;       (BBpp_ (cons HASH_TABLE: al))))
;;    ((null? arg) '())
;;    ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;    ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
;;    (else (BBpp_custom_converter arg))))
;; 
;; ;; Brandon's pretty printer.  It expands hashes and custom types in addition to regular pp
;; (define (BBpp arg)
;;   (pp (BBpp_ arg)))

;(use define-macro)
(define-syntax inspect
  (syntax-rules ()
    [(_ x)
    ;; (with-output-to-port (current-error-port)
       (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))

Modified commonmod.scm from [2570fcf4eb] to [837b476e48].

39
40
41
42
43
44
45










46
47
48
49
50
51
52
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62







+
+
+
+
+
+
+
+
+
+







;;  testsuite and area utilites
;;
;;======================================================================

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")

;; Globals

(define *runremote*           #f)                ;; if set up for server communication this will hold <host port>
;; db stats
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex*      (make-mutex))
(define *toppath*             #f)
(define *db-keys*             #f)
(define *keyvals*             #f)

(define (get-full-version)
  (conc megatest-version "-" megatest-fossil-hash))

(define (version-signature)
  (conc megatest-version "-" (substring megatest-fossil-hash 0 4)))

(define *common:denoise*    (make-hash-table)) ;; for low noise printing
211
212
213
214
215
216
217
218
219
220
221
222
223
224

225
221
222
223
224
225
226
227







228








-
-
-
-
-
-
-
+
-
	     ,(val->alist (cadr entry))))
	 adat)))

;;======================================================================
;; misc stuff
;;======================================================================

;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions dbgp dbgpinfo)
;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))

)
)

Modified configf.scm from [6390e213ef] to [a8ff1d05bd].

23
24
25
26
27
28
29

30
31


32
33
34
35
36
37
38
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41







+


+
+







;;======================================================================

(use regex regex-case matchable) ;;  directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
(declare (uses debugprint))

(include "common_records.scm")

(import debugprint)

;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
	(if (common:file-exists? cfname)
	    (list toppath cfname configname)

Modified configfmod.scm from [150f2301e2] to [5f13eb2f6f].

15
16
17
18
19
20
21
22
23


24
25
26
27
28
29
30
15
16
17
18
19
20
21


22
23
24
25
26
27
28
29
30







-
-
+
+







;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit configfmod))
;; (declare (uses mtargs))
;; (declare (uses debugprint))
(declare (uses mtargs))
(declare (uses debugprint))
;; (declare (uses keysmod))

(module configfmod
*	

(import srfi-1
  
42
43
44
45
46
47
48
49
50


51
52
53
54
55
56
57
42
43
44
45
46
47
48


49
50
51
52
53
54
55
56
57







-
-
+
+







;;	chicken.process-context
;;	chicken.process-context.posix
;;	chicken.sort
;;	chicken.string
;;	chicken.time
;;	chicken.eval
;;	
;;	debugprint
;;	(prefix mtargs args:)
	debugprint
	(prefix mtargs args:)
;;	pkts
;;	keysmod
;;
;;	(prefix base64 base64:)
;;	(prefix dbi dbi:)
;;	(prefix sqlite3 sqlite3:)
;;	(srfi 18)

Modified dashboard-context-menu.scm from [7325252cd1] to [e159de1324].

37
38
39
40
41
42
43


44
45
46
47


48
49
50
51
52
53
54
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58







+
+




+
+







(declare (uses db))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(declare (uses debugprint))


(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(import debugprint)

(define (dboard:launch-testpanel run-id test-id)
  (let* ((dboardexe (common:find-local-megatest "dashboard"))
         (cmd (conc dboardexe
                    " -test " run-id "," test-id
                    " &")))
    (system cmd)))

Modified dashboard-guimonitor.scm from [60455a8a12] to [d2ee1578bc].

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
36
37
38
39
40
41
42

43
44
45
46
47
48
49







-







(declare (uses keys))
(declare (uses db))
(declare (uses tasks))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")

(define (control-panel db tdb keys)
  (let* ((var-params (make-hash-table)) ;; register all the widgets here for querying on run, rollup, remove?
	 (key-params (make-hash-table))
	 (monitordat '()) ;; list of monitor records
	 (keyentries (iup:frame 
		      #:title "Keys"

Modified dashboard-tests.scm from [e634889bb3] to [65ea816136].

36
37
38
39
40
41
42

43
44
45
46


47
48
49
50
51
52
53
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56







+




+
+







(declare (uses db))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(declare (uses debugprint))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")

(import debugprint)

;;======================================================================
;; C O M M O N
;;======================================================================

(define *dashboard-comment-share-slot* #f)

Modified dashboard.scm from [4ad343f07e] to [0d8f853388].

43
44
45
46
47
48
49

50
51
52
53
54

55
56
57


58
59
60
61
62
63
64
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







+




-
+



+
+







(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
(declare (uses mt))
(declare (uses dbfile))        
(declare (uses debugprint))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")

(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")

(import debugprint)

(dbfile:db-init-proc db:initialize-main-db)

(define help (conc 
	      "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version 
              " license GPL, Copyright (C) Matt Welland 2012-2017

Modified db.scm from [a8c5e5bad4] to [da2478eb1d].

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
45
46
47
48
49
50
51

52
53
54
55
56
57
58
59
60
61
62
63
64
65
66


67
68
69
70
71
72
73
74
75
76







-
+














-
-
+
+
+







     typed-records
     matchable
     files)

(declare (unit db))
(declare (uses common))
(declare (uses dbmod))
;; (declare (uses debugprint))
(declare (uses debugprint))
(declare (uses dbfile))
(declare (uses keys))
(declare (uses ods))
;; (declare (uses client))
(declare (uses mt))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

(define *number-of-writes* 0)
(define *number-non-write-queries* 0)

(import dbmod)
(import dbfile)
(import dbmod
	dbfile
	debugprint)

;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
  (state #f)
  (status #f)
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
































3181
3182
3183
3184
3185
3186
3187
3143
3144
3145
3146
3147
3148
3149
































3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







	testname)
       res))))

;;======================================================================
;; QUEUE UP META, TEST STATUS AND STEPS REMOTE ACCESS
;;======================================================================

;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj #!key (transport 'http))
  (case transport
    ;; ((fs) obj)
    ((http fs)
     (string-substitute
      (regexp "=") "_"
      (base64:base64-encode 
       (z3:encode-buffer
	(with-output-to-string
	  (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating.  serialize is sensitive to binary image of mtest.
      #t))
    ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
    (else obj))) ;; rpc

(define (db:string->obj msg #!key (transport 'http))
  (case transport
    ;; ((fs) msg)
    ((http fs)
     (if (string? msg)
	 (with-input-from-string 
	     (z3:decode-buffer
	      (base64:base64-decode
	       (string-substitute 
		(regexp "_") "=" msg #t)))
	   (lambda ()(deserialize)))
	 (begin
	   (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
           (print-call-chain (current-error-port))
	   msg))) ;; crude reply for when things go awry
    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg))) ;; rpc
;; ;; NOTE: Can remove the regex and base64 encoding for zmq
;; (define (db:obj->string obj #!key (transport 'http))
;;   (case transport
;;     ;; ((fs) obj)
;;     ((http fs)
;;      (string-substitute
;;       (regexp "=") "_"
;;       (base64:base64-encode 
;;        (z3:encode-buffer
;; 	(with-output-to-string
;; 	  (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating.  serialize is sensitive to binary image of mtest.
;;       #t))
;;     ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
;;     (else obj))) ;; rpc
;; 
;; (define (db:string->obj msg #!key (transport 'http))
;;   (case transport
;;     ;; ((fs) msg)
;;     ((http fs)
;;      (if (string? msg)
;; 	 (with-input-from-string 
;; 	     (z3:decode-buffer
;; 	      (base64:base64-decode
;; 	       (string-substitute 
;; 		(regexp "_") "=" msg #t)))
;; 	   (lambda ()(deserialize)))
;; 	 (begin
;; 	   (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
;;            (print-call-chain (current-error-port))
;; 	   msg))) ;; crude reply for when things go awry
;;     ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
;;     (else msg))) ;; rpc

;; ; This is to be the big daddy call NOPE: Replaced by db:set-state-status-and-roll-up-items
;; ;
;; define (db:test-set-state-status dbstruct run-id test-id state status msg)
;;  (let ((dbdat  (db:get-subdb dbstruct run-id)))
;;    (if (member state '("LAUNCHED" "REMOTEHOSTSTART"))
;; 	(db:general-call dbdat 'set-test-start-time (list test-id)))

Modified dbfile.scm from [ec0a32b2ce] to [bea959c089].

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
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







-
+



















+


-
-







;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit dbfile))
;; (declare (uses debugprint))
(declare (uses debugprint))
(declare (uses commonmod))

(module dbfile
	*
	
  (import scheme
	  chicken
	  data-structures
	  extras
	  matchable)
  
(import (prefix sqlite3 sqlite3:)
	posix typed-records srfi-18 srfi-1
	srfi-69
	stack
	files
	ports

	commonmod
	debugprint
	)

;; (import debugprint)

;;======================================================================
;;  R E C O R D S
;;======================================================================

;; a single Megatest area with it's multiple dbs is
;; managed in a dbstruct
;;

Modified dbmod.scm from [043beb90c3] to [c1b3b278a4].

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
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







+




-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+









+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit dbmod))
(declare (uses debugprint))

(module dbmod
	*
	
(import scheme chicken data-structures extras)
(import scheme
	chicken
	ports
	s11n
	z3
	
	data-structures
	extras
	(prefix base64 base64:)
	message-digest
	regex

	debugprint
	)

(import (prefix sqlite3 sqlite3:)
	posix typed-records srfi-18
	srfi-69)

(define (db:run-id->dbname run-id)
  (cond
   ((number? run-id)(conc run-id ".db"))
   ((not run-id)    "main.db")
   (else            run-id)))

;; NOTE: Can remove the regex and base64 encoding for zmq
(define (db:obj->string obj #!key (transport 'http))
  (case transport
    ;; ((fs) obj)
    ((http fs)
     (string-substitute
      (regexp "=") "_"
      (base64:base64-encode 
       (z3:encode-buffer
	(with-output-to-string
	  (lambda ()(serialize obj))))) ;; BB: serialize - this is what causes problems between different builds of megatest communicating.  serialize is sensitive to binary image of mtest.
      #t))
    ((zmq nmsg)(with-output-to-string (lambda ()(serialize obj))))
    (else obj))) ;; rpc

(define (db:string->obj msg #!key (transport 'http))
  (case transport
    ;; ((fs) msg)
    ((http fs)
     (if (string? msg)
	 (with-input-from-string 
	     (z3:decode-buffer
	      (base64:base64-decode
	       (string-substitute 
		(regexp "_") "=" msg #t)))
	   (lambda ()(deserialize)))
	 (begin
	   (debug:print-error 0 *default-log-port* "reception failed. Received \"" msg "\" but cannot translate it.")
           (print-call-chain (current-error-port))
	   msg))) ;; crude reply for when things go awry
    ((zmq nmsg)(with-input-from-string msg (lambda ()(deserialize))))
    (else msg))) ;; rpc


;;======================================================================
;; hash of hashs
;;======================================================================


Modified dcommon.scm from [2cc987e965] to [960040782d].

26
27
28
29
30
31
32

33
34



35
36
37
38
39
40
41
26
27
28
29
30
31
32
33
34

35
36
37
38
39
40
41
42
43
44







+

-
+
+
+







(use regex typed-records matchable)

(declare (unit dcommon))

(declare (uses gutils))
(declare (uses db))
(declare (uses commonmod))
(declare (uses debugprint))

(import commonmod)
(import commonmod
	debugprint
	)
;; (declare (uses synchash))

(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

Modified diff-report.scm from [2363105245] to [350245269f].

15
16
17
18
19
20
21

22
23
24
25
26


27
28
29
30
31
32
33
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36







+





+
+







;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(declare (unit diff-report))
(declare (uses common))
(declare (uses rmtmod))
(declare (uses debugprint))
         
(include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
(import debugprint)

(define css "")

(define (diff:tests-mindat->hash tests-mindat)
  (let* ((res (make-hash-table)))
    (for-each
     (lambda (item)
       (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))

Modified env.scm from [028e47144f] to [2156bd5c58].

15
16
17
18
19
20
21

22
23


24
25
26
27
28
29
30
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33







+


+
+







;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit env))
(declare (uses debugprint))

(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)

(import debugprint)

(define (env:open-db fname)
  (let* ((db-exists (common:file-exists? fname))
	 (db        (open-database fname)))
    (if (not db-exists)
	(begin
	  (exec (sql db "CREATE TABLE envvars (

Modified ezsteps.scm from [aab87817a5] to [e652536dac].

23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
46







+








-
+







     z3 csv typed-records pathname-expand matchable)

(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses debugprint))
;; (declare (uses sdb))
;; (declare (uses filedb))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")


(import debugprint)
;;(rmt:get-test-info-by-id run-id test-id) -> testdat

;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (launch:runstep ezstep run-id test-id exit-info m tal testconfig all-steps-dat)
  (let* ((stepname       (car ezstep))  ;; do stuff to run the step
	 (stepinfo       (cadr ezstep))

Modified genexample.scm from [c6a2ab2853] to [83a6a2da50].

15
16
17
18
19
20
21


22

23
24
25
26
27
28
29
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32







+
+

+







;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit genexample))
(declare (uses debugprint))

(use posix regex matchable)
(import debugprint)

(include "db_records.scm")

(define genexample:example-logpro
#<<EOF
  ;; You should have at least one expect:required. This ensures that your process ran
  ;; comment out the line below and replace "put pattern here" with a pattern that will

Modified items.scm from [16328a4b96] to [b819f8ae5b].

19
20
21
22
23
24
25

26
27


28
29
30
31
32
33
34
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37







+


+
+








;; (define itemdat '((ripeness    "green ripe overripe")
;; 		     (temperature "cool medium hot")
;; 		     (season      "summer winter fall spring")))

(declare (unit items))
(declare (uses common))
(declare (uses debugprint))

(include "common_records.scm")

(import debugprint)

;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
  (let ((res '()))
    (if (not hierdepth)
	(set! hierdepth (length itemlist)))
    (let loop ((hed (car itemlist))

Modified keys.scm from [9fa2c0cfa5] to [d9a1882f80].

17
18
19
20
21
22
23




24
25


26
27
28


29
30
31
32
33
34
35
17
18
19
20
21
22
23
24
25
26
27


28
29
30


31
32
33
34
35
36
37
38
39







+
+
+
+
-
-
+
+

-
-
+
+







;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;
 
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================

(declare (unit keys))
(declare (uses common))
(declare (uses debugprint))

(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(use srfi-1 posix regex regex-case srfi-69
     (prefix sqlite3 sqlite3:))

(declare (unit keys))
(declare (uses common))
(import debugprint)
	

(include "key_records.scm")
(include "common_records.scm")

(define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ...
  (string-intersperse keys ","))

Modified launch.scm from [9881087e2c] to [fed129a191].

30
31
32
33
34
35
36

37
38
39
40
41


42
43
44
45
46
47
48
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51







+





+
+








(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses ezsteps))
(declare (uses debugprint))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")

(import debugprint)

;;======================================================================
;; ezsteps
;;======================================================================

;; ezsteps were going to be coded as
;; stepname[,predstep1,predstep2 ...] [{VAR1=first,second,third}] command to execute

Modified lock-queue.scm from [21543b63ce] to [8e6c749c60].

12
13
14
15
16
17
18
19
20
21
22
23




24
25
26
27
28
29
30
12
13
14
15
16
17
18


19
20
21
22
23
24
25
26
27
28
29
30
31
32







-
-



+
+
+
+







;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;

(use (prefix sqlite3 sqlite3:) srfi-18)

(declare (unit lock-queue))
(declare (uses common))
(declare (uses tasks))
(declare (uses debugprint))

(use (prefix sqlite3 sqlite3:) srfi-18)
(import debugprint)

;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing
;; update requests in an sqlite db
;;======================================================================

;;======================================================================

Modified megatest.scm from [d11cee8fe2] to [555218ae3b].

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
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







-
-
+
+









-
+
+
+







(declare (uses rmtmod))
(declare (uses clientmod))
(declare (uses servermod))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses dbfile))
(declare (uses dbfile.import))
;; (declare (uses debugprint))
;; (declare (uses debugprint.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
;; (declare (uses mtargs))
;; (declare (uses mtargs.import))

;; (declare (uses ftail))
;; (import ftail)

(import dbmod
	commonmod
	dbfile
	servermod)
	servermod
	debugprint
	)

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")

Modified mlaunch.scm from [5bcd34288f] to [955b765f63].

21
22
23
24
25
26
27
28
29
30
31
32


33
21
22
23
24
25
26
27


28
29
30
31
32
33







-
-



+
+

;; MLAUNCH
;;
;;   take jobs from the given queue and keep launching them keeping
;;   the cpu load at the targeted level
;;
;;======================================================================

(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)

(declare (unit mlaunch))
(declare (uses db))
(declare (uses common))

(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)

Modified mt.scm from [849e3c135b] to [1abbf767e0].

26
27
28
29
30
31
32

33
34
35
36
37
38


39
40
41
42
43
44
45
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48







+






+
+







(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses servermod))
(declare (uses runs))
(declare (uses rmtmod))
;; (declare (uses filedb))
(declare (uses debugprint))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

(import debugprint)

;; This is the Megatest API. All generally "useful" routines will be wrapped or extended
;; here.

;;======================================================================
;;  R U N S
;;======================================================================

Modified mtserv.scm from [e7de2023f5] to [ad1041ae0e].

28
29
30
31
32
33
34

35
36
37
38
39
40
41
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42







+







     matchable
     )

;; (declare (uses common))
(declare (uses margs))
(declare (uses configfmod))
(declare (uses servermod))


(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")

(define help (conc "
mtserv, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "

Modified mtut.scm from [413cf26858] to [f9bdb0fdb0].

28
29
30
31
32
33
34

35
36


37
38
39
40
41
42
43
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46







+


+
+







     (prefix sqlite3 sqlite3:)
     nanomsg)

(declare (uses common))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
(declare (uses debugprint))

(use ducttape-lib)

(import debugprint)

(include "megatest-fossil-hash.scm")

(require-library stml)

;; stuff for the mapper and checker functions
;;

Modified newdashboard.scm from [a0c1909f88] to [db5c39b7a4].

34
35
36
37
38
39
40


41
42
43
44
45

46
47
48
49
50
51
52
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55







+
+





+








;; (declare (uses launch))
;; (declare (uses gutils))
;; (declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
(declare (uses debugprint))

;; (declare (uses tree))
;; 
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
(import debugprint)

(define help (conc 
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
  version " megatest-version "
  license GPL, Copyright (C) Matt Welland 2011

Usage: dashboard [options]

Modified portlogger.scm from [8344cdf37f] to [59aa832bb1].

20
21
22
23
24
25
26


27
28
29
30
31
32
33
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35







+
+







(require-extension (srfi 18) extras tcp s11n)

(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3)
(import (prefix sqlite3 sqlite3:))

(declare (unit portlogger))
(declare (uses db))
(declare (uses debugprint))
(import debugprint)

;; lsof -i

(define (portlogger:open-db fname)
  (let* ((avail    (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
	 (exists   (common:file-exists? fname))
	 (db       (if avail 

Modified process.scm from [f525bcbf17] to [4050043a66].

20
21
22
23
24
25
26



27
28
29
30
31
32
33
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36







+
+
+








;;======================================================================
;; Process convience utils
;;======================================================================

(use regex directory-utils)
(declare (unit process))
(declare (uses debugprint))

(import debugprint)

(define (process:conservative-read port)
  (let loop ((res ""))
    (if (not (eof-object? (peek-char port)))
	(loop (conc res (read-char port)))
	res)))

Modified rmt.scm from [b4412653ef] to [00e4366063].

20
21
22
23
24
25
26

27
28
29
30
31



32
33
34
35
36
37
38
20
21
22
23
24
25
26
27
28
29
30
31

32
33
34
35
36
37
38
39
40
41







+




-
+
+
+








(use format typed-records) ;; RADT => purpose of json format??

(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses dbfile))
(declare (uses debugprint))

(include "common_records.scm")
;; (declare (uses rmtmod))

(import dbfile) ;; rmtmod)
(import dbfile
	debugprint
	) ;; rmtmod)

;; ;;
;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;; ;;
;; 
;; ;; generate entries for ~/.megatestrc with the following
;; ;;

Modified rmtmod.scm from [68caa1e403] to [32ffde6ac2].

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
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







+
+








+




-
+
+


+
+








;;======================================================================

(declare (unit rmtmod))
(declare (uses commonmod))
(declare (uses clientmod))
(declare (uses dbmod))
(declare (uses debugprint))
(declare (uses apimod))

(module rmtmod
*

(import scheme
	chicken
	data-structures
	posix
	;; regex
	srfi-1
	srfi-18
	srfi-69
	extras
	

	commonmod
	clientmod
	dbmod
	apimod
	debugprint
	)

;;
;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!!
;;

;; generate entries for ~/.megatestrc with the following
55
56
57
58
59
60
61
62


63
64

65
66
67
68
69
70
71
61
62
63
64
65
66
67

68
69
70
71
72
73
74
75
76
77
78
79







-
+
+


+







;; else return #f to let the calling proc know that there is no server available
;;
(define (rmt:get-connection-info areapath) ;; TODO: push areapath down.
  (if *runremote*
      *runremote*
      (begin
	(set! *runremote* (client:find-server areapath))
	(con-obj-to-str-set! *runremote* db:obj->str)
	(con-obj-to-str-set! *runremote* db:obj->string)
	(con-str-to-obj-set! *runremote* db:string->obj)
	(con-host-set! *runremote* (get-host-name))
	(con-pid-set!  *runremote* (current-process-id))
	(con-areapath-set! *runremote* areapath)
	*runremote*)))
      
  #;(let* ((cinfo     (if (remote? runremote)
			(remote-conndat runremote)
			#f)))
	  (if cinfo
	      cinfo
84
85
86
87
88
89
90
91

92
93
94
95
96
97
98
92
93
94
95
96
97
98

99
100
101
102
103
104
105
106







-
+









;;======================================================================

(define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id

(define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected
  (let* ((con (rmt:get-connection-info areapath)))
  (let* ((con      (rmt:get-connection-info *toppath*)))
    (client:send-receive con cmd params)))
    

  
;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname))
;;
;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected
386
387
388
389
390
391
392
393

394
395
396
397
398
399
400
394
395
396
397
398
399
400

401
402
403
404
405
406
407
408







-
+







			     (if (> tot 10)
				 (cons newmax-cmd currmax)
				 (cons 'none 0))
			     (loop (car tal)(cdr tal) newmax-cmd currmax)))))))
    (mutex-unlock! *db-stats-mutex*)
    res))

(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
#;(define (rmt:open-qry-close-locally cmd run-id params #!key (remretries 5))
  (let* ((qry-is-write    (not (member cmd api:read-only-queries)))
	 (db-file-path    (db:dbfile-path)) ;;  0))
	 (dbstructs-local (db:setup #t))  ;; make-dbr:dbstruct path:  dbdir local: #t)))
	 (read-only       (not (file-write-access? db-file-path)))
	 (start           (current-milliseconds))
	 (resdat          (if (not (and read-only qry-is-write))
			      (let ((v (api:execute-requests dbstructs-local (vector (symbol->string cmd) params))))
429
430
431
432
433
434
435
436

437
438
439
440
441
442
443
437
438
439
440
441
442
443

444
445
446
447
448
449
450
451







-
+







	  (if qry-is-write
	      (let ((start-time (current-seconds)))
		(mutex-lock! *db-multi-sync-mutex*)
/		(set! *db-last-access* start-time)  ;; THIS IS PROBABLY USELESS? (we are on a client)
                (mutex-unlock! *db-multi-sync-mutex*)))))
    res))

(define (rmt:send-receive-no-auto-client-setup runremote cmd run-id params)
#;(define (rmt:send-receive-no-auto-client-setup runremote cmd run-id params)
  (let* ((run-id   (if run-id run-id 0))
	 (res  	   (http-transport:client-api-send-receive run-id runremote cmd params)))
    (if (and res (vector-ref res 0))
	(vector-ref res 1) ;;; YES!! THIS IS CORRECT!! CHANGE IT HERE, THEN CHANGE rmt:send-receive ALSO!!!
	#f)))

;;======================================================================
462
463
464
465
466
467
468
469

470
471
472
473
474
475
476
470
471
472
473
474
475
476

477
478
479
480
481
482
483
484







-
+








(define (rmt:login run-id)
  (rmt:send-receive 'login run-id (list *toppath* megatest-version (client:get-signature))))

;; This login does no retries under the hood - it acts a bit like a ping.
;; Deprecated for nmsg-transport.
;;
(define (rmt:login-no-auto-client-setup runremote)
#;(define (rmt:login-no-auto-client-setup runremote)
  (rmt:send-receive-no-auto-client-setup runremote 'login 0 (list *toppath* megatest-version (client:get-signature))))

;; hand off a call to one of the db:queries statements
;; added run-id to make looking up the correct db possible 
;;
(define (rmt:general-call stmtname run-id . params)
  (rmt:send-receive 'general-call run-id (append (list stmtname run-id) params)))
569
570
571
572
573
574
575
576

577
578
579
580
581
582
583
577
578
579
580
581
582
583

584
585
586
587
588
589
590
591







-
+







	(debug:print 0 *default-log-port* "WARNING: Bad data handed to rmt:get-test-info-by-id run-id=" run-id ", test-id=" test-id)
	(print-call-chain (current-error-port))
	#f)))

(define (rmt:test-get-rundir-from-test-id run-id test-id)
  (rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))

(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
#;(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
  (assert (number? run-id) "FATAL: Run id required.")
  (let* ((test-path (if (string? work-area)
			work-area
			(rmt:test-get-rundir-from-test-id run-id test-id))))
    (debug:print 3 *default-log-port* "TEST PATH: " test-path)
    (open-test-db test-path)))

925
926
927
928
929
930
931
932
933


934
935
936
937
938
939
940
933
934
935
936
937
938
939


940
941
942
943
944
945
946
947
948







-
-
+
+







;;  2. Continue as above
;; 
;;(define (rmt:get-steps-for-test run-id test-id)
;;  (rmt:send-receive 'get-steps-data run-id (list test-id)))

(define (rmt:teststep-set-status! run-id test-id teststep-name state-in status-in comment logfile)
  (assert (number? run-id) "FATAL: Run id required.")
  (let* ((state     (items:check-valid-items "state" state-in))
	 (status    (items:check-valid-items "status" status-in)))
  (let* ((state     state-in)   ;; (items:check-valid-items "state" state-in))
	 (status    status-in)) ;; (items:check-valid-items "status" status-in)))
    (if (or (not state)(not status))
	(debug:print 3 *default-log-port* "WARNING: Invalid " (if status "status" "state")
		     " value \"" (if status state-in status-in) "\", update your validvalues section in megatest.config"))
    (rmt:send-receive 'teststep-set-status! run-id (list run-id test-id teststep-name state-in status-in comment logfile))))


(define (rmt:delete-steps-for-test! run-id test-id)
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
































































1104
1105
1041
1042
1043
1044
1045
1046
1047
































































1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


(define (rmt:test-set-archive-block-id run-id test-id archive-block-id)
  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))

(define (rmt:test-get-archive-block-info archive-block-id)
  (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))


(define (rmtmod:calc-ro-mode runremote *toppath*)
  (if (and runremote
	   (remote-ro-mode-checked runremote))
      (remote-ro-mode runremote)
      (let* ((mtcfgfile  (conc *toppath* "/megatest.config"))
	     (ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
	(if runremote
	    (begin
	      (remote-ro-mode-set! runremote ro-mode)
	      (remote-ro-mode-checked-set! runremote #t)
	      ro-mode)
	    ro-mode))))

(define (extras-readonly-mode rmt-mutex log-port cmd params)
  (mutex-unlock! rmt-mutex)
  (debug:print-info 12 log-port "rmt:send-receive, case 3")
  (debug:print 0 log-port "WARNING: write transaction requested on a readonly area.  cmd="cmd" params="params)
  #f)

(define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
  (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
  (mutex-lock! *rmt-mutex*)
  (http-transport:close-connections runremote)
  (remote-server-url-set! runremote #f)
  (mutex-unlock! *rmt-mutex*)
  (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9.1")
  (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
  
(define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
  (if (and (vector? res)
	   (eq? (vector-length res) 2)
	   (eq? (vector-ref res 1) 'overloaded)) ;; since we are
						 ;; looking at the
						 ;; data to carry the
						 ;; error we'll use a
						 ;; fairly obtuse
						 ;; combo to minimise
						 ;; the chances of
						 ;; some sort of
						 ;; collision.  this
						 ;; is the case where
						 ;; the returned data
						 ;; is bad or the
						 ;; server is
						 ;; overloaded and we
						 ;; want to ease off
						 ;; the queries
      (let ((wait-delay (+ attemptnum (* attemptnum 10))))
	(debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
	(mutex-lock! *rmt-mutex*)
	(http-transport:close-connections runremote)
	(set! *runremote* #f) ;; force starting over
	(mutex-unlock! *rmt-mutex*)
	(thread-sleep! wait-delay)
	(rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
      res)) ;; All good, return res

#;(set-functions rmt:send-receive                       remote-server-url-set!
	       http-transport:close-connections	      remote-conndat-set!
	       debug:print                            debug:print-info
	       remote-ro-mode                         remote-ro-mode-set!
	       remote-ro-mode-checked-set!            remote-ro-mode-checked)

;; 
;; (define (rmtmod:calc-ro-mode runremote *toppath*)
;;   (if (and runremote
;; 	   (remote-ro-mode-checked runremote))
;;       (remote-ro-mode runremote)
;;       (let* ((mtcfgfile  (conc *toppath* "/megatest.config"))
;; 	     (ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
;; 	(if runremote
;; 	    (begin
;; 	      (remote-ro-mode-set! runremote ro-mode)
;; 	      (remote-ro-mode-checked-set! runremote #t)
;; 	      ro-mode)
;; 	    ro-mode))))
;; 
;; (define (extras-readonly-mode rmt-mutex log-port cmd params)
;;   (mutex-unlock! rmt-mutex)
;;   (debug:print-info 12 log-port "rmt:send-receive, case 3")
;;   (debug:print 0 log-port "WARNING: write transaction requested on a readonly area.  cmd="cmd" params="params)
;;   #f)
;; 
;; (define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
;;   (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
;;   (mutex-lock! *rmt-mutex*)
;;   (http-transport:close-connections runremote)
;;   (remote-server-url-set! runremote #f)
;;   (mutex-unlock! *rmt-mutex*)
;;   (debug:print-info 12 *default-log-port* "rmt:send-receive, case  9.1")
;;   (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
;;   
;; (define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
;;   (if (and (vector? res)
;; 	   (eq? (vector-length res) 2)
;; 	   (eq? (vector-ref res 1) 'overloaded)) ;; since we are
;; 						 ;; looking at the
;; 						 ;; data to carry the
;; 						 ;; error we'll use a
;; 						 ;; fairly obtuse
;; 						 ;; combo to minimise
;; 						 ;; the chances of
;; 						 ;; some sort of
;; 						 ;; collision.  this
;; 						 ;; is the case where
;; 						 ;; the returned data
;; 						 ;; is bad or the
;; 						 ;; server is
;; 						 ;; overloaded and we
;; 						 ;; want to ease off
;; 						 ;; the queries
;;       (let ((wait-delay (+ attemptnum (* attemptnum 10))))
;; 	(debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
;; 	(mutex-lock! *rmt-mutex*)
;; 	(http-transport:close-connections runremote)
;; 	(set! *runremote* #f) ;; force starting over
;; 	(mutex-unlock! *rmt-mutex*)
;; 	(thread-sleep! wait-delay)
;; 	(rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
;;       res)) ;; All good, return res
;; 
;; #;(set-functions rmt:send-receive                       remote-server-url-set!
;; 	       http-transport:close-connections	      remote-conndat-set!
;; 	       debug:print                            debug:print-info
;; 	       remote-ro-mode                         remote-ro-mode-set!
;; 	       remote-ro-mode-checked-set!            remote-ro-mode-checked)
;; 
	
)

Modified runconfig.scm from [66b9c38588] to [6913a95308].

16
17
18
19
20
21
22
23
24
25
26




27
28
29
30
31
32
33
16
17
18
19
20
21
22


23
24
25
26
27
28
29
30
31
32
33
34
35







-
-


+
+
+
+







;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================

(use format directory-utils)

(declare (unit runconfig))
(declare (uses common))
(declare (uses debugprint))

(use format directory-utils)
(import debugprint)

(include "common_records.scm")

(define (runconfig:read fname target environ-patt)
  (let ((ht (make-hash-table)))
    (if target (hash-table-set! ht target '()))
    (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f))))

Modified runs.scm from [292b302d70] to [db1439c273].

27
28
29
30
31
32
33

34
35
36
37
38
39
40

41
42
43
44
45
46
47
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49







+







+







(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses servermod))
(declare (uses mt))
(declare (uses archive))
;; (declare (uses filedb))
(declare (uses debugprint))

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")

(import debugprint)
;; (include "debugger.scm")

;; use this struct to facilitate refactoring
;;

(defstruct runs:dat
  reglen regfull

Modified servermod.scm from [ed8ceb5dcd] to [b3e225a5e9].

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
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







+




















+







;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.
;;======================================================================

(declare (unit servermod))
(declare (uses artifacts))
(declare (uses debugprint))

(use md5 message-digest posix typed-records extras)

(module servermod
*

(import scheme
	chicken

	extras
	md5
	message-digest
	ports
	posix
	srfi-18

	typed-records
	data-structures

	artifacts
	debugprint
	)

(defstruct srv
  (areapath #f)
  (host     #f)
  (pid      #f)
  (type     #f)

Modified subrun.scm from [8e4ec606e5] to [68aa532b1d].

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
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







-
-
-











+
+
+
+
+
+
+







;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;  strftime('%m/%d/%Y %H:%M:%S','now','localtime')

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format
     call-with-environment-variables)
(declare (unit subrun))
;;(declare (uses 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 filedb))
(declare (uses debugprint))

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format
     call-with-environment-variables)

(import debugprint)

;(include "common_records.scm")
;;(include "key_records.scm")
(include "db_records.scm") ;; provides db:test-get-id
;;(include "run_records.scm")
;;(include "test_records.scm")

Modified tasks.scm from [abd648b927] to [3a4630abf8].

23
24
25
26
27
28
29

30
31



32
33
34
35
36
37
38
39
40
41
23
24
25
26
27
28
29
30
31

32
33
34
35
36

37
38
39
40
41
42
43







+

-
+
+
+


-








(declare (unit tasks))
(declare (uses dbfile))
(declare (uses db))
(declare (uses rmtmod))
(declare (uses common))
(declare (uses pgdb))
(declare (uses debugprint))

(import dbfile)
(import dbfile
	debugprint
	)
;; (import pgdb) ;; pgdb is a module

(include "task_records.scm")
(include "db_records.scm")

;;======================================================================
;; Tasks db
;;======================================================================

;; wait up to aprox n seconds for a journal to go away

Modified tdb.scm from [d3b22aeea7] to [c43cba4b5d].

30
31
32
33
34
35
36

37
38
39
40
41


42
43
44
45
46
47
48
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51







+





+
+







(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses clientmod))
(declare (uses mt))
(declare (uses db))
(declare (uses debugprint))

(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")

(import debugprint)

;;======================================================================
;;
;; T E S T   D A T A B A S E S
;;
;;======================================================================

Modified tests.scm from [d338c8419d] to [cbdf45c29c].

30
31
32
33
34
35
36



37
38
39
40
41
42
43
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46







+
+
+







(declare (uses commonmod))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses servermod))
;;(declare (uses stml2))
(declare (uses debugprint))

(import debugprint)

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(import commonmod)
(require-library stml)

(include "common_records.scm")

Modified tree.scm from [0e8e68fe0a] to [018afa4bfc].

31
32
33
34
35
36
37

38
39
40
41
42


43
44
45
46
47
48
49
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52







+





+
+







(declare (uses launch))
;; (declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
;; (declare (uses server))
;; (declare (uses synchash))
(declare (uses dcommon))
(declare (uses debugprint))

(include "megatest-version.scm")
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")

(import debugprint)

;;======================================================================
;; T R E E   S T U F F 
;;======================================================================

;; path is a list of nodes, each the child of the previous
;; this routine returns the id so another node can be added