Megatest

Check-in [fd11c410ee]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Improved cache factors for testconfig
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.55
Files: files | file ages | folders
SHA1: fd11c410eeee0ee984a5e0a08b419763b81c3a2e
User & Date: matt on 2013-08-18 16:01:10
Other Links: branch diff | manifest | tags
Context
2013-08-18
22:03
Better support for read-only access to a Megatest area check-in: 439da33084 user: matt tags: v1.55
16:01
Improved cache factors for testconfig check-in: fd11c410ee user: matt tags: v1.55
14:53
Tweaks to triggers implementation. Use caching (dangerous but necessary as performance is terrible otherwise) check-in: db9c121e0f user: matt tags: v1.55
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [5237757a15] to [6f10718538].

︙
70
71
72
73
74
75
76
77
78


79
80
81
82
83
84
85

70
71
72
73
74
75
76


77
78
79
80
81
82
83
84
85








-
-
+
+








(define *run-info-cache*    (make-hash-table)) ;; run info is stable, no need to reget

;; Awful. Please FIXME
(define *env-vars-by-run-id* (make-hash-table))
(define *current-run-name*   #f)

;; Testconfig and runconfig caches. 
(define *testconfigs*       (make-hash-table)) ;; test-id => testconfig
(define *runconfigs*        (make-hash-table)) ;; target  => runconfig
(define *testconfigs*       (make-hash-table)) ;; test-name => testconfig
(define *runconfigs*        (make-hash-table)) ;; target    => runconfig

(define (common:clear-caches)
  (set! *target*             (make-hash-table))
  (set! *keys*               (make-hash-table))
  (set! *keyvals*            (make-hash-table))
  (set! *toptest-paths*      (make-hash-table))
  (set! *test-paths*         (make-hash-table))
︙

Modified launch.scm from [658a0efdee] to [c53205e00d].

︙
176
177
178
179
180
181
182
183

184
185
186
187
188
189
190

176
177
178
179
180
181
182

183
184
185
186
187
188
189
190








-
+








						(loop (+ i 1)))
					      )))))
				 ;; then, if runscript ran ok (or did not get called)
				 ;; do all the ezsteps (if any)
				 (if ezsteps
				     (let* ((testconfig (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here?
					    (ezstepslst (hash-table-ref/default testconfig "ezsteps" '())))
				       (hash-table-set! *testconfigs* test-id testconfig) ;; cached for lazy reads later ...
				       (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ...
				       (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps"))
				       ;; if ezsteps was defined then we are sure to have at least one step but check anyway
				       (if (not (> (length ezstepslst) 0))
					   (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length")
					   (let loop ((ezstep (car ezstepslst))
						      (tal    (cdr ezstepslst))
						      (prevstep #f))
︙

Modified mt.scm from [ff7cd2e663] to [9f3a7e8a6b].

︙
91
92
93
94
95
96
97

98
99
100
101
102
103
104
105

106
107
108
109
110
111
112

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105

106
107
108
109
110
111
112
113








+







-
+








;;======================================================================
;;  T R I G G E R S
;;======================================================================

(define (mt:process-triggers test-id newstate newstatus)
  (let* ((test-dat      (mt:lazy-get-test-info-by-id test-id))
	 (test-rundir   (db:test-get-rundir test-dat))
	 (test-name     (db:test-get-testname test-dat))
	 (tconfig       #f)
	 (state         (if newstate  newstate  (db:test-get-state  test-dat)))
	 (status        (if newstatus newstatus (db:test-get-status test-dat))))
    (if (and (file-exists? test-rundir)
	     (directory? test-rundir))
	(begin
	  (push-directory test-rundir)
	  (set! tconfig (mt:lazy-read-test-config test-dat))
	  (set! tconfig (mt:lazy-read-test-config test-name))
	  (pop-directory)
	  (for-each (lambda (trigger)
		      (let ((cmd  (configf:lookup tconfig "triggers" trigger))
			    (logf (conc  test-rundir "/last-trigger.log")))
			(if cmd
			    (let ((fullcmd (conc "(" cmd " " test-id " " test-rundir " " trigger ") >> " logf " 2>&1")))
			      (debug:print-info 0 "TRIGGERED on " trigger ", running command " fullcmd)
︙
149
150
151
152
153
154
155
156

157
158
159
160
161
162
163
164

















165

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








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


  (let* ((tdat (hash-table-ref/default *test-info* test-id #f)))
    (if (and tdat 
	     (< (current-seconds)(+ (vector-ref tdat 0) 10)))
	(vector-ref tdat 1)
	;; no need to update *test-info* as that is done in cdb:get-test-info-by-id
	(cdb:get-test-info-by-id *runremote* test-id))))

(define (mt:lazy-read-test-config test-dat)
(define (mt:lazy-read-test-config test-name)
  (let* ((test-id     (db:test-get-id test-dat))
	 (test-rundir (db:test-get-rundir test-dat))
	 (tconfig     (hash-table-ref/default *testconfigs* test-id #f)))
    (if tconfig 
	tconfig
	(let ((newtcfg (read-config (conc test-rundir "/testconfig") #f #f))) ;; NOTE: Does NOT run [system ...]
	  (hash-table-set! *testconfigs* test-id newtcfg)
	  newtcfg))))
  (let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
    (if tconf
	tconf
	(let ((test-dirs (tests:get-tests-search-path *configdat*)))
	  (let loop ((hed (car test-dirs))
		     (tal (cdr test-dirs)))
	    (let ((tconfig-file (conc hed "/" test-name "/testconfig")))
	      (if (and (file-exists? tconfig-file)
		       (file-read-access? tconfig-file))
		  (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...]
		    (hash-table-set! *testconfigs* test-name newtcfg)
		    newtcfg)
		  (if (null? tal)
		      (begin
			(debug:print 0 "ERROR: No readable testconfig found for " test-name)
			#f)
		      (loop (car tal)(cdr tal))))))))))

Modified runs.scm from [e0d9d07905] to [21dd6a2f0c].

︙
1216
1217
1218
1219
1220
1221
1222
1223

1224
1225
1226
1227
1228
1229

1230
1231
1232
1233
1234
1235
1236

1216
1217
1218
1219
1220
1221
1222

1223




1224

1225
1226
1227
1228
1229
1230
1231
1232








-
+
-
-
-
-

-
+








     '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)))))

;; Update test_meta for all tests
(define (runs:update-all-test_meta db)
  (let ((test-names (tests:get-valid-tests)))
    (for-each 
     (lambda (test-name)
       (let* ((test-path    (conc *toppath* "/tests/" test-name))
       (let* ((test-conf    (mt:lazy-read-test-config test-name)))
	      (test-configf (conc test-path "/testconfig"))
	      (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	      ;; read configs with tricks turned off (i.e. no system)
	      (test-conf    (if testexists (read-config test-configf #f #f)(make-hash-table))))
	 ;; use the cdb:remote-run instead of passing in db
	 (runs:update-test_meta test-name test-conf)))
	 (if test-conf (runs:update-test_meta test-name test-conf))))
     test-names)))

;; This could probably be refactored into one complex query ...
(define (runs:rollup-run keys runname user keyvals)
  (debug:print 4 "runs:rollup-run, keys: " keys " :runname " runname " user: " user)
  (let* ((db              #f)
	 (new-run-id      (cdb:remote-run db:register-run #f keyvals runname "new" "n/a" user))
︙

Modified tests.scm from [7ecdd42518] to [7cf7299e0f].

︙
486
487
488
489
490
491
492
493
494
495
496
497
498








499
500
501
502
503
504
505

486
487
488
489
490
491
492






493
494
495
496
497
498
499
500
501
502
503
504
505
506
507








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








;; 	     (map (lambda (testp)
;; 		    (last (string-split testp "/")))
;; 		  tests)))))

(define (tests:get-testconfig test-name test-registry system-allowed)
  (let* ((test-path    (hash-table-ref/default test-registry test-name (conc *toppath* "/tests/" test-name)))
	 (test-configf (conc test-path "/testconfig"))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf))))
    (if testexists
	(read-config test-configf #f system-allowed environ-patt: (if system-allowed
								      "pre-launch-env-vars"
								      #f))
	#f)))
	 (testexists   (and (file-exists? test-configf)(file-read-access? test-configf)))
	 (tcfg         (if testexists
			   (read-config test-configf #f system-allowed environ-patt: (if system-allowed
											 "pre-launch-env-vars"
											 #f))
			   #f)))
    (hash-table-set! *testconfigs* test-name tcfg)
    tcfg))
  
;; sort tests by priority and waiton
;; Move test specific stuff to a test unit FIXME one of these days
(define (tests:sort-by-priority-and-waiton test-records)
  (let ((mungepriority (lambda (priority)
			 (if priority
			     (let ((tmp (any->number priority)))
︙

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