Megatest

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

Changes In Branch network-only-transport Through [c6cee5cbb1] Excluding Merge-Ins

This is equivalent to a diff from b93e6887b8 to c6cee5cbb1

2013-03-06
15:38
Merged network-only-transport and bumped version to v1.53 check-in: 962322e080 user: mrwellan tags: trunk, v1.53
2013-03-04
22:27
Disabled fs and got zmq working again (I think) check-in: 9bf6d9d0fe user: matt tags: network-only-transport
2013-02-28
23:28
Converted couple more calls in runs.scm to full remote check-in: c6cee5cbb1 user: matt tags: network-only-transport
23:08
Converted dashboard to remote calls check-in: c1e7692bac user: matt tags: network-only-transport
16:40
Removed all traces of itempath check-in: b93e6887b8 user: mrwellan tags: trunk
2013-02-26
22:18
Added server start to Makefile check-in: c4982d7367 user: matt tags: trunk

Modified dashboard.scm from [9fce501c6a] to [6cbe46c740].

︙
54
55
56
57
58
59
60
61

62
63
64
65
66
67
68

54
55
56
57
58
59
60

61
62
63
64
65
66
67
68








-
+








;; process args
(define remargs (args:get-args 
		 (argv)
		 (list  "-rows"
			"-run"
			"-test"
			"-debug"
			"-server" 
			"-host" 
			) 
		 (list  "-h"
			"-guimonitor"
			"-main"
			"-v"
			"-q"
		       )
︙
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

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








-
+

-
-
+
+
+








-
+
+









-
+








(if (not (setup-for-run))
    (begin
      (print "Failed to find megatest.config, exiting") 
      (exit 1)))

(define *db* #f) ;; (open-db))

(if (args:get-arg "-server")
(if (args:get-arg "-host")
    (begin
      (set! *runremote* (string-split (args:get-arg "-server" ":")))
      (server:client-launch)))
      (set! *runremote* (string-split (args:get-arg "-host" ":")))
      (server:client-launch))
    (server:client-launch))

;; HACK ALERT: this is a hack, please fix.
(define *read-only* (not (file-read-access? (conc *toppath* "/megatest.db"))))
;; (server:client-setup *db*)

(define toplevel #f)
(define dlg      #f)
(define max-test-num 0)
(define *keys*   (open-run-close db:get-keys #f))
;; (define *keys*   (open-run-close db:get-keys #f))
(define *keys*   (cdb:remote-run db:get-keys #f))
;; (define *keys*   (db:get-keys   *db*))
(define *dbkeys*  (map (lambda (x)(vector-ref x 0))
		      (append *keys* (list (vector "runname" "blah")))))
(define *header*       #f)
(define *allruns*     '())
(define *buttondat*    (make-hash-table)) ;; <run-id color text test run-key>
(define *alltestnamelst* '())
(define *searchpatts*  (make-hash-table))
(define *num-runs*      8)
(define *tot-run-count* (open-run-close db:get-num-runs #f "%"))
(define *tot-run-count* (cdb:remote-run db:get-num-runs #f "%"))
;; (define *tot-run-count* (db:get-num-runs *db* "%"))
(define *last-update*   (current-seconds))
(define *num-tests*     15)
(define *start-run-offset*  0)
(define *start-test-offset* 0)
(define *examine-test-dat* (make-hash-table))
(define *exit-started* #f)
︙
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

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








-
+















-
+

-
+








		 (> (current-seconds)(+ *last-db-update-time* 5)))
	    (> *delayed-update* 0))
	(begin
	  (debug:print-info 4 "update-rundat runnamepatt: " runnamepatt " numruns: " numruns " testnamepatt: " testnamepatt " keypatts: " keypatts)
	  (set! *please-update-buttons* #t)
	  (set! *last-db-update-time* modtime)
	  (set! *delayed-update* (- *delayed-update* 1))
	  (let* ((allruns     (open-run-close db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
	  (let* ((allruns     (cdb:remote-run db:get-runs #f runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2))
					   *start-run-offset* keypatts))
		 (header      (db:get-header allruns))
		 (runs        (db:get-rows   allruns))
		 (result      '())
		 (maxtests    0)
		 (states      (hash-table-keys *state-ignore-hash*))
		 (statuses    (hash-table-keys *status-ignore-hash*)))
	    ;; (thread-sleep! 0.1) ;; give some time to other threads
	    (debug:print 6 "update-rundat, got " (length runs) " runs")
	    (if (> (+ *last-update* 300) (current-seconds)) ;; every five minutes
		(begin
		  (set! *last-update* (current-seconds))
		  (set! *tot-run-count* (length runs)))) ;; (rdb:get-num-runs *db* runnamepatt))))
	    (for-each (lambda (run)
			(let* ((run-id   (db:get-value-by-header run header "id"))
			       (tests    (let ((tsts (open-run-close db:get-tests-for-run #f run-id testnamepatt states statuses)))
			       (tests    (let ((tsts (cdb:remote-run db:get-tests-for-run #f run-id testnamepatt states statuses)))
					   (if *tests-sort-reverse* (reverse tsts) tsts)))
			       (key-vals (open-run-close db:get-key-vals #f run-id)))
			       (key-vals (cdb:remote-run db:get-key-vals #f run-id)))
			  (if (> (length tests) maxtests)
			      (set! maxtests (length tests)))
			  (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set
				  (not (null? tests)))
			      (set! result (cons (vector run tests key-vals) result)))))
		      runs)
	    (set! *header*  header)
︙
641
642
643
644
645
646
647
648

649
650
651
652
653
654
655

643
644
645
646
647
648
649

650
651
652
653
654
655
656
657








-
+








 ((args:get-arg "-run")
  (let ((runid (string->number (args:get-arg "-run"))))
    (if runid
	(begin
	  (lambda (x)
	    (on-exit (lambda ()
		       (if *db* (sqlite3:finalize! *db*))))
	    (open-run-close examine-run *db* runid)))
	    (cdb:remote-run examine-run *db* runid)))
	(begin
	  (print "ERROR: runid is not a number " (args:get-arg "-run"))
	  (exit 1)))))
 ((args:get-arg "-test")
    (let ((testid (string->number (args:get-arg "-test"))))
    (if testid
	(examine-test testid)
︙

Modified launch.scm from [9c1957ce23] to [9d5e223a7b].

︙
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

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








+
+














+
+








	       (target    (assoc/default 'target    cmdinfo))
	       (itemdat   (assoc/default 'itemdat   cmdinfo))
	       (env-ovrd  (assoc/default 'env-ovrd  cmdinfo))
	       (set-vars  (assoc/default 'set-vars  cmdinfo)) ;; pre-overrides from -setvar
	       (runname   (assoc/default 'runname   cmdinfo))
	       (megatest  (assoc/default 'megatest  cmdinfo))
	       (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
	       (keys      #f)
	       (keyvals   #f)
	       (fullrunscript (if (not runscript)
                                  #f
                                  (if (substring-index "/" runscript)
                                      runscript ;; use unadultered if contains slashes
                                      (let ((fulln (conc testpath "/" runscript)))
	                                  (if (and (file-exists? fulln)
                                                   (file-execute-access? fulln))
                                              fulln
                                              runscript))))) ;; assume it is on the path
	       (rollup-status 0))
	  (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name))
	  ;; Setup the *runremote* global var
	  (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time"))
	  (set! *runremote* runremote)
	  (set! keys       (cdb:remote-run db:get-keys #f))
	  (set! keyvals    (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f))
	  ;; apply pre-overrides before other variables. The pre-override vars must not
	  ;; clobbers things from the official sources such as megatest.config and runconfigs.config
	  (if (string? set-vars)
	      (let ((varpairs (string-split set-vars ",")))
		(debug:print 4 "varpairs: " varpairs)
		(map (lambda (varpair)
		       (let ((varval (string-split varpair "=")))
︙
115
116
117
118
119
120
121
122

123
124
125
126
127
128
129

119
120
121
122
123
124
125

126
127
128
129
130
131
132
133








-
+








	  ;; Can setup as client for server mode now
	  (server:client-setup)

	  (change-directory *toppath*) 
	  (set-megatest-env-vars run-id) ;; these may be needed by the launching process
	  (change-directory work-area) 

	  (open-run-close set-run-config-vars #f run-id)
	  (open-run-close set-run-config-vars #f run-id keys keyvals)
	  ;; environment overrides are done *before* the remaining critical envars.
	  (alist->env-vars env-ovrd)
	  (set-megatest-env-vars run-id)
	  (set-item-env-vars itemdat)
	  (save-environment-as-files "megatest")
	  (open-run-close test-set-meta-info #f test-id run-id test-name itemdat 0)
	  (tests:test-set-status! test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
︙

Modified runconfig.scm from [e60c2bb3c8] to [09fb252607].

︙
8
9
10
11
12
13
14
15
16
17




18
19
20
21
22
23
24

8
9
10
11
12
13
14



15
16
17
18
19
20
21
22
23
24
25








-
-
-
+
+
+
+








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

(include "common_records.scm")



(define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f)(change-env #t))
  (let* ((keys    (db:get-keys db))
	 (keyvals (if run-id (db:get-key-vals db run-id) #f))
;; (define (setup-env-defaults db fname run-id already-seen #!key (environ-patt #f)(change-env #t))
(define (setup-env-defaults fname run-id already-seen keys keyvals #!key (environ-patt #f)(change-env #t))
  (let* (;; (keys    (db:get-keys db))
	 ;; (keyvals (if run-id (db:get-key-vals db run-id) #f))
	 (thekey  (if keyvals (string-intersperse (map (lambda (x)(if x x "-na-")) keyvals) "/")
		      (if (args:get-arg "-reqtarg") 
			  (args:get-arg "-reqtarg")
			  (if (args:get-arg "-target")
			      (args:get-arg "-target")
			      (begin
				(debug:print 0 "ERROR: setup-env-defaults called with no run-id or -target or -reqtarg")
︙
56
57
58
59
60
61
62
63

64
65
66
67
68

69
70
71
72




73
74

57
58
59
60
61
62
63

64
65
66
67
68
69
70




71
72
73
74
75
76








-
+





+
-
-
-
-
+
+
+
+



	  (for-each (lambda (fullkey)
		      (debug:print 2 (format #f "~20a ~a\n" fullkey (hash-table-ref/default whatfound fullkey 0))))
		    sections)
	  (debug:print 2 "---")
	  (set! *already-seen-runconfig-info* #t)))
    finaldat))

(define (set-run-config-vars db run-id)
(define (set-run-config-vars db run-id keys keyvals)
  (let ((runconfigf (conc  *toppath* "/runconfigs.config"))
	(targ       (or (args:get-arg "-target")
			(args:get-arg "-reqtarg")
			(db:get-target db run-id))))
    (if (file-exists? runconfigf)
	(setup-env-defaults runconfigf run-id #t keys keyvals
	(setup-env-defaults db runconfigf run-id #t environ-patt: (conc "(default"
									(if targ
									    (conc "|" targ ")")
									    ")")))
			    environ-patt: (conc "(default"
						(if targ
						    (conc "|" targ ")")
						    ")")))
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))))

Modified runs.scm from [1aa6b158e4] to [7ba96bae1f].

︙
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

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








+










-
+








;;            
(define (runs:run-tests target runname test-names test-patts user flags)
  (common:clear-caches) ;; clear all caches
  (let* ((db          #f)
	 (keys        (cdb:remote-run db:get-keys #f))
	 (keyvallst   (keys:target->keyval keys target))
	 (run-id      (cdb:remote-run runs:register-run #f keys keyvallst runname "new" "n/a" user))  ;;  test-name)))
	 (keyvals     (if run-id (cdb:remote-run db:get-key-vals #f run-id) #f))
	 (deferred    '()) ;; delay running these since they have a waiton clause
	 ;; keepgoing is the defacto modality now, will add hit-n-run a bit later
	 ;; (keepgoing   (hash-table-ref/default flags "-keepgoing" #f))
	 (runconfigf   (conc  *toppath* "/runconfigs.config"))
	 (required-tests '())
	 (test-records (make-hash-table)))

    (set-megatest-env-vars run-id) ;; these may be needed by the launching process

    (if (file-exists? runconfigf)
	(open-run-close setup-env-defaults db runconfigf run-id *already-seen-runconfig-info* "pre-launch-env-vars")
	(setup-env-defaults runconfigf run-id *already-seen-runconfig-info* keys keyvals "pre-launch-env-vars")
	(debug:print 0 "WARNING: You do not have a run config file: " runconfigf))
    
    ;; look up all tests matching the comma separated list of globs in
    ;; test-patts (using % as wildcard)

    (set! test-names (tests:get-valid-tests *toppath* test-names))
    (set! test-names (delete-duplicates test-names))
︙

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