Megatest

Changes On Branch b969852101bbddb2
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Hide Diff Patch Side-by-Side Diff

Changes In Branch v1.90-proper-interface-lists Through [b969852101] Excluding Merge-Ins

This is equivalent to a diff from cee15a9d94 to b969852101

2024-02-12
16:00
wip check-in: 5d85b42870 user: mrwellan tags: v1.90-proper-interface-lists
15:42
repl runs check-in: b969852101 user: mrwellan tags: v1.90-proper-interface-lists
14:31
wip, compiles check-in: bbdb404874 user: mrwellan tags: v1.90-proper-interface-lists
2024-02-11
19:49
convert to use proper interface lists check-in: bbac9c3682 user: matt tags: v1.90-proper-interface-lists
18:19
Adding uses of .import files back Leaf check-in: cee15a9d94 user: matt tags: v1.90-fix-modes
16:41
Moved remainder of configf into configfmod check-in: c2d750aad9 user: matt tags: v1.90-fix-modes

Modified Makefile from [28690e5571] to [d30fa8d10d].

︙
24
25
26
27
28
29
30
31

32
33
34
35
36
37
38

24
25
26
27
28
29
30

31
32
33
34
35
36
37
38








-
+








	fossil timeline -n 350 -t ci -F "%h,%a,%b,%t,\"%c\"" > recent-commits.csv


SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm launch.scm runconfig.scm	\
SRCFILES = launch.scm runconfig.scm	\
           server.scm configf.scm keys.scm		\
           process.scm runs.scm genexample.scm	\
           tdb.scm mt.scm	\
           ezsteps.scm api.scm		\
           subrun.scm archive.scm env.scm		\
           diff-report.scm
︙

Modified apimod.scm from [c5b4d2905e] to [49fb14301c].

︙
23
24
25
26
27
28
29
30



31
32
33
34
35
36
37

23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39








-
+
+
+








(declare (uses debugprint))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tcp-transportmod))
(declare (uses megatestmod))

(module apimod
	*
	(
	 api:dispatch-request
	 )
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix matchable typed-records srfi-1 srfi-18 srfi-69 )
(import commonmod)
(import debugprint)
(import dbmod)
(import dbfile)
︙

Modified archive.scm from [3972290090] to [e534969391].

︙
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








-
+








;;

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

(declare (unit archive))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses common))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))

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

Modified archivemod.scm from [ddced4be70] to [5b21746964].

︙
35
36
37
38
39
40
41






42



43
44
45
46
47
48
49

35
36
37
38
39
40
41
42
43
44
45
46
47

48
49
50
51
52
53
54
55
56
57








+
+
+
+
+
+
-
+
+
+








(declare (uses mtmod))
(declare (uses dbmod))
(declare (uses dbfile))

(use srfi-69)

(module archivemod
	(
	 archive:get-archive-disks
	 archive:allocate-new-archive-block
	 archive:get-timestamp-dir
	 archive:megatest-db
	 archive:bup-get-data
	*


	 )

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports
︙
119
120
121
122
123
124
125
126

127
128
129
130
131
132
133

127
128
129
130
131
132
133

134
135
136
137
138
139
140
141








-
+








	srfi-13
	srfi-18
	srfi-69
	typed-records
	z3
	)
	
(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")

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

;; ;; NOT CURRENTLY USED
︙

Added attic/codescanlib.scm version [6e625610ce]. 


















































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

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

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     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/>.
;;

;; gotta compile with csc, doesn't work with csi -s for whatever reason

(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()
   (with-input-from-string
       (conc "("
             (with-input-from-file scm-file read-all)
             ")" )
     read)))

;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
;;   -- be advised:
;;      * this may be fooled by macros, since this code does not take them into account.
;;      * this code does only checks for form (define (<procname> ... ) <body>)
;;           so it excludes from reckoning
;;               - generated functions, as in things like foo-set! from defstructs,
;;               - define-inline, (
;;               - define procname (lambda ..
;;               - etc...
(define (get-toplevel-procs+file+args+body filename)
  (let* ((scm-tree (load-scm-file filename))
         (procs
          (filter identity
                  (map
                   (match-lambda 
                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
                         (list defname filename args body)
                         #f)]
                    [else #f] ) scm-tree))))
    procs))


;; given a sexp, return a flat list of atoms in that sexp
(define (get-atoms-in-body body)
  (cond
   ((null? body) '())
   ((atom? body) (list body))
   (else
    (apply append (map get-atoms-in-body body)))))

;;  given a file, return a list of procname, file, list of atoms in said procname
(define (get-procs+file+atoms file)
  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
         (res
          (map
           (lambda (item)
             (let* ((proc (car item))
                    (file (cadr item))
                    (args (caddr item))
                    (body (cadddr item))
                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
               (list proc file atoms)))
           toplevel-proc-items)))
    res))

;; uniquify a list of atoms 
(define (unique-atoms lst)
  (let loop ((lst (flatten lst)) (res '()))
    (if (null? lst)
        (reverse res)
        (let ((c (car lst)))
          (loop (cdr lst) (if (member c res) res (cons c res)))))))

;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
;; returning alist mapping procname to procname that calls said procname
(define (get-callers-alist all-procs+file+calls)
  (let* ((all-procs (map car all-procs+file+calls))
         (caller-ht (make-hash-table))) 
    ;; let's cross reference with a hash table
    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
    (for-each (lambda (item)
               (let* ((proc (car item))
                      (file (cadr item))
                      (calls (caddr item)))
                 (for-each (lambda (callee)
                             (hash-table-set! caller-ht callee
                                              (cons proc
                                                    (hash-table-ref caller-ht callee))))
                           calls)))
              all-procs+file+calls)
    (map (lambda (x)
           (let ((k (car x))
                 (r (unique-atoms (cdr x))))
             (cons k r)))                    
         (hash-table->alist caller-ht))))

;; create a handy cross-reference of callees to callers in the form of an alist.
(define (get-xref all-scm-files)
  (let* ((all-procs+file+atoms
          (apply append (map get-procs+file+atoms all-scm-files)))
         (all-procs (map car all-procs+file+atoms))
         (all-procs+file+calls  ; proc calls things in calls list
          (map (lambda (item)
                 (let* ((proc (car item))
                        (file (cadr item))
                        (atoms (caddr item))
                        (calls
                         (filter identity
                                 (map
                                  (lambda (x)
                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
                                         (member x all-procs))
                                        x
                                        #f))
                                  atoms))))
                   (list proc file calls)))
               all-procs+file+atoms))
         (callers (get-callers-alist all-procs+file+calls))) 
    callers))








Deleted codescanlib.scm version [6e625610ce].



1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144


















































































































































-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

;;  Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     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/>.
;;

;; gotta compile with csc, doesn't work with csi -s for whatever reason

(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)

;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
(define (load-scm-file scm-file)
  ;;(print "load "scm-file)
  (handle-exceptions
   exn
   '()
   (with-input-from-string
       (conc "("
             (with-input-from-file scm-file read-all)
             ")" )
     read)))

;; extract a list of procname, filename, args and body of procedures defined in filename, input from load-scm-file
;;   -- be advised:
;;      * this may be fooled by macros, since this code does not take them into account.
;;      * this code does only checks for form (define (<procname> ... ) <body>)
;;           so it excludes from reckoning
;;               - generated functions, as in things like foo-set! from defstructs,
;;               - define-inline, (
;;               - define procname (lambda ..
;;               - etc...
(define (get-toplevel-procs+file+args+body filename)
  (let* ((scm-tree (load-scm-file filename))
         (procs
          (filter identity
                  (map
                   (match-lambda 
                    [('define ('uses args ...) body ...) #f] ;; filter out (define (uses ...
                    [('define ('unit args ...) body ...) #f] ;; filter out (define (unit ...
                    [('define ('prefix args ...) body ...) #f] ;; filter out (define (prefix ...
                    [('define (defname args ...) body ...) ;; match (define (procname <args>) <body>)
                     (if (atom? defname) ;; filter out things we dont understand (procname is a list, what??)
                         (list defname filename args body)
                         #f)]
                    [else #f] ) scm-tree))))
    procs))


;; given a sexp, return a flat list of atoms in that sexp
(define (get-atoms-in-body body)
  (cond
   ((null? body) '())
   ((atom? body) (list body))
   (else
    (apply append (map get-atoms-in-body body)))))

;;  given a file, return a list of procname, file, list of atoms in said procname
(define (get-procs+file+atoms file)
  (let* ((toplevel-proc-items (get-toplevel-procs+file+args+body file))
         (res
          (map
           (lambda (item)
             (let* ((proc (car item))
                    (file (cadr item))
                    (args (caddr item))
                    (body (cadddr item))
                    (atoms (append (get-atoms-in-body args) (get-atoms-in-body body))))
               (list proc file atoms)))
           toplevel-proc-items)))
    res))

;; uniquify a list of atoms 
(define (unique-atoms lst)
  (let loop ((lst (flatten lst)) (res '()))
    (if (null? lst)
        (reverse res)
        (let ((c (car lst)))
          (loop (cdr lst) (if (member c res) res (cons c res)))))))

;; given a list of procname, filename, list of procs called from procname, cross reference and reverse
;; returning alist mapping procname to procname that calls said procname
(define (get-callers-alist all-procs+file+calls)
  (let* ((all-procs (map car all-procs+file+calls))
         (caller-ht (make-hash-table))) 
    ;; let's cross reference with a hash table
    (for-each (lambda (proc) (hash-table-set! caller-ht proc '())) all-procs)
    (for-each (lambda (item)
               (let* ((proc (car item))
                      (file (cadr item))
                      (calls (caddr item)))
                 (for-each (lambda (callee)
                             (hash-table-set! caller-ht callee
                                              (cons proc
                                                    (hash-table-ref caller-ht callee))))
                           calls)))
              all-procs+file+calls)
    (map (lambda (x)
           (let ((k (car x))
                 (r (unique-atoms (cdr x))))
             (cons k r)))                    
         (hash-table->alist caller-ht))))

;; create a handy cross-reference of callees to callers in the form of an alist.
(define (get-xref all-scm-files)
  (let* ((all-procs+file+atoms
          (apply append (map get-procs+file+atoms all-scm-files)))
         (all-procs (map car all-procs+file+atoms))
         (all-procs+file+calls  ; proc calls things in calls list
          (map (lambda (item)
                 (let* ((proc (car item))
                        (file (cadr item))
                        (atoms (caddr item))
                        (calls
                         (filter identity
                                 (map
                                  (lambda (x)
                                    (if (and ;; (not (equal? x proc))  ;; uncomment to prevent listing self
                                         (member x all-procs))
                                        x
                                        #f))
                                  atoms))))
                   (list proc file calls)))
               all-procs+file+atoms))
         (callers (get-callers-alist all-procs+file+calls))) 
    callers))








Deleted common.scm version [58be7ce4cf].



1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117























































































































-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     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/>.

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

(declare (unit common))
(declare (uses commonmod))
(declare (uses processmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(declare (uses debugprint))
(declare (uses mtargs))
        

(use srfi-1 data-structures posix regex-case (prefix base64 base64:)
     format dot-locking csv-xml z3 udp ;; sql-de-lite
     hostinfo md5 message-digest typed-records directory-utils stack
     matchable regex posix (srfi 18) extras ;; tcp 
     (prefix nanomsg nmsg:)
     (prefix sqlite3 sqlite3:)
     pkts (prefix dbi dbi:)
     )
(use posix-extras pathname-expand files)


(import commonmod
	processmod
	debugprint
	configfmod
	rmtmod
	(prefix mtargs args:))

(include "common_records.scm")





;;======================================================================
;; (define *common:telemetry-log-state* 'startup)
;; (define *common:telemetry-log-socket* #f)
;; 
;; (define (common:telemetry-log-open)
;;   (if (eq? *common:telemetry-log-state* 'startup)
;;       (let* ((serverhost (configf:lookup *configdat* "telemetry" "host"))
;;              (serverport (configf:lookup-number *configdat* "telemetry" "port"))
;;              (user (or (get-environment-variable "USER") "unknown"))
;;              (host (or (get-environment-variable "HOST") "unknown")))
;;         (set! *common:telemetry-log-state*
;;               (handle-exceptions
;;                exn
;;                (begin
;;                  (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure")
;;                  'broken)
;;                (if (and serverhost serverport user host)
;;                    (let* ((s (udp-open-socket)))
;;                      ;;(udp-bind! s #f 0)
;;                      (udp-connect! s serverhost serverport)
;;                      (set! *common:telemetry-log-socket* s)
;;                      'open)
;;                    'not-needed))))))
;;   
;; (define (common:telemetry-log event #!key (payload '()))
;;   (if (eq? *common:telemetry-log-state* 'startup)
;;       (common:telemetry-log-open))
;; 
;;   (if (eq? 'open *common:telemetry-log-state*)
;;       (handle-exceptions
;;        exn
;;        (begin
;;          (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)")
;;          ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose)
;;          ;;(common:telemetry-log-close)
;;          (define *common:telemetry-log-state* 'broken-or-no-server)
;;          (set! *common:telemetry-log-socket* #f)
;;          )
;;        (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events
;;            (let* ((user (or (get-environment-variable "USER") "unknown"))
;;                   (host (or (get-environment-variable "HOST") "unknown"))
;;                   (start (conc "[megatest "event"]"))
;;                   (toppath (or *toppath* "/dev/null"))
;;                   (payload-serialized
;;                    (base64:base64-encode
;;                     (z3:encode-buffer
;;                      (with-output-to-string (lambda () (pp payload))))))
;;                   (msg     (conc user":"host":"start":"(current-process-id)":"(car (argv))":"
;;                                  toppath":"payload-serialized)))
;;              (udp-send *common:telemetry-log-socket* msg))))))
;;   
;; (define (common:telemetry-log-close)
;;   (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*)
;;     (handle-exceptions
;;      exn
;;      (begin
;;        (define *common:telemetry-log-state* 'closed-fail)
;;        (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure")
;;        )
;;      (begin
;;        (define *common:telemetry-log-state* 'closed)
;;        (udp-close-socket *common:telemetry-log-socket*)
;;        (set! *common:telemetry-log-socket* #f)))))









Modified commonmod.scm
from [5100c657f0]
to [3dbddd7962].




︙


48
49
50
51
52
53
54







55







56




































































































































































































































57
58
59
60
61
62
63

48
49
50
51
52
53
54
55
56
57
58
59
60
61

62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304








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

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








     typed-records
     z3)

(import stml2
	)

(module commonmod
	(
	 keys->valslots
	 item-list->path
	 common:human-time
	 number-of-processes-running
	 get-normalized-cpu-load
	 common:find-local-megatest
	*

	 common:get-intercept
	 common:get-num-cpus
	 common:get-cpu-load
	 common:hms-string->seconds
	 seconds->time-string
	 common:get-megatest-exe

	 megatest-version
	 common:get-toppath
	 common:generic-ssh
	 common:file-exists?
	 common:with-env-vars
	 common:nice-path
	 common:get-fields

	 common:get-normalized-cpu-load
	 common:unix-ping
	 common:get-normalized-cpu-load

	 ;; globals
	 *common:badly-ended-states*
	 *common:dont-roll-up-states*
	 *common:ended-states*
	 *common:not-started-ok-statuses*
	 *common:running-states*
	 *common:std-states*
	 *common:std-statuses*
	 *common:well-ended-states*
	 *configdat*
	 *configinfo*
	 *db-access-allowed*
	 *db-api-call-time*
	 *db-cache-path*
	 *db-keys*
	 *default-area-tag*
	 *host-loads*
	 *keyvals*
	 *logged-in-clients*
	 *my-client-signature*
	 *on-exit-procs*
	 *pkts-info*
	 *pre-reqs-met-cache*
	 *runremote*
	 *server-id*
	 *server-info*
	 *target*
	 *task-db*
	 *testconfigs*
	 *time-to-exit*
	 *toppath*
	 *transport-type*
	 
	 any->number-if-possible

	 common:special-sort
	 keys:target-set-args

	 getenv
	 setenv
	 safe-setenv

	 commonmod:get-cpu-load

	 get-area-path-signature
	 common:simple-file-lock
	 common:low-noise-print
	 common:get-create-writeable-dir
	 common:real-path
	 val->alist

	 client:get-signature

	 common:get-color-from-status
	 
	 seconds->year-work-week/day-time
	 common:simple-file-release-lock
	 common:simple-file-lock-and-wait
	 tests:lookup-itemmap

	 tests:match->sqlqry
	 runs:get-std-run-fields
	 common:min-max
	 common:max
	 common:sum
	 keys:target->keyval
	 db:patt->like

	 rmt:transport-mode
	 common:version-signature

	 keys->keystr
	 keys:config-get-fields
	 common:make-tmpdir-name

	 db:test-get-status
	 db:test-get-state
	 db:test-get-event_time
	 db:test-get-item-path
	 db:test-get-testname
	 db:test-get-id
	 db:test-get-comment
	 db:test-get-run_duration
	 db:test-get-rundir

	 tests:match
	 patt-list-match
	 common:pkts-spec

	 sdb:qry
	 seconds->work-week/day-time

	 tdb:step-get-comment
	 seconds->hr-min-sec
	 any->number
	 tdb:step-get-logfile
	 tdb:step-get-event_time
	 tdb:step-get-status
	 tdb:step-get-state
	 tdb:step-get-id
	 tdb:step-get-stepname
	 db:test-make-full-name
	 common:htree->html
	 common:list->htree

	 tdb:steps-table-get-log-file
	 tdb:steps-table-get-runtime
	 tdb:steps-table-get-status
	 tdb:steps-table-get-end
	 tdb:steps-table-get-start
	 tdb:steps-table-get-stepname
	 tdb:step-get-last_update
	 tdb:step-get-test_id

	 db:test-get-run_id
	 db:test-get-final_logf

	 tests:testqueue-get-item_path
	 tests:testqueue-get-itemdat
	 tests:testqueue-get-testname
	 tests:testqueue-get-priority
	 tests:testqueue-set-priority!
	 tests:testqueue-get-testconfig
	 tests:testqueue-get-waitons

	 tasks:wait-on-journal
	 common:get-area-path-signature

	 db:test-get-last_update
	 db:test-get-archived
	 db:test-get-uname
	 db:test-get-diskfree
	 db:test-get-cpuload
	 db:test-get-process_id
	 db:test-get-host
	 db:test-data-get-last_update
	 db:test-data-get-type
	 db:test-data-get-status
	 db:test-data-get-comment
	 db:test-data-get-units
	 db:test-data-get-tol
	 db:test-data-get-expected
	 db:test-data-get-value
	 db:test-data-get-variable
	 db:test-data-get-category
	 db:test-data-get-test_id
	 db:test-data-get-id

	 host-last-cpuload
	 host-last-update
	 host-last-cpuload-set!
	 host-last-update-set!
	 host-reachable-set!
	 make-host
	 host-last-used-set!
	 host-reachable
	 host-last-used

	 common:alist-ref/default
	 common:val->alist
	 common:in-running-test?
	 
	 common:without-vars
	 common:get-megatest-exe-path
	 common:get-megatest-exe-dir
	 common:get-param-mapping
	 common:get-mtexe
	 
	 db:test-get-is-toplevel
	 seconds->quarter
	 *globalexitstatus*

	 tests:testqueue-set-items!
	 tests:testqueue-get-items
	 *runconfigdat*
	 *passnum*
	 *already-seen-runconfig-info*
	 common:directory-writable?
	 common:dir-clean-up
	 common:fail-safe
	 common:list-or-null
	 *toptest-paths*
	 common:directory-exists?
	 *configstatus*
	 *last-launch*
	 *launch-setup-mutex*
	 commonmod:is-test-alive
	 alist->env-vars
	 *env-vars-by-run-id*
	 common:get-signature
	 common:join-backgrounded-threads
	 tests:glob-like-match
	 common:send-thunk-to-background-thread
	 db:test-get-fullname
	 common:clear-caches
	 db:mintest-get-event_time
	 *test-meta-updated*
	 tests:testqueue-set-item_path!
	 tests:testqueue-set-itemdat!
	 make-tests:testqueue

	 megatest-fossil-hash

	 common:steps-can-proceed-given-status-sym
	 status-sym->string
	 common:worse-status-sym
	 common:logpro-exit-code->status-sym

	 save-environment-as-files
	 assoc/default
	 common:read-encoded-string
	 common:which

	 stop-the-train
	 )
	
(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports
	  (prefix base64 base64:)




︙


118
119
120
121
122
123
124


125
126
127
128
129
130
131

359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374








+
+








	  srfi-1
	  srfi-18
	  srfi-69
	  typed-records
	  system-information

	  debugprint
	  megatest-fossil-hash
	  
  )))

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions




︙


383
384
385
386
387
388
389

390
391
392
393
394
395
396

626
627
628
629
630
631
632
633
634
635
636
637
638
639
640








+








(define *fdb* #f)

(define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state.

;; environment vars handy stuff from common.scm
;;
(define getenv get-environment-variable)

(define (safe-setenv key val)
  (if (or (substring-index "!" key)
	  (substring-index ":" key)  ;; variables containing : are for internal use and cannot be environment variables.
	  (substring-index "." key)) ;; periods are not allowed in environment variables
      (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"")
      (if (and (string? val)
	       (string? key))




︙


561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577

805
806
807
808
809
810
811



812
813
814
815
816
817
818








-
-
-








  ;; convert string a=1; b=2; c=a silly thing; d=
  (let ((valstr (lookup cfgdat section var)))
    (if valstr
	(val->alist valstr)
	'()))) ;; should it return empty list or #f to indicate not set?


(define (get-section cfgdat section)
  (hash-table-ref/default cfgdat section '()))

(define (common:make-tmpdir-name areapath tmpadj)
  (let* ((area (pathname-file areapath))
         (dname (conc "/tmp/"(current-user-name)"/megatest_localdb/" area "/" (string-translate areapath "/" ".") tmpadj "/.mtdb")))
    (unless (directory-exists? dname)
      (create-directory dname #t))
    dname))





︙


2734
2735
2736
2737
2738
2739
2740



2741



2742




















2743




































































































































































































2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009

3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
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
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204








+
+
+

+
+
+

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


(define (common:get-fields cfgdat)
  (let ((fields (hash-table-ref/default cfgdat "fields" '())))
    (map car fields)))

(define keys:config-get-fields common:get-fields)

;;======================================================================
;; db_records.scm
;;======================================================================

;;======================================================================
;; dbstruct
;;======================================================================

(define (make-db:test)(make-vector 20))
(define (db:test-get-id           vec) (vector-ref vec 0))
(define (db:test-get-run_id       vec) (vector-ref vec 1))
(define (db:test-get-testname     vec) (vector-ref vec 2))
(define (db:test-get-state        vec) (vector-ref vec 3))
(define (db:test-get-status       vec) (vector-ref vec 4))
(define (db:test-get-event_time   vec) (vector-ref vec 5))
(define (db:test-get-host         vec) (vector-ref vec 6))
(define (db:test-get-cpuload      vec) (vector-ref vec 7))
(define (db:test-get-diskfree     vec) (vector-ref vec 8))
(define (db:test-get-uname        vec) (vector-ref vec 9))
;; (define (db:test-get-rundir       vec) (sdb:qry 'getstr (vector-ref vec 10)))
(define (db:test-get-rundir       vec) (vector-ref vec 10))
(define (db:test-get-item-path    vec) (vector-ref vec 11))
(define (db:test-get-run_duration vec) (vector-ref vec 12))
(define (db:test-get-final_logf   vec) (vector-ref vec 13))
(define (db:test-get-comment      vec) (vector-ref vec 14))
(define (db:test-get-process_id   vec) (vector-ref vec 16))
(define (db:test-get-archived     vec) (vector-ref vec 17))
(define (db:test-get-last_update     vec) (vector-ref vec 18))
)

;; (define (db:test-get-pass_count   vec) (vector-ref vec 15))
;; (define (db:test-get-fail_count   vec) (vector-ref vec 16))
(define (db:test-get-fullname     vec)
  (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))

;; replace runs:make-full-test-name with this routine
(define (db:test-make-full-name testname itempath)
  (if (equal? itempath "") testname (conc testname "/" itempath)))

;; (define (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
;; (define (db:test-get-first_warn   vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated

(define (db:test-set-cpuload!  vec val)(vector-set! vec 7 val))
(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define (db:test-set-state!    vec val)(vector-set! vec 3 val))
(define (db:test-set-status!   vec val)(vector-set! vec 4 val))
(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))

;; Test record utility functions

;; Is a test a toplevel?
;;
(define (db:test-get-is-toplevel vec)
  (and (equal? (db:test-get-item-path vec) "")      ;; test is not an item
       (equal? (db:test-get-uname vec)     "n/a"))) ;; test has never been run

;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;; RADT => purpose of mintest??
;;
(define (make-db:mintest)(make-vector 7))
(define (db:mintest-get-id           vec)    (vector-ref  vec 0))
(define (db:mintest-get-run_id       vec)    (vector-ref  vec 1))
(define (db:mintest-get-testname     vec)    (vector-ref  vec 2))
(define (db:mintest-get-state        vec)    (vector-ref  vec 3))
(define (db:mintest-get-status       vec)    (vector-ref  vec 4))
(define (db:mintest-get-event_time   vec)    (vector-ref  vec 5))
(define (db:mintest-get-item_path    vec)    (vector-ref  vec 6))

;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
(define (make-db:testmeta)(make-vector 10 ""))
(define (db:testmeta-get-id            vec)    (vector-ref  vec 0))
(define (db:testmeta-get-testname      vec)    (vector-ref  vec 1))
(define (db:testmeta-get-author        vec)    (vector-ref  vec 2))
(define (db:testmeta-get-owner         vec)    (vector-ref  vec 3))
(define (db:testmeta-get-description   vec)    (vector-ref  vec 4))
(define (db:testmeta-get-reviewed      vec)    (vector-ref  vec 5))
(define (db:testmeta-get-iterated      vec)    (vector-ref  vec 6))
(define (db:testmeta-get-avg_runtime   vec)    (vector-ref  vec 7))
(define (db:testmeta-get-avg_disk      vec)    (vector-ref  vec 8))
(define (db:testmeta-get-tags          vec)    (vector-ref  vec 9))
(define (db:testmeta-set-id!           vec val)(vector-set! vec 0 val))
(define (db:testmeta-set-testname!     vec val)(vector-set! vec 1 val))
(define (db:testmeta-set-author!       vec val)(vector-set! vec 2 val))
(define (db:testmeta-set-owner!        vec val)(vector-set! vec 3 val))
(define (db:testmeta-set-description!  vec val)(vector-set! vec 4 val))
(define (db:testmeta-set-reviewed!     vec val)(vector-set! vec 5 val))
(define (db:testmeta-set-iterated!     vec val)(vector-set! vec 6 val))
(define (db:testmeta-set-avg_runtime!  vec val)(vector-set! vec 7 val))
(define (db:testmeta-set-avg_disk!     vec val)(vector-set! vec 8 val))

;;======================================================================
;; S I M P L E   R U N
;;======================================================================

;; (defstruct id  "runname" "state" "status" "owner" "event_time"

;;======================================================================
;; T E S T   D A T A 
;;======================================================================
(define (make-db:test-data)(make-vector 10))
(define (db:test-data-get-id               vec)    (vector-ref  vec 0))
(define (db:test-data-get-test_id          vec)    (vector-ref  vec 1))
(define (db:test-data-get-category         vec)    (vector-ref  vec 2))
(define (db:test-data-get-variable         vec)    (vector-ref  vec 3))
(define (db:test-data-get-value            vec)    (vector-ref  vec 4))
(define (db:test-data-get-expected         vec)    (vector-ref  vec 5))
(define (db:test-data-get-tol              vec)    (vector-ref  vec 6))
(define (db:test-data-get-units            vec)    (vector-ref  vec 7))
(define (db:test-data-get-comment          vec)    (vector-ref  vec 8))
(define (db:test-data-get-status           vec)    (vector-ref  vec 9))
(define (db:test-data-get-type             vec)    (vector-ref  vec 10))
(define (db:test-data-get-last_update      vec)    (vector-ref  vec 11))

(define (db:test-data-set-id!              vec val)(vector-set!  vec 0  val))
(define (db:test-data-set-test_id!         vec val)(vector-set!  vec 1  val))
(define (db:test-data-set-category!        vec val)(vector-set!  vec 2  val))
(define (db:test-data-set-variable!        vec val)(vector-set!  vec 3  val))
(define (db:test-data-set-value!           vec val)(vector-set!  vec 4  val))
(define (db:test-data-set-expected!        vec val)(vector-set!  vec 5  val))
(define (db:test-data-set-tol!             vec val)(vector-set!  vec 6  val))
(define (db:test-data-set-units!           vec val)(vector-set!  vec 7  val))
(define (db:test-data-set-comment!         vec val)(vector-set!  vec 8  val))
(define (db:test-data-set-status!          vec val)(vector-set!  vec 9  val))
(define (db:test-data-set-type!            vec val)(vector-set!  vec 10 val))

;;======================================================================
;; S T E P S 
;;======================================================================
;; Run steps
;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time    
(define (make-db:step)(make-vector 9))
(define (tdb:step-get-id              vec)    (vector-ref  vec 0))
(define (tdb:step-get-test_id         vec)    (vector-ref  vec 1))
(define (tdb:step-get-stepname        vec)    (vector-ref  vec 2))
(define (tdb:step-get-state           vec)    (vector-ref  vec 3))
(define (tdb:step-get-status          vec)    (vector-ref  vec 4))
(define (tdb:step-get-event_time      vec)    (vector-ref  vec 5))
(define (tdb:step-get-logfile         vec)    (vector-ref  vec 6))
(define (tdb:step-get-comment         vec)    (vector-ref  vec 7))
(define (tdb:step-get-last_update     vec)    (vector-ref  vec 8))
(define (tdb:step-set-id!             vec val)(vector-set! vec 0 val))
(define (tdb:step-set-test_id!        vec val)(vector-set! vec 1 val))
(define (tdb:step-set-stepname!       vec val)(vector-set! vec 2 val))
(define (tdb:step-set-state!          vec val)(vector-set! vec 3 val))
(define (tdb:step-set-status!         vec val)(vector-set! vec 4 val))
(define (tdb:step-set-event_time!     vec val)(vector-set! vec 5 val))
(define (tdb:step-set-logfile!        vec val)(vector-set! vec 6 val))
(define (tdb:step-set-comment!        vec val)(vector-set! vec 7 val))


;; The steps table
(define (make-db:steps-table)(make-vector 5))
(define (tdb:steps-table-get-stepname   vec)    (vector-ref  vec 0))
(define (tdb:steps-table-get-start      vec)    (vector-ref  vec 1))
(define (tdb:steps-table-get-end        vec)    (vector-ref  vec 2))
(define (tdb:steps-table-get-status     vec)    (vector-ref  vec 3))
(define (tdb:steps-table-get-runtime    vec)    (vector-ref  vec 4))
(define (tdb:steps-table-get-log-file   vec)    (vector-ref  vec 5))

(define (tdb:step-stable-set-stepname!  vec val)(vector-set! vec 0 val))
(define (tdb:step-stable-set-start!     vec val)(vector-set! vec 1 val))
(define (tdb:step-stable-set-end!       vec val)(vector-set! vec 2 val))
(define (tdb:step-stable-set-status!    vec val)(vector-set! vec 3 val))
(define (tdb:step-stable-set-runtime!   vec val)(vector-set! vec 4 val))

;; ;; The data structure for handing off requests via wire
;; (define (make-cdb:packet)(make-vector 6))
;; (define (cdb:packet-get-client-sig   vec)    (vector-ref  vec 0))
;; (define (cdb:packet-get-qtype        vec)    (vector-ref  vec 1))
;; (define (cdb:packet-get-immediate    vec)    (vector-ref  vec 2))
;; (define (cdb:packet-get-query-sig    vec)    (vector-ref  vec 3))
;; (define (cdb:packet-get-params       vec)    (vector-ref  vec 4))
;; (define (cdb:packet-get-qtime        vec)    (vector-ref  vec 5))
;; (define (cdb:packet-set-client-sig!  vec val)(vector-set! vec 0 val))
;; (define (cdb:packet-set-qtype!       vec val)(vector-set! vec 1 val))
;; (define (cdb:packet-set-immediate!   vec val)(vector-set! vec 2 val))
;; (define (cdb:packet-set-query-sig!   vec val)(vector-set! vec 3 val))
;; (define (cdb:packet-set-params!      vec val)(vector-set! vec 4 val))
;; (define (cdb:packet-set-qtime!       vec val)(vector-set! vec 5 val))

;;======================================================================
;; key_records
;;======================================================================

(define (keys->valslots keys) ;; => ?,?,? ....
  (string-intersperse (map (lambda (x) "?") keys) ","))

;; (define (keys->key/field keys . additional)
;;   (string-join (map (lambda (k)(conc k " TEXT"))
;; 		    (append keys additional)) ","))

(define (item-list->path itemdat)
  (if (list? itemdat)
      (string-intersperse  (map cadr itemdat) "/")
      ""))


;;======================================================================
;; test_records
;;======================================================================

;; make-vector-record tests testqueue testname testconfig waitons priority items
(define (make-tests:testqueue)(make-vector 7 #f))
(define (tests:testqueue-get-testname     vec)    (vector-ref  vec 0))
(define (tests:testqueue-get-testconfig   vec)    (vector-ref  vec 1))
(define (tests:testqueue-get-waitons      vec)    (vector-ref  vec 2))
(define (tests:testqueue-get-priority     vec)    (vector-ref  vec 3))
;; items: #f=no items, list=list of items remaining, proc=need to call to get items
(define (tests:testqueue-get-items        vec)    (vector-ref  vec 4))
(define (tests:testqueue-get-itemdat      vec)    (vector-ref  vec 5))
(define (tests:testqueue-get-item_path    vec)    (vector-ref  vec 6))

(define (tests:testqueue-set-testname!    vec val)(vector-set! vec 0 val))
(define (tests:testqueue-set-testconfig!  vec val)(vector-set! vec 1 val))
(define (tests:testqueue-set-waitons!     vec val)(vector-set! vec 2 val))
(define (tests:testqueue-set-priority!    vec val)(vector-set! vec 3 val))
(define (tests:testqueue-set-items!       vec val)(vector-set! vec 4 val))
(define (tests:testqueue-set-itemdat!     vec val)(vector-set! vec 5 val))
(define (tests:testqueue-set-item_path!   vec val)(vector-set! vec 6 val))


)








Modified configf.scm
from [59af4a3967]
to [912b217ff6].




︙


26
27
28
29
30
31
32
33

34
35
36
37
38
39
40

26
27
28
29
30
31
32

33
34
35
36
37
38
39
40








-
+








(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtargs.import))
(declare (uses common))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses processmod))
(declare (uses processmod.import))
(declare (uses configfmod))
(declare (uses configfmod.import))
(declare (uses dbfile))




︙







Modified configfmod.scm
from [8c4c9bcd5b]
to [a991ee4037].




︙


23
24
25
26
27
28
29













30











31
32
33
34
35
36
37

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








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








(declare (uses commonmod))
(declare (uses processmod))
(declare (uses mtargs))

(use regex regex-case)

(module configfmod
	(
	 lookup
	 configf:lookup
	 get-section
	 configf:get-section
	 configf:lookup-number
	 read-config
	 runconfigs-get
	 configf:section-vars
	 configf:read-alist
	 configf:config->alist
	 configf:alist->config
	 configf:set-section-var
*	

	 find-and-read-config
	 common:args-get-target
	 configf:eval-string-in-environment

	 read-config-set!
	 configf:read-file

	 configf:system
	 shell
	)

(import scheme
        chicken
	extras
	files
	matchable
	ports




︙


201
202
203
204
205
206
207


208
209
210
211
212
213
214

224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239








+
+








	    #f
	    (let ((match (assoc var sectdat)))
	      (if match ;; (and match (list? match)(> (length match) 1))
		  (cadr match)
		  #f))
	    ))
      #f))

(define lookup configf:lookup)

;; use to have definitive setting:
;;  [foo]
;;  var yes
;;
;;  (configf:var-is? cfgdat "foo" "var" "yes") => #t
;;




︙


232
233
234
235
236
237
238


239
240
241
242
243
244
245

257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272








+
+








  (let ((sectdat (hash-table-ref/default cfgdat section '())))
    (if (null? sectdat)
	'()
	(map car sectdat))))

(define (configf:get-section cfgdat section)
  (hash-table-ref/default cfgdat section '()))

(define get-section configf:get-section)

(define (configf:set-section-var cfgdat section var val)
  (let ((sectdat (configf:get-section cfgdat section)))
    (hash-table-set! cfgdat section
                     (configf:assoc-safe-add sectdat var val))))

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




︙


505
506
507
508
509
510
511
512
513
514
515
516
517
518
519

532
533
534
535
536
537
538



539
540
541
542
543








-
-
-






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




(include "configf-guts.scm")

)









Modified cpumod.scm
from [33a302895b]
to [338168220c].




︙


27
28
29
30
31
32
33

34

35
36
37
38
39
40
41

27
28
29
30
31
32
33
34

35
36
37
38
39
40
41
42








+
-
+








(declare (unit cpumod))
(declare (uses debugprint))
(declare (uses mtargs))

(use srfi-69)

(module cpumod
	()
	*
       

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports




︙







Modified dashboard-context-menu.scm
from [a9287541e5]
to [2e962c22f5].




︙


20
21
22
23
24
25
26
27

28
29
30
31
32
33
34

20
21
22
23
24
25
26

27
28
29
30
31
32
33
34








-
+









;;======================================================================
;; implementation of context menu that pops up on
;; right click on test cell in Runs & Runs Summary Tabs
;;======================================================================

(declare (unit dashboard-context-menu))
(declare (uses common))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezsteps))
;; (declare (uses sdb))
;; (declare (uses filedb))




︙


42
43
44
45
46
47
48
49

50
51
52
53
54
55
56

42
43
44
45
46
47
48

49
50
51
52
53
54
55
56








-
+








(import (prefix iup iup:))

(use canvas-draw)

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

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

(import commonmod
	configfmod
	rmtmod
	testsmod




︙







Modified dashboard-guimonitor.scm
from [14af79287f]
to [6f526827b3].




︙


28
29
30
31
32
33
34
35

36
37
38
39
40

41
42
43
44
45
46
47

28
29
30
31
32
33
34

35
36
37
38
39

40
41
42
43
44
45
46
47








-
+




-
+









(use canvas-draw)

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

(declare (unit dashboard-guimonitor))
(declare (uses common))
;; (declare (uses common))
(declare (uses keys))
(declare (uses commonmod))
(import commonmod)

(include "common_records.scm")
;; (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))




︙







Modified dashboard-tests.scm
from [9f47337a67]
to [00c786d383].




︙


19
20
21
22
23
24
25
26

27
28
29
30
31
32
33

19
20
21
22
23
24
25

26
27
28
29
30
31
32
33








-
+








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

;;======================================================================
;; Test info panel
;;======================================================================

(declare (unit dashboard-tests))
(declare (uses common))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses rmtmod))
(declare (uses megatestmod))
(declare (uses dbmod))
(declare (uses dbfile))




︙


59
60
61
62
63
64
65
66

67
68
69
70
71
72
73

59
60
61
62
63
64
65

66
67
68
69
70
71
72
73








-
+








	dbfile
	tasksmod
	testsmod
	runsmod
	subrunmod
	)

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

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





︙







Modified dashboard.scm
from [0974058261]
to [21bf76042d].




︙


64
65
66
67
68
69
70
71

72
73
74
75
76
77
78

64
65
66
67
68
69
70

71
72
73
74
75
76
77
78








-
+








(declare (uses archivemod.import))
(declare (uses runsmod))
(declare (uses runsmod.import))
(declare (uses launchmod))
(declare (uses launchmod.import))

(declare (uses configf))
(declare (uses common))
;; (declare (uses common))
(declare (uses keys))

(declare (uses process))
(declare (uses launch))
(declare (uses runs))
(declare (uses dashboard-tests))
(declare (uses tree))




︙


105
106
107
108
109
110
111
112

113
114
115
116

117
118
119
120
121
122
123

105
106
107
108
109
110
111

112
113
114
115

116
117
118
119
120
121
122
123








-
+



-
+








	stml2
	megatestmod
	tasksmod
	runsmod
	testsmod
	)

(include "common_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-version.scm")
;; (include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")

;; set some parameters here - these need to be put in something that can be loaded from other
;; executables such as dashboard and mtutil
;;
(include "dashboard-transport-mode.scm")




︙







Modified db_records.scm
from [d1dae58171]
to [1501321c72].




︙


11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

11
12
13
14
15
16
17
























































































































































































-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     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/>.

;;======================================================================
;; dbstruct
;;======================================================================

(define (make-db:test)(make-vector 20))
(define (db:test-get-id           vec) (vector-ref vec 0))
(define (db:test-get-run_id       vec) (vector-ref vec 1))
(define (db:test-get-testname     vec) (vector-ref vec 2))
(define (db:test-get-state        vec) (vector-ref vec 3))
(define (db:test-get-status       vec) (vector-ref vec 4))
(define (db:test-get-event_time   vec) (vector-ref vec 5))
(define (db:test-get-host         vec) (vector-ref vec 6))
(define (db:test-get-cpuload      vec) (vector-ref vec 7))
(define (db:test-get-diskfree     vec) (vector-ref vec 8))
(define (db:test-get-uname        vec) (vector-ref vec 9))
;; (define (db:test-get-rundir       vec) (sdb:qry 'getstr (vector-ref vec 10)))
(define (db:test-get-rundir       vec) (vector-ref vec 10))
(define (db:test-get-item-path    vec) (vector-ref vec 11))
(define (db:test-get-run_duration vec) (vector-ref vec 12))
(define (db:test-get-final_logf   vec) (vector-ref vec 13))
(define (db:test-get-comment      vec) (vector-ref vec 14))
(define (db:test-get-process_id   vec) (vector-ref vec 16))
(define (db:test-get-archived     vec) (vector-ref vec 17))
(define (db:test-get-last_update     vec) (vector-ref vec 18))

;; (define (db:test-get-pass_count   vec) (vector-ref vec 15))
;; (define (db:test-get-fail_count   vec) (vector-ref vec 16))
(define (db:test-get-fullname     vec)
  (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec)))

;; replace runs:make-full-test-name with this routine
(define (db:test-make-full-name testname itempath)
  (if (equal? itempath "") testname (conc testname "/" itempath)))

;; (define (db:test-get-first_err    vec) (printable (vector-ref vec 15)))
;; (define (db:test-get-first_warn   vec) (printable (vector-ref vec 16))) ;; RADT => reference 16 is repeated

(define (db:test-set-cpuload!  vec val)(vector-set! vec 7 val))
(define (db:test-set-diskfree! vec val)(vector-set! vec 8 val))
(define (db:test-set-testname! vec val)(vector-set! vec 2 val))
(define (db:test-set-state!    vec val)(vector-set! vec 3 val))
(define (db:test-set-status!   vec val)(vector-set! vec 4 val))
(define (db:test-set-run_duration! vec val)(vector-set! vec 12 val))
(define (db:test-set-final_logf! vec val)(vector-set! vec 13 val))

;; Test record utility functions

;; Is a test a toplevel?
;;
(define (db:test-get-is-toplevel vec)
  (and (equal? (db:test-get-item-path vec) "")      ;; test is not an item
       (equal? (db:test-get-uname vec)     "n/a"))) ;; test has never been run

;; make-vector-record "" db mintest id run_id testname state status event_time item_path
;; RADT => purpose of mintest??
;;
(define (make-db:mintest)(make-vector 7))
(define (db:mintest-get-id           vec)    (vector-ref  vec 0))
(define (db:mintest-get-run_id       vec)    (vector-ref  vec 1))
(define (db:mintest-get-testname     vec)    (vector-ref  vec 2))
(define (db:mintest-get-state        vec)    (vector-ref  vec 3))
(define (db:mintest-get-status       vec)    (vector-ref  vec 4))
(define (db:mintest-get-event_time   vec)    (vector-ref  vec 5))
(define (db:mintest-get-item_path    vec)    (vector-ref  vec 6))

;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk
(define (make-db:testmeta)(make-vector 10 ""))
(define (db:testmeta-get-id            vec)    (vector-ref  vec 0))
(define (db:testmeta-get-testname      vec)    (vector-ref  vec 1))
(define (db:testmeta-get-author        vec)    (vector-ref  vec 2))
(define (db:testmeta-get-owner         vec)    (vector-ref  vec 3))
(define (db:testmeta-get-description   vec)    (vector-ref  vec 4))
(define (db:testmeta-get-reviewed      vec)    (vector-ref  vec 5))
(define (db:testmeta-get-iterated      vec)    (vector-ref  vec 6))
(define (db:testmeta-get-avg_runtime   vec)    (vector-ref  vec 7))
(define (db:testmeta-get-avg_disk      vec)    (vector-ref  vec 8))
(define (db:testmeta-get-tags          vec)    (vector-ref  vec 9))
(define (db:testmeta-set-id!           vec val)(vector-set! vec 0 val))
(define (db:testmeta-set-testname!     vec val)(vector-set! vec 1 val))
(define (db:testmeta-set-author!       vec val)(vector-set! vec 2 val))
(define (db:testmeta-set-owner!        vec val)(vector-set! vec 3 val))
(define (db:testmeta-set-description!  vec val)(vector-set! vec 4 val))
(define (db:testmeta-set-reviewed!     vec val)(vector-set! vec 5 val))
(define (db:testmeta-set-iterated!     vec val)(vector-set! vec 6 val))
(define (db:testmeta-set-avg_runtime!  vec val)(vector-set! vec 7 val))
(define (db:testmeta-set-avg_disk!     vec val)(vector-set! vec 8 val))

;;======================================================================
;; S I M P L E   R U N
;;======================================================================

;; (defstruct id  "runname" "state" "status" "owner" "event_time"

;;======================================================================
;; T E S T   D A T A 
;;======================================================================
(define (make-db:test-data)(make-vector 10))
(define (db:test-data-get-id               vec)    (vector-ref  vec 0))
(define (db:test-data-get-test_id          vec)    (vector-ref  vec 1))
(define (db:test-data-get-category         vec)    (vector-ref  vec 2))
(define (db:test-data-get-variable         vec)    (vector-ref  vec 3))
(define (db:test-data-get-value            vec)    (vector-ref  vec 4))
(define (db:test-data-get-expected         vec)    (vector-ref  vec 5))
(define (db:test-data-get-tol              vec)    (vector-ref  vec 6))
(define (db:test-data-get-units            vec)    (vector-ref  vec 7))
(define (db:test-data-get-comment          vec)    (vector-ref  vec 8))
(define (db:test-data-get-status           vec)    (vector-ref  vec 9))
(define (db:test-data-get-type             vec)    (vector-ref  vec 10))
(define (db:test-data-get-last_update      vec)    (vector-ref  vec 11))

(define (db:test-data-set-id!              vec val)(vector-set!  vec 0  val))
(define (db:test-data-set-test_id!         vec val)(vector-set!  vec 1  val))
(define (db:test-data-set-category!        vec val)(vector-set!  vec 2  val))
(define (db:test-data-set-variable!        vec val)(vector-set!  vec 3  val))
(define (db:test-data-set-value!           vec val)(vector-set!  vec 4  val))
(define (db:test-data-set-expected!        vec val)(vector-set!  vec 5  val))
(define (db:test-data-set-tol!             vec val)(vector-set!  vec 6  val))
(define (db:test-data-set-units!           vec val)(vector-set!  vec 7  val))
(define (db:test-data-set-comment!         vec val)(vector-set!  vec 8  val))
(define (db:test-data-set-status!          vec val)(vector-set!  vec 9  val))
(define (db:test-data-set-type!            vec val)(vector-set!  vec 10 val))

;;======================================================================
;; S T E P S 
;;======================================================================
;; Run steps
;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time    
(define (make-db:step)(make-vector 9))
(define (tdb:step-get-id              vec)    (vector-ref  vec 0))
(define (tdb:step-get-test_id         vec)    (vector-ref  vec 1))
(define (tdb:step-get-stepname        vec)    (vector-ref  vec 2))
(define (tdb:step-get-state           vec)    (vector-ref  vec 3))
(define (tdb:step-get-status          vec)    (vector-ref  vec 4))
(define (tdb:step-get-event_time      vec)    (vector-ref  vec 5))
(define (tdb:step-get-logfile         vec)    (vector-ref  vec 6))
(define (tdb:step-get-comment         vec)    (vector-ref  vec 7))
(define (tdb:step-get-last_update     vec)    (vector-ref  vec 8))
(define (tdb:step-set-id!             vec val)(vector-set! vec 0 val))
(define (tdb:step-set-test_id!        vec val)(vector-set! vec 1 val))
(define (tdb:step-set-stepname!       vec val)(vector-set! vec 2 val))
(define (tdb:step-set-state!          vec val)(vector-set! vec 3 val))
(define (tdb:step-set-status!         vec val)(vector-set! vec 4 val))
(define (tdb:step-set-event_time!     vec val)(vector-set! vec 5 val))
(define (tdb:step-set-logfile!        vec val)(vector-set! vec 6 val))
(define (tdb:step-set-comment!        vec val)(vector-set! vec 7 val))


;; The steps table
(define (make-db:steps-table)(make-vector 5))
(define (tdb:steps-table-get-stepname   vec)    (vector-ref  vec 0))
(define (tdb:steps-table-get-start      vec)    (vector-ref  vec 1))
(define (tdb:steps-table-get-end        vec)    (vector-ref  vec 2))
(define (tdb:steps-table-get-status     vec)    (vector-ref  vec 3))
(define (tdb:steps-table-get-runtime    vec)    (vector-ref  vec 4))
(define (tdb:steps-table-get-log-file   vec)    (vector-ref  vec 5))

(define (tdb:step-stable-set-stepname!  vec val)(vector-set! vec 0 val))
(define (tdb:step-stable-set-start!     vec val)(vector-set! vec 1 val))
(define (tdb:step-stable-set-end!       vec val)(vector-set! vec 2 val))
(define (tdb:step-stable-set-status!    vec val)(vector-set! vec 3 val))
(define (tdb:step-stable-set-runtime!   vec val)(vector-set! vec 4 val))

;; ;; The data structure for handing off requests via wire
;; (define (make-cdb:packet)(make-vector 6))
;; (define (cdb:packet-get-client-sig   vec)    (vector-ref  vec 0))
;; (define (cdb:packet-get-qtype        vec)    (vector-ref  vec 1))
;; (define (cdb:packet-get-immediate    vec)    (vector-ref  vec 2))
;; (define (cdb:packet-get-query-sig    vec)    (vector-ref  vec 3))
;; (define (cdb:packet-get-params       vec)    (vector-ref  vec 4))
;; (define (cdb:packet-get-qtime        vec)    (vector-ref  vec 5))
;; (define (cdb:packet-set-client-sig!  vec val)(vector-set! vec 0 val))
;; (define (cdb:packet-set-qtype!       vec val)(vector-set! vec 1 val))
;; (define (cdb:packet-set-immediate!   vec val)(vector-set! vec 2 val))
;; (define (cdb:packet-set-query-sig!   vec val)(vector-set! vec 3 val))
;; (define (cdb:packet-set-params!      vec val)(vector-set! vec 4 val))
;; (define (cdb:packet-set-qtime!       vec val)(vector-set! vec 5 val))








Modified dbmod.scm
from [6fddda802c]
to [24c8e30f6f].




︙


24
25
26
27
28
29
30





31











































































































































32
33
34
35
36
37
38

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

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181








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








(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses mtmod))

(module dbmod
	(
	 db:test-get-event_time
	 db:test-get-item-path
	 db:test-get-testname
	 db:get-value-by-header
	*
	 
	 db:get-subdb

	 db:multi-db-sync
	 
	 dbmod:open-dbmoddb
	 dbmod:run-id->dbfname

	 db:roll-up-rules
	 db:get-all-state-status-counts-for-test
	 db:test-set-state-status-db
	 db:general-call
	 db:convert-test-itempath

	 db:test-data-rollup
	 db:keep-trying-until-true
	 db:get-test-info-by-id
	 db:with-db
	 db:get-test-id
	 db:get-test-info

	 dbmod:print-db-stats
	 db:get-keys
	 db:open-no-sync-db
	 db:add-stats

	 ;; dbr:counts record accessors
	 dbr:counts->alist

	 db:add-var
	 db:archive-register-block-name
	 db:archive-register-disk
	 db:create-all-triggers
	 db:csv->test-data
	 db:dec-var
	 db:del-var
	 db:delete-old-deleted-test-records
	 db:delete-run
	 db:delete-steps-for-test!
	 db:delete-test-records
	 db:drop-all-triggers
	 db:get-all-run-ids
	 db:get-all-runids
	 db:get-changed-record-ids
	 db:get-changed-record-run-ids
	 db:get-changed-record-test-ids
	 db:get-count-tests-running
	 db:get-count-tests-running-for-run-id
	 db:get-count-tests-running-for-testname
	 db:get-count-tests-running-in-jobgroup
	 db:get-data-info-by-id
	 db:get-key-val-pairs
	 db:get-key-vals
	 db:get-latest-host-load
	 db:get-main-run-stats
	 db:get-matching-previous-test-run-records
	 db:get-not-completed-cnt
	 db:get-num-runs
	 db:get-prereqs-not-met
	 db:get-prev-run-ids
	 db:get-raw-run-stats
	 db:get-run-ids-matching-target
	 db:get-run-info
	 db:get-run-name-from-id
	 db:get-run-record-ids
	 db:get-run-state
	 db:get-run-state-status
	 db:get-run-stats
	 db:get-run-status
	 db:get-run-times
	 db:get-runs
	 db:get-runs-by-patt
	 db:get-runs-cnt-by-patt
	 db:get-steps-data
	 db:get-steps-for-test
	 db:get-steps-info-by-id
	 db:get-target
	 db:get-targets
	 db:get-test-state-status-by-id
	 db:get-test-times
	 db:get-testinfo-state-status
	 db:get-tests-for-run
	 db:get-tests-for-run-mindata
	 db:get-tests-for-run-state-status
	 db:get-tests-tags
	 db:get-toplevels-and-incompletes
	 db:get-var
	 db:have-incompletes?
	 db:inc-var
	 db:initialize-main-db
	 db:insert-run
	 db:insert-test
	 db:lock/unlock-run
	 db:login
	 db:read-test-data
	 db:read-test-data-varpatt
	 db:register-run
	 db:set-run-state-status
	 db:set-run-status
	 db:set-state-status-and-roll-up-run
	 db:set-var
	 db:simple-get-runs
	 db:test-get-archive-block-info
	 db:test-get-logfile-info
	 db:test-get-paths-matching-keynames-target-new
	 db:test-get-records-for-index-file
	 db:test-get-rundir-from-test-id
	 db:test-get-top-process-pid
	 db:test-set-archive-block-id
	 db:test-set-state-status
	 db:test-set-top-process-pid
	 db:test-toplevel-num-items
	 db:testmeta-add-record
	 db:testmeta-get-record
	 db:testmeta-update-field
	 db:teststep-set-status!
	 db:top-test-set-per-pf-counts
	 db:update-run-event_time
	 db:update-run-stats
	 db:update-tesdata-on-repilcate-db
	 tasks:add
	 tasks:find-task-queue-records
	 tasks:get-last
	 tasks:set-state-given-param-key

	 *db-stats*
	 dbmod:nfs-get-dbstruct
	 *db-stats-mutex*

	 db:get-header
	 db:get-rows
	 db:get-changed-run-ids

	 db:set-sync
	 db:setup

	 db:logpro-dat->csv
	 std-exit-procedure
	 )
	
(import scheme)
	
(cond-expand
 (chicken-4
  (import chicken
	  data-structures




︙


77
78
79
80
81
82
83
84

85
86
87
88
89
90
91

220
221
222
223
224
225
226

227
228
229
230
231
232
233
234








-
+








	commonmod
	configfmod
	dbfile
	debugprint
	mtmod
	)

(include "common_records.scm")
;; (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)





︙







Modified dcommon.scm
from [d0a5600c78]
to [bda06bf5b7].




︙


38
39
40
41
42
43
44
45

46
47
48
49
50
51
52

38
39
40
41
42
43
44

45
46
47
48
49
50
51
52








-
+








	configfmod
	rmtmod
        testsmod
        dbmod
	debugprint)

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

;; yes, this is non-ideal 
(define dashboard:update-summary-tab #f)
(define dashboard:update-servers-table #f)




︙







Modified diff-report.scm
from [939aa5e4ab]
to [ab6e573136].




︙


13
14
15
16
17
18
19
20

21
22
23
24
25
26
27
28

29
30
31
32
33
34
35

13
14
15
16
17
18
19

20
21
22
23
24
25
26
27

28
29
30
31
32
33
34
35








-
+







-
+








;;     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/>.
;;

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

(define (diff:tests-mindat->hash tests-mindat)
  (let* ((res (make-hash-table)))




︙







Modified ezsteps.scm
from [27c83d47a5]
to [8e5e826481].




︙


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








-
+








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

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

(declare (unit ezsteps))
(declare (uses commonmod))
(declare (uses common))
;; (declare (uses common))
(declare (uses configfmod))
(declare (uses debugprint))

(declare (uses runconfig))
(declare (uses rmtmod))
(declare (uses mtargs))
(declare (uses tasksmod))




︙







Modified ezstepsmod.scm
from [0f672c5b01]
to [ff6068567c].




︙


43
44
45
46
47
48
49
50

51
52
53
54
55
56
57

43
44
45
46
47
48
49

50
51
52
53
54
55
56
57








-
+








(declare (uses testsmod))
(declare (uses runsmod))
(declare (uses fsmod))

(use srfi-69)

(module ezstepsmod
	*
	()

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports




︙


124
125
126
127
128
129
130
131

132
133
134
135
136
137
138

124
125
126
127
128
129
130

131
132
133
134
135
136
137
138








-
+








	tasksmod
	subrunmod
	testsmod
	runsmod
	fsmod
	)

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


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





︙







Modified fsmod.scm
from [57a2c983b3]
to [5fe1b052db].




︙


31
32
33
34
35
36
37






38


39
40
41
42
43
44
45

31
32
33
34
35
36
37
38
39
40
41
42
43

44
45
46
47
48
49
50
51
52








+
+
+
+
+
+
-
+
+








(declare (uses configfmod))
(declare (uses commonmod))
(declare (uses processmod))

(use srfi-69)

(module fsmod
	(
	 get-df
	 get-uname
	 common:get-disk-with-most-free-space
	 common:get-disk-space-used
	 common:check-db-dir-and-exit-if-insufficient
	*

	 )

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports




︙







Modified genexample.scm
from [6229d612cf]
to [706bcbab51].




︙


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








-
+








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

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

(declare (unit genexample))
(declare (uses mtargs))
(declare (uses debugprint))
(declare (uses common))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))

(use posix regex matchable)
(import (prefix mtargs args:)
	commonmod




︙







Modified key_records.scm
from [55f6701b87]
to [8cb99c889a].




︙


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

14
15
16
17
18
19
20




















-
-
-
-
-
-
-
-
-
-
-
-

;;     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/>.

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

(define (keys->valslots keys) ;; => ?,?,? ....
  (string-intersperse (map (lambda (x) "?") keys) ","))

;; (define (keys->key/field keys . additional)
;;   (string-join (map (lambda (k)(conc k " TEXT"))
;; 		    (append keys additional)) ","))

(define (item-list->path itemdat)
  (if (list? itemdat)
      (string-intersperse  (map cadr itemdat) "/")
      ""))









Modified keys.scm
from [ddf211e0d9]
to [727b92d3a4].




︙


18
19
20
21
22
23
24
25

26
27
28
29
30
31
32

18
19
20
21
22
23
24

25
26
27
28
29
30
31
32








-
+








;;
 
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================

(declare (unit keys))
(declare (uses common))
;; (declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses mtargs))

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




︙







Modified launch.scm
from [60c51037a0]
to [24a75d7c76].




︙


19
20
21
22
23
24
25
26

27
28
29
30
31
32
33

19
20
21
22
23
24
25

26
27
28
29
30
31
32
33








-
+








;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================

(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
;; (declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses processmod))
(declare (uses configfmod))
(declare (uses configf))
(declare (uses rmtmod))
(declare (uses ezsteps))




︙


44
45
46
47
48
49
50
51

52
53
54
55
56
57
58

44
45
46
47
48
49
50

51
52
53
54
55
56
57
58








-
+








     typed-records pathname-expand matchable)

(import (prefix base64 base64:)
	(prefix sqlite3 sqlite3:)
	(prefix mtargs args:)
)

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

(import commonmod
	processmod
	configfmod




︙







Modified launchmod.scm
from [46f91d6b1b]
to [a0b277c06f].




︙


42
43
44
45
46
47
48
49


50
51
52
53
54
55
56

42
43
44
45
46
47
48

49
50
51
52
53
54
55
56
57








-
+
+








(declare (uses testsmod))
(declare (uses runsmod))
(declare (uses fsmod))

(use srfi-69)

(module launchmod
	*
	(
	)

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports




︙


124
125
126
127
128
129
130
131

132
133
134
135
136
137
138

125
126
127
128
129
130
131

132
133
134
135
136
137
138
139








-
+








	tasksmod
	subrunmod
	testsmod
	runsmod
	fsmod
	)

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

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




︙


977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076

978
979
980
981
982
983
984






















































































985
986
987
988
989
990
991








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








		     #f)))
    ;; now wait on that process if all is correct
    ;; periodically update the db with runtime
    ;; when the process exits look at the db, if still RUNNING after 10 seconds set
    ;; state/status appropriately
    (process-wait pid)))

;;======================================================================
;; Maintenance
;;======================================================================

(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
  (let* ((cfg-deadtime             (configf:lookup-number *configdat* "setup" "deadtime"))
	 (test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period")))
   (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
   ;;call end of eud of run detection for posthook
   (launch:end-of-run-check run-id)))

;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
;;
;; NOT EASY TO MIGRATE TO db{file,mod}
;;
(define (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
  (let* ((incompleted '())
	 (oldlaunched '())
	 (toplevels   '())
          ;; The default running-deadtime is 720 seconds = 12 minutes.
          ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30))
         (deadtime-trim (or ovr-deadtime cfg-deadtime))
         (server-start-allowance 200)
         (server-overloaded-budget 200)
         (launch-monitor-off-time (or test-stats-update-period 30))
         (launch-monitor-on-time-budget 30)
         (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget))
         (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30))
         (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default))
         (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))
         (running-deadtime (or deadtime-trim running-deadtime-default))) ;; two minutes (30 seconds between updates, this leaves 3x grace period)

    (debug:print-info 4  *default-log-port* "running-deadtime = " running-deadtime)
    (debug:print-info 4  *default-log-port* "deadtime-trim = " deadtime-trim)

    (let* ((dat (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime)))
      (set! oldlaunched (list-ref dat 1))
      (set! toplevels   (list-ref dat 2))
      (set! incompleted (list-ref dat 0)))

    (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, "
		      (length toplevels) " old LAUNCHED toplevel tests and "
		      (length incompleted) " tests marked RUNNING but apparently dead.")
  
    ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
    ;;
    ;; (db:delay-if-busy dbdat)
    (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all
	   (all-ids             (append min-incompleted-ids (map car oldlaunched))))
      (if (> (length all-ids) 0)
	  (begin
	    ;; (launch:is-test-alive "localhost" 435)
	    (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ")
			 " as DEAD")
	    (for-each
             (lambda (test-id)
               (let* ((tinfo   (rmt:get-test-info-by-id run-id test-id))
		      (run-dir (db:test-get-rundir     tinfo))
		      (host    (db:test-get-host       tinfo))
		      (pid     (db:test-get-process_id tinfo))
		      (result (rmt:get-status-from-final-status-file run-dir)))
		 (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result))) 
		     (begin
		       (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD")
		       (rmt:set-state-status-and-roll-up-items
			run-id test-id 'foo "COMPLETED" "PASS"
			"Test stopped responding but it has PASSED; marking it PASS in the DB."))
		     (let ((is-alive (and (not (eq? pid 0))  ;; 0 is default in re-used field "attemptnum" where pid stored.
					  (commonmod:is-test-alive host pid))))
		       (if is-alive
			   (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host
					" has a process on pid " pid ", NOT setting to DEAD.")
			   (begin
			     (debug:print 0 *default-log-port* "INFO: test " test-id
					  " final state/status is not COMPLETED/PASS. It is " result)
			     (rmt:set-state-status-and-roll-up-items
			      run-id test-id 'foo "COMPLETED" "DEAD"
			      "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
	     ;; call end of eud of run detection for posthook - from merge, is it needed?
	     ;; (launch:end-of-run-check run-id)
	     all-ids)
	    )))))


;; TODO: deprecate me in favor of ezsteps.scm
;;
(define (ezsteps: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))
	;; (let ((info (cadr ezstep)))




︙







Modified megatest.scm
from [faeb3396e2]
to [d93df9db65].




︙


13
14
15
16
17
18
19
20

21
22
23
24
25

26
27
28
29

30
31
32
33
34
35
36

13
14
15
16
17
18
19

20
21
22
23
24

25
26
27
28

29
30
31
32
33
34
35
36








-
+




-
+



-
+








;;     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/>.
;;

;; (include "common.scm")
(include "megatest-version.scm")
;; (include "megatest-version.scm")

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(declare (uses common))
;; (declare (uses common))
;; (declare (uses megatest-version))
;; (declare (uses margs))
(declare (uses mtargs))
;; (declare (uses mtargs.import))
(declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses cookie))
(declare (uses cookie.import))
(declare (uses stml2))
(declare (uses stml2.import))
(declare (uses commonmod))




︙


119
120
121
122
123
124
125
126

127
128
129
130
131
132
133

119
120
121
122
123
124
125

126
127
128
129
130
131
132
133








-
+








	rmtmod
	launchmod
	fsmod
        )

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

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

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:))
(use readline apropos json http-client directory-utils typed-records)




︙







Modified megatestmod.scm
from [a70a654362]
to [5c7bd63407].




︙


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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68








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








(declare (uses pkts))
(declare (uses servermod))
(declare (uses fsmod))

(use srfi-69)

(module megatestmod
	(
	db:set-tests-state-status
	db:set-state-status-and-roll-up-items
	common:get-install-area
	tests:get-all
	common:use-cache?
	*

mt:lazy-read-test-config
common:get-full-test-name
tests:extend-test-patts
tests:get-itemmaps
tests:get-items
tests:get-global-waitons
tests:get-tests-search-path
tests:filter-test-names
common:args-get-testpatt
tests:filter-test-names-not-matched
common:args-get-runname
	)

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports




︙







Modified monitor.scm
from [11b5fa345e]
to [5284c87b1f].




︙


17
18
19
20
21
22
23
24

25
26
27
28
29
30

31
32
33
34

17
18
19
20
21
22
23

24
25
26
27
28
29

30
31
32
33
34








-
+





-
+






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

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

(declare (unit runs))
(declare (uses common))
;; (declare (uses common))

(declare (uses runconfig))
(declare (uses commonmod))
(import commonmod)

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









Modified mt.scm
from [f24a9e55ce]
to [715a388a89].




︙


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

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








-
+


















-
+









(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils
     call-with-environment-variables)

(import (prefix sqlite3 sqlite3:))

(declare (unit mt))
(declare (uses debugprint))
(declare (uses common))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))

(declare (uses runconfig))
(declare (uses server))
(declare (uses runs))
(declare (uses rmtmod))
(declare (uses megatestmod))

(import debugprint
	commonmod
	configfmod
	rmtmod
	megatestmod)

;; make mt: calls in megatestmod work
;; (read-config-set! read-config)

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

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









Modified mtexec.scm
from [8cf589213b]
to [e107d3437d].




︙


34
35
36
37
38
39
40
41

42
43
44
45
46
47
48

34
35
36
37
38
39
40

41
42
43
44
45
46
47
48








-
+








(declare (uses configfmod))

(import commonmod
	configfmod
	(prefix mtargs args:))

;; (use ducttape-lib)
(include "megatest-version.scm")
;; (include "megatest-version.scm")
(include "megatest-fossil-hash.scm")

;; (require-library stml)

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




︙







Modified mtmod.scm
from [b742c926fe]
to [4d23e65eeb].




︙


30
31
32
33
34
35
36







37





38
39
40
41
42
43
44

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








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








(declare (uses commonmod))
(declare (uses configfmod))
;; (declare (uses tcp-transportmod)) ;; we don't want mtmod depending on tcp

(use srfi-69)

(module mtmod
	(
	 keys:make-key/field-string
	 common:get-testsuite-name
	 items:get-items-from-config
	 mt:run-trigger
	 common:get-linktree
	 common:get-area-name
	*
	 
	 items:check-valid-items
	 mt:discard-blocked-tests

	 )

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports




︙







Modified mtut.scm
from [73522346db]
to [f402ce6bd2].




︙


12
13
14
15
16
17
18
19

20
21
22
23
24
25
26

12
13
14
15
16
17
18

19
20
21
22
23
24
25
26








-
+








;;     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/>.
;;
;
(declare (uses common))
;; (declare (uses common))
(declare (uses mtargs))
(declare (uses mtargs.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses configfmod))




︙







Modified odsmod.scm
from [9072959ec4]
to [c50014d604].




︙


14
15
16
17
18
19
20
21

22
23
24
25
26
27
28


29
30
31
32
33
34
35

14
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/>.
;;

(use csv-xml regex)
(declare (unit odsmod))
(declare (uses common))
;; (declare (uses common))
(declare (uses commonmod))
(declare (uses debugprint))
(declare (uses dbfile))
(declare (uses dbmod))

(module odsmod
	*
	(
	 )
	
(import scheme
	chicken
	data-structures
	extras
	posix
	ports




︙







Modified processmod.scm
from [1cce7c0878]
to [1199556817].




︙


21
22
23
24
25
26
27





28




29
30
31
32
33
34
35

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

33
34
35
36
37
38
39
40
41
42
43








+
+
+
+
+
-
+
+
+
+








(declare (unit processmod))
(declare (uses debugprint))
(declare (uses commonmod))

(use srfi-69)

(module processmod
	(
	 process:cmd-run->list
	 process:alive?
	 run-n-wait
	 process:cmd-run-with-stderr-and-exitcode->list
	*

	 process:alive-on-host?
	 process:get-sub-pids
	 )

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports




︙







Modified rmtmod.scm
from [f16c2416fe]
to [1fb394eaa1].




︙


26
27
28
29
30
31
32







33











































































































34
35
36
37
38
39
40

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








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








(declare (uses dbmod))
(declare (uses mtmod))
(declare (uses tcp-transportmod))
(declare (uses apimod))
(declare (uses servermod))

(module rmtmod
	(
	 rmtmod:send-receive
	 rmt:send-receive
	 rmt:no-sync-get-lock
	 rmt:no-sync-del!
	 rmt:no-sync-set
	 rmt:no-sync-get/default
	*

	 rmt:get-runs-by-patt
	 rmt:get-testinfo-state-status
	 rmt:get-test-id
	 rmt:set-state-status-and-roll-up-items

	 rmt:get-prereqs-not-met
	 rmt:get-tests-for-run

	 rmt:get-keys
	 rmt:test-get-records-for-index-file
	 tests:test-set-toplog!
	 rmt:test-get-logfile-info
	 rmt:general-call
	 rmt:test-get-paths-matching-keynames-target-new
	 rmt:get-test-info-by-id
	 rmt:get-steps-for-test
	 rmt:get-num-runs
	 rmt:get-runs-cnt-by-patt
	 rmt:get-runs

	 rmt:get-latest-host-load
	 rmt:get-changed-record-test-ids
	 rmt:get-all-runids
	 rmt:get-changed-record-run-ids
	 rmt:get-run-record-ids
	 rmt:get-data-info-by-id
	 rmt:get-steps-info-by-id
	 rmt:get-target

	 rmt:get-run-name-from-id
	 rmt:get-run-info
	 rmt:get-test-times
	 rmt:get-run-times

	 rmt:tasks-find-task-queue-records
	 
	 common:api-changed?
	 rmt:on-homehost?

	 rmt:get-var
	 rmt:csv->test-data
	 rmt:get-previous-test-run-record

	 common:cleanup-db
	 common:get-last-run-version

	 rmt:get-key-val-pairs
	 rmt:create-all-triggers
	 rmt:update-tesdata-on-repilcate-db
	 rmt:drop-all-triggers
	 rmt:test-get-archive-block-info
	 rmt:test-toplevel-num-items
	 rmt:archive-get-allocations
	 rmt:archive-register-disk
	 rmt:archive-register-block-name

	 mt:get-runs-by-patt
	 rmt:simple-get-runs
	 rmt:get-tests-for-runs-mindata
	 rmt:test-get-top-process-pid
	 rmt:set-state-status-and-roll-up-run
	 rmt:get-run-state-status
	 rmt:get-not-completed-cnt
	 rmt:get-tests-tags
	 rmt:testmeta-update-field
	 rmt:testmeta-add-record
	 rmt:testmeta-get-record
	 rmt:lock/unlock-run
	 rmt:delete-old-deleted-test-records
	 rmt:delete-run
	 rmt:get-raw-run-stats
	 rmt:update-run-stats
	 rmt:delete-test-records
	 rmt:test-set-archive-block-id
	 mt:get-tests-for-run
	 mt:test-set-state-status-by-testname
	 mt:test-set-state-status-by-testname-unless-completed
	 rmt:register-test
	 mt:test-set-state-status-by-id-unless-completed
	 rmt:get-all-run-ids

	 rmt:set-run-state-status
	 rmt:set-var
	 rmt:set-tests-state-status
	 rmt:tasks-add
	 rmt:tasks-set-state-given-param-key
	 rmt:register-run
	 rmt:get-count-tests-running-in-jobgroup
	 rmt:get-count-tests-running-for-run-id
	 
	 rmt:test-set-state-status-by-id
	 mt:test-set-state-status-by-id

	 rmt:get-status-from-final-status-file
	 rmt:get-toplevels-and-incompletes 

	 rmt:test-set-log!
	 rmt:teststep-set-status!

	 rmt:delete-steps-for-test!
	 rmt:test-set-state-status
	 rmt:get-test-state-status-by-id
	 rmt:test-set-top-process-pid

	 )
	
	
(import scheme
	chicken
	data-structures
	regex
	extras
	matchable




︙


703
704
705
706
707
708
709
710
711
712
713




714
715
716
717
718
719
720

816
817
818
819
820
821
822




823
824
825
826
827
828
829
830
831
832
833








-
-
-
-
+
+
+
+








(define (rmt:update-run-event_time run-id)
  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'update-run-event_time #f (list run-id)))

(define (rmt:get-runs-by-patt  keys runnamepatt targpatt offset limit fields last-runs-update  #!key  (sort-order "asc")) ;; fields of #f uses default
  (rmt:send-receive 'get-runs-by-patt #f (list keys runnamepatt targpatt offset limit fields last-runs-update sort-order)))

(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
  (assert (number? run-id) "FATAL: Run id required.")
  ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
  (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )
;; (define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
;;   (assert (number? run-id) "FATAL: Run id required.")
;;   ;; (if (rmt:send-receive 'have-incompletes? run-id (list run-id ovr-deadtime))
;;   (rmt:send-receive 'mark-incomplete run-id (list run-id ovr-deadtime))) ;; )

(define (rmt:get-main-run-stats run-id)
  (assert (number? run-id) "FATAL: Run id required.")
  (rmt:send-receive 'get-main-run-stats #f (list run-id)))

(define (rmt:get-var varname)
  (rmt:send-receive 'get-var #f (list varname)))




︙


735
736
737
738
739
740
741
742
743
744
745
746





747
748
749
750
751
752
753

848
849
850
851
852
853
854





855
856
857
858
859
860
861
862
863
864
865
866








-
-
-
-
-
+
+
+
+
+








  (rmt:send-receive 'add-var #f (list varname value)))

;;======================================================================
;; M U L T I R U N   Q U E R I E S
;;======================================================================

;; Need to move this to multi-run section and make associated changes
(define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
  (let ((run-ids (rmt:get-all-run-ids)))
    (for-each (lambda (run-id)
	       (rmt:find-and-mark-incomplete run-id ovr-deadtime))
	     run-ids)))
;; (define (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))
;;   (let ((run-ids (rmt:get-all-run-ids)))
;;     (for-each (lambda (run-id)
;; 	       (rmt:find-and-mark-incomplete run-id ovr-deadtime))
;; 	     run-ids)))

;; get the previous record for when this test was run where all keys match but runname
;; returns #f if no such test found, returns a single test record if found
;; 
;; Run this at the client end since we have to connect to multiple run-id dbs
;;
(define (rmt:get-previous-test-run-record run-id test-name item-path)




︙







Modified runconfig.scm
from [5664220be3]
to [5190dce4cd].




︙


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








-
+






-
+


;; 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 common))
(declare (uses debugprint))
(declare (uses commonmod))

(import commonmod
	debugprint)

(include "common_records.scm")
;; (include "common_records.scm")









Modified runs.scm
from [647460790c]
to [9c12515ed9].




︙


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

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








-
+












-
+








(declare (uses dbfile))
(declare (uses dbmod))
(declare (uses megatestmod))
(declare (uses mtmod))
(declare (uses tasksmod))
(declare (uses servermod))

(declare (uses common))
;; (declare (uses common))

(declare (uses runconfig))
(declare (uses server))
(declare (uses mt))
(declare (uses archive))

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) 
     posix-extras directory-utils pathname-expand typed-records format  sxml-serializer
     sxml-modifications matchable)



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

;; (include "debugger.scm")





︙







Modified runsmod.scm
from [251bedfaeb]
to [2e2fa19e43].




︙


42
43
44
45
46
47
48





49





50
51
52
53
54
55
56

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

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








+
+
+
+
+
-
+
+
+
+
+








(declare (uses subrunmod))
(declare (uses archivemod))
(declare (uses fsmod))

(use srfi-69)

(module runsmod
	(
	 rmt:find-and-mark-incomplete
	 launch:setup
	 launch:end-of-run-check
	 launch:test-copy
	*

	 set-item-env-vars
	 runs:set-megatest-env-vars
	 full-runconfigs-read
	 )

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports




︙


125
126
127
128
129
130
131
132

133
134
135
136
137
138
139

134
135
136
137
138
139
140

141
142
143
144
145
146
147
148








-
+








	tasksmod
	testsmod
	subrunmod
	archivemod
	fsmod
	)

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

;; use this struct to facilitate refactoring
;;




︙


4538
4539
4540
4541
4542
4543
4544
4545



4546























































































4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557

4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643









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

		(if (member (symbol->string archive-command) '("save-remove"))
                    (begin 
                     (debug:print-info 0 *default-log-port* "remove testdat")
		    (runs:remove-test-directory test-dat 'archive-remove)))))
	    (hash-table-ref test-groups test-base)))))
       (hash-table-keys disk-groups))
    #t))

;;======================================================================
;; Maintenance
;;======================================================================
)

(define (rmt:find-and-mark-incomplete run-id ovr-deadtime)
  (let* ((cfg-deadtime             (configf:lookup-number *configdat* "setup" "deadtime"))
	 (test-stats-update-period (configf:lookup-number *configdat* "setup" "test-stats-update-period")))
   (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
   ;;call end of eud of run detection for posthook
   (launch:end-of-run-check run-id)))

;;  select end_time-now from
;;      (select testname,item_path,event_time+run_duration as
;;                          end_time,strftime('%s','now') as now from tests where state in
;;      ('RUNNING','REMOTEHOSTSTART','LAUNCHED'));
;;
;; NOT EASY TO MIGRATE TO db{file,mod}
;;
(define (rmt:find-and-mark-incomplete-engine run-id ovr-deadtime cfg-deadtime test-stats-update-period)
  (let* ((incompleted '())
	 (oldlaunched '())
	 (toplevels   '())
          ;; The default running-deadtime is 720 seconds = 12 minutes.
          ;; "(running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))" = 200 + (2 * (200 + 30 + 30))
         (deadtime-trim (or ovr-deadtime cfg-deadtime))
         (server-start-allowance 200)
         (server-overloaded-budget 200)
         (launch-monitor-off-time (or test-stats-update-period 30))
         (launch-monitor-on-time-budget 30)
         (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget))
         (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30))
         (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default))
         (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period)))
         (running-deadtime (or deadtime-trim running-deadtime-default))) ;; two minutes (30 seconds between updates, this leaves 3x grace period)

    (debug:print-info 4  *default-log-port* "running-deadtime = " running-deadtime)
    (debug:print-info 4  *default-log-port* "deadtime-trim = " deadtime-trim)

    (let* ((dat (rmt:get-toplevels-and-incompletes run-id running-deadtime remotehoststart-deadtime)))
      (set! oldlaunched (list-ref dat 1))
      (set! toplevels   (list-ref dat 2))
      (set! incompleted (list-ref dat 0)))

    (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, "
		      (length toplevels) " old LAUNCHED toplevel tests and "
		      (length incompleted) " tests marked RUNNING but apparently dead.")
  
    ;; These are defunct tests, do not do all the overhead of set-state-status. Force them to INCOMPLETE.
    ;;
    ;; (db:delay-if-busy dbdat)
    (let* ((min-incompleted-ids (map car incompleted)) ;; do 'em all
	   (all-ids             (append min-incompleted-ids (map car oldlaunched))))
      (if (> (length all-ids) 0)
	  (begin
	    ;; (launch:is-test-alive "localhost" 435)
	    (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ")
			 " as DEAD")
	    (for-each
             (lambda (test-id)
               (let* ((tinfo   (rmt:get-test-info-by-id run-id test-id))
		      (run-dir (db:test-get-rundir     tinfo))
		      (host    (db:test-get-host       tinfo))
		      (pid     (db:test-get-process_id tinfo))
		      (result (rmt:get-status-from-final-status-file run-dir)))
		 (if (and (list? result) (> (length result) 1) (equal? "PASS" (cadr result)) (equal? "COMPLETED" (car result))) 
		     (begin
		       (debug:print 0 *default-log-port* "INFO: test " test-id " actually passed, so marking PASS not DEAD")
		       (rmt:set-state-status-and-roll-up-items
			run-id test-id 'foo "COMPLETED" "PASS"
			"Test stopped responding but it has PASSED; marking it PASS in the DB."))
		     (let ((is-alive (and (not (eq? pid 0))  ;; 0 is default in re-used field "attemptnum" where pid stored.
					  (commonmod:is-test-alive host pid))))
		       (if is-alive
			   (debug:print 0 *default-log-port* "INFO: test " test-id " on host " host
					" has a process on pid " pid ", NOT setting to DEAD.")
			   (begin
			     (debug:print 0 *default-log-port* "INFO: test " test-id
					  " final state/status is not COMPLETED/PASS. It is " result)
			     (rmt:set-state-status-and-roll-up-items
			      run-id test-id 'foo "COMPLETED" "DEAD"
			      "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")))))))
	     ;; call end of eud of run detection for posthook - from merge, is it needed?
	     ;; (launch:end-of-run-check run-id)
	     all-ids)
	    )))))



)








Modified server.scm
from [3cd1085ec7]
to [d483f05a8e].




︙


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

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








-
+

















-
+








;; 
;;     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 server))

(declare (uses common))
;; (declare (uses common))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses rmtmod))
(declare (uses launch))
(declare (uses mtargs))

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

(import commonmod
	configfmod
	debugprint
	(prefix mtargs args:))

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

(define (db:kill-servers)
  (let* ((tl (launch:setup)) ;; need this to initialize *toppath*
        (servdir (conc *toppath* "/.servinfo"))
        (servfiles (glob (conc servdir "/*:*.db")))
        (fmtstr  "~10a~22a~10a~25a~25a~8a\n")




︙







Modified servermod.scm
from [5384b281b4]
to [8f38f0674c].




︙


21
22
23
24
25
26
27




28


29
30
31
32
33
34
35

21
22
23
24
25
26
27
28
29
30
31

32
33
34
35
36
37
38
39
40








+
+
+
+
-
+
+








(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses mtmod))
(declare (uses debugprint))
(declare (uses mtargs))

(module servermod
	(
	 remote-hh-dat
	 server:mk-signature
	 common:wait-for-normalized-load
	*
	 
	 )

(import scheme
	chicken)
	
(use (srfi 18) extras s11n)
(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest)
(use directory-utils posix-extras matchable utils)




︙


44
45
46
47
48
49
50
51

52
53
54
55
56
57
58

49
50
51
52
53
54
55

56
57
58
59
60
61
62
63








-
+








	commonmod
	configfmod
	debugprint
	(prefix mtargs args:)
	mtmod
	)

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

(define (server:make-server-url hostport)
  (if (not hostport)
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))





︙







Modified subrun.scm
from [479d716ad5]
to [66d6a52eda].




︙


22
23
24
25
26
27
28
29

30
31
32
33
34
35
36

22
23
24
25
26
27
28

29
30
31
32
33
34
35
36








-
+









(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses tasksmod))

(declare (uses mt))
(declare (uses common))
;; (declare (uses common))

(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 commonmod
	configfmod




︙







Modified subrunmod.scm
from [ddf54f1377]
to [f63d1179cd].




︙


38
39
40
41
42
43
44
45










46
47
48
49
50
51
52

38
39
40
41
42
43
44

45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61








-
+
+
+
+
+
+
+
+
+
+








(declare (uses mtmod))
(declare (uses megatestmod))
(declare (uses tasksmod))

(use srfi-69)

(module subrunmod
	*
	(
	 subrun:set-state-status
	 subrun:kill-subrun
	 subrun:get-log-path
	 subrun:remove-subrun
	 subrun:subrun-removed?
	 subrun:subrun-test-initialized?
	 subrun:launch-cmd
	 subrun:initialize-toprun-test
	 )

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports




︙







Modified tasksmod.scm
from [381a26e6c2]
to [1d99e1d940].




︙


37
38
39
40
41
42
43









44




45
46
47
48
49
50
51

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








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








(declare (uses pgdb))
(declare (uses mtmod))
(declare (uses megatestmod))

(use srfi-69)

(module tasksmod
	(
	 configf:write-alist
	 common:simple-unlock
	 common:simple-lock
	 tests:test-set-status!
	 common:get-launcher
	 tasks:kill-runner
	 tests:get-testconfig
	 tests:get-waitons
	*

	 tests:get-test-path-from-environment

	 )

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports




︙







Modified tcmt.scm
from [114f35b4de]
to [80d6c74c63].




︙


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

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








-
+












-
+








;;  1. Run the megatest process and pass it all the needed parameters
;;  2. Every five seconds check for state/status changes and print the info
;;

(declare (uses mtargs))
(declare (uses rmt))
(declare (uses rmtmod))
(declare (uses common))
;; (declare (uses common))
;; (declare (uses megatest-version))
(declare (uses commonmod))

(use srfi-1 posix srfi-69 srfi-18 regex defstruct)

(use trace)
;; (trace-call-sites #t)

(import commonmod
	rmtmod
	(prefix mtargs args:))

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

(define origargs (cdr (argv)))
(define remargs (args:get-args
		 (argv)
		 `( "-target"




︙







Modified tcp-transportmod.scm
from [1a862ecee9]
to [8cd3530dc9].




︙


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








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








(declare (uses dbmod))
(declare (uses portlogger))
(declare (uses mtmod))

(use address-info tcp)

(module tcp-transportmod
	*
	(
	 tt:mk-signature
	 tt-state
	 tt:server-process-run
	 tt:make-remote
	 tt-ro-mode-checked-set!
	 tt-ro-mode-set!
	 tt-ro-mode
	 tt-ro-mode-checked
	 tt:handler
	 tt:get-conn
	 )
	
(import scheme)

(cond-expand
 (chicken-4
  (import (prefix sqlite3 sqlite3:)
	  chicken




︙







Modified tdb.scm
from [e7e7aee13a]
to [3c5dc20bcf].




︙


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

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








-
+
















-
+









;;======================================================================
;; Database access
;;======================================================================

(declare (unit tdb))
(declare (uses debugprint))
(declare (uses common))
;; (declare (uses common))
(declare (uses keys))
(declare (uses mt))
(declare (uses commonmod))
(declare (uses mtargs))
(declare (uses rmtmod))

(require-extension (srfi 18) extras tcp)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

(import commonmod
	debugprint
	rmtmod
	(prefix mtargs args:))

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

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




︙







Modified test_records.scm
from [d106f3911c]
to [1501321c72].




︙


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

11
12
13
14
15
16
17



























-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     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/>.

;; make-vector-record tests testqueue testname testconfig waitons priority items
(define (make-tests:testqueue)(make-vector 7 #f))
(define (tests:testqueue-get-testname     vec)    (vector-ref  vec 0))
(define (tests:testqueue-get-testconfig   vec)    (vector-ref  vec 1))
(define (tests:testqueue-get-waitons      vec)    (vector-ref  vec 2))
(define (tests:testqueue-get-priority     vec)    (vector-ref  vec 3))
;; items: #f=no items, list=list of items remaining, proc=need to call to get items
(define (tests:testqueue-get-items        vec)    (vector-ref  vec 4))
(define (tests:testqueue-get-itemdat      vec)    (vector-ref  vec 5))
(define (tests:testqueue-get-item_path    vec)    (vector-ref  vec 6))

(define (tests:testqueue-set-testname!    vec val)(vector-set! vec 0 val))
(define (tests:testqueue-set-testconfig!  vec val)(vector-set! vec 1 val))
(define (tests:testqueue-set-waitons!     vec val)(vector-set! vec 2 val))
(define (tests:testqueue-set-priority!    vec val)(vector-set! vec 3 val))
(define (tests:testqueue-set-items!       vec val)(vector-set! vec 4 val))
(define (tests:testqueue-set-itemdat!     vec val)(vector-set! vec 5 val))
(define (tests:testqueue-set-item_path!   vec val)(vector-set! vec 6 val))









Modified testsmod.scm
from [342c5ad45d]
to [70de32f7f8].




︙


37
38
39
40
41
42
43




44






45
46
47
48
49
50
51

37
38
39
40
41
42
43
44
45
46
47

48
49
50
51
52
53
54
55
56
57
58
59
60








+
+
+
+
-
+
+
+
+
+
+








(declare (uses mtmod))
(declare (uses servermod))
(declare (uses fsmod))

(use srfi-69)

(module testsmod
	(
	 tests:summarize-items
	 tests:filter-non-runnable
	 tests:sort-by-priority-and-waiton
	*

	 tests:summarize-test
	 tests:save-final-status
	 tests:update-central-meta-info
	 tests:set-full-meta-info
	 )

(import scheme)
(cond-expand
 (chicken-4
  
  (import chicken
	  ports




︙


123
124
125
126
127
128
129
130

131
132
133
134
135
136
137

132
133
134
135
136
137
138

139
140
141
142
143
144
145
146








-
+








	rmtmod
	stml2
	mtmod
	servermod
	fsmod
	)

(include "common_records.scm")
;; (include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")
(include "js-path.scm")

(define (init-java-script-lib)




︙







Modified tree.scm
from [5b26f8b9f9]
to [ee0f2b29cf].




︙


33
34
35
36
37
38
39
40
41


42
43
44
45
46
47
48

33
34
35
36
37
38
39


40
41
42
43
44
45
46
47
48








-
-
+
+









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

(import (prefix mtargs args:)
	debugprint)

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

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





︙







Added utils/extract-export-list.sh version [d50045d1ff].

















1
2
3
4
5
6
7
8
9
10
11
12
13

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

#!/bin/bash

LAST_PARENT=foobar

for fn in $(grep 'Warning: refer' typescript |tr '`' ' '|tr "'" " "|awk '{print $7}');do
    PARENT=$(grep $fn *mod.scm|grep define|cut -d: -f1)
    if [[ $PARENT != $LAST_PARENT ]];then
	echo
	echo $PARENT
	LAST_PARENT=$PARENT
    fi
    echo $fn
done











This page was generated in about
0.206s by
Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00