Megatest

Check-in [854adfaec7]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Lots of little bugs from the transition fixed
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: 854adfaec70ff1b06765378764090d4bc4830b7f
User & Date: matt on 2014-02-18 18:36:18
Other Links: branch diff | manifest | tags
Context
2014-02-18
19:41
Clean up, removed old references to *runremote* check-in: 7590c8479a user: matt tags: v1.60
18:36
Lots of little bugs from the transition fixed check-in: 854adfaec7 user: matt tags: v1.60
16:58
Moved setting of running state in servers table to slightly later in time in the hopes it will improve server startup reliablitity. check-in: 197e330a65 user: matt tags: v1.60
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified client.scm from [5cb1c0c7dc] to [67235b3676].

︙
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

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








-
-
-
+















-
-
-
+








	(exit 1))
      (let ((server-dat (and run-id (hash-table-ref/default *runremote* run-id #f))))
	(if server-dat
	    (let ((start-res (http-transport:client-connect run-id ;; NB// confusion over server-dat and connection result!
							    (tasks:hostinfo-get-interface server-dat)
							    (tasks:hostinfo-get-port      server-dat))))
	      (if start-res ;; sucessful login?
		  (begin
		    (hash-table-set! *runremote* run-id start-res)
		    start-res)
		  start-res
		  (begin    ;; login failed
		    (hash-table-delete! *runremote* run-id)
		    (open-run-close tasks:server-force-clean-run-record
				    tasks:open-db
				    run-id 
				    (tasks:hostinfo-get-interface server-dat)
				    (tasks:hostinfo-get-port      server-dat))
		    (thread-sleep! 5)
		    (client:setup run-id remaining-tries: (- remaining-tries 1)))))
	    (let* ((server-dat (open-run-close tasks:get-server tasks:open-db run-id)))
	      (if server-dat
		  (let ((start-res (http-transport:client-connect run-id
								  (tasks:hostinfo-get-interface server-dat)
								  (tasks:hostinfo-get-port      server-dat))))
		    (if start-res
			(begin
			  (hash-table-set! *runremote* run-id start-res)
			  start-res)
			start-res
			(begin    ;; login failed
			  (hash-table-delete! *runremote* run-id)
			  (open-run-close tasks:server-force-clean-run-record
					  tasks:open-db
					  run-id 
					  (tasks:hostinfo-get-interface server-dat)
					  (tasks:hostinfo-get-port      server-dat))
︙

Modified common.scm from [8ec6f3bb49] to [98ab0c8aab].

︙
21
22
23
24
25
26
27







28
29
30
31
32
33
34

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








+
+
+
+
+
+
+









(include "common_records.scm")

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

(define getenv get-environment-variable)
(define (safe-setenv key val)
  (if (and (string? val)(string? key))
      (handle-exceptions
       exn
       (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)
       (setenv key val))
      (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))

(define home (getenv "HOME"))
(define user (getenv "USER"))

;; GLOBAL GLETCHES
(define *db-keys* #f)
(define *configinfo* #f)
︙

Modified configf.scm from [363b2b5fd7] to [4398556a5c].

︙
215
216
217
218
219
220
221
222
223
224
225
226
227

228
229
230
231
232
233
234
235

215
216
217
218
219
220
221






222

223
224
225
226
227
228
229








-
-
-
-
-
-
+
-








							  (loop (configf:read-line inp res allow-system) curr-section-name #f #f)))
	       (configf:key-val-pr ( x key unk1 val unk2 ) (let* ((alist   (hash-table-ref/default res curr-section-name '()))
								  (envar   (and environ-patt (string-search (regexp environ-patt) curr-section-name)))
								  (realval (if envar
									       (config:eval-string-in-environment val)
									       val)))
							     (debug:print-info 6 "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
							     (if envar
								 (if (and (string? realval)(string? key))
								     (handle-exceptions
								      exn
								      (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" realval)
								      (setenv key realval))
							     (if envar (safe-setenv key realval))
								     (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" realval)))
							     (hash-table-set! res curr-section-name 
									      (config:assoc-safe-add alist key realval))
							     (loop (configf:read-line inp res allow-system) curr-section-name key #f)))
	       (configf:key-no-val ( x key val)             (let* ((alist   (hash-table-ref/default res curr-section-name '())))
							      (hash-table-set! res curr-section-name 
									       (config:assoc-safe-add alist key #t))
							      (loop (configf:read-line inp res allow-system) curr-section-name key #f)))
︙

Modified lock-queue.scm from [a9f4c5425b] to [e008712ec5].

︙
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

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








+
+
+
+
-
-
-
+
+
+


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








              test_id    INTEGER,
              run_lock   TEXT,
              CONSTRAINT runlock_constraint UNIQUE (run_lock));")))
    (sqlite3:set-busy-handler! db handler)
    db))

(define (lock-queue:set-state db test-id newstate)
  (handle-exceptions
   exn
   (thread-sleep! 30)
   (lock-queue:set-state db test-id newstate)
  (sqlite3:execute db "UPDATE queue SET state=? WHERE test_id=?;"
		   newstate
		   test-id))
   (sqlite3:execute db "UPDATE queue SET state=? WHERE test_id=?;"
		    newstate
		    test-id)))

(define (lock-queue:any-younger? db mystart test-id)
  (handle-exceptions
   exn
   (thread-sleep! 30)
   (lock-queue:any-younger? db mystart test-id)
  (let ((res #f))
    (sqlite3:for-each-row
     (lambda (tid)
       ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as 
       (if (not (equal? tid test-id)) 
	   (set! res tid)))
     db
     "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
    res))
   (let ((res #f))
     (sqlite3:for-each-row
      (lambda (tid)
	;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as 
	(if (not (equal? tid test-id)) 
	    (set! res tid)))
      db
      "SELECT test_id FROM queue WHERE start_time > ?;" mystart)
     res)))

(define (lock-queue:get-lock db test-id)
  (let ((res       #f)
	(lckqry    (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';"))
	(mklckqry  (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');")))
    (let ((result 
	   (handle-exceptions
︙

Modified megatest.scm from [7c47c73e54] to [b4a28c1ffe].

︙
937
938
939
940
941
942
943
944

945
946
947
948
949
950
951

937
938
939
940
941
942
943

944
945
946
947
948
949
950
951








-
+








		;; (cdb:test-set-log! *runremote* test-id (sdb:qry 'getid logfname))))
		(rmt:test-set-log! run-id test-id logfname)))
	  (if (args:get-arg "-set-toplog")
	      ;; DO NOT run remote
	      (tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
	  (if (args:get-arg "-summarize-items")
	      ;; DO NOT run remote
	      (tests:summarize-items db run-id test-id test-name #t)) ;; do force here
	      (tests:summarize-items run-id test-id test-name #t)) ;; do force here
	  (if (args:get-arg "-runstep")
	      (if (null? remargs)
		  (begin
		    (debug:print 0 "ERROR: nothing specified to run!")
		    (if db (sqlite3:finalize! db))
		    (exit 6))
		  (let* ((stepname   (args:get-arg "-runstep"))
︙

Modified runconfig.scm from [ddd98be244] to [4e3a96ccb1].

︙
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

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








-
+













-
+








	 (sections (list "default" thekey)))
    (if (not *target*)(set! *target* thekey)) ;; may save a db access or two but repeats db:get-target code
    (debug:print 4 "Using key=\"" thekey "\"")

    (if change-env
	(for-each ;; NB// This can be simplified with new content of keyvals having all that is needed.
	 (lambda (keyval)
	   (setenv (car keyval)(cadr keyval)))
	   (safe-setenv (car keyval)(cadr keyval)))
	 keyvals))
	
    (for-each 
     (lambda (section)
       (let ((section-dat (hash-table-ref/default confdat section #f)))
	 (if section-dat
	     (for-each 
	      (lambda (envvar)
		(let ((val (cadr (assoc envvar section-dat))))
		(hash-table-set! whatfound section (+ (hash-table-ref/default whatfound section 0) 1))
		(if (and (string? envvar)
			 (string? val)
			 change-env)
		    (setenv envvar val))
		    (safe-setenv envvar val))
		(hash-table-set! finaldat envvar val)))
	      (map car section-dat)))))
     sections)
    (if already-seen
	(begin
	  (debug:print 2 "Key settings found in runconfig.config:")
	  (for-each (lambda (fullkey)
︙

Modified runs.scm from [d850da5471] to [f4abbaad2e].

︙
82
83
84
85
86
87
88
89

90
91
92
93
94
95
96

82
83
84
85
86
87
88

89
90
91
92
93
94
95
96








-
+








	  (debug:print 0 "ERROR: [" (args:get-arg "-reqtarg") "] not found in " runconfigf)
	  (if db (sqlite3:finalize! db))
	  (exit 1)))
    ;; Now have runconfigs data loaded, set environment vars
    (for-each (lambda (section)
		(for-each (lambda (varval)
			    (set! envdat (append envdat (list varval)))
			    (setenv (car varval)(cadr varval)))
			    (safe-setenv (car varval)(cadr varval)))
			  (configf:get-section runconfig section)))
	      (list "default" target))
    (vector target runname testpatt keys keyvals envdat mconfig runconfig serverdat transport db toppath run-id)))

(define (set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f))
  (let* ((target      (or (args:get-arg "-reqtarg")
			  (args:get-arg "-target")
︙
108
109
110
111
112
113
114
115
116
117

118
119
120
121
122
123
124
125

108
109
110
111
112
113
114



115

116
117
118
119
120
121
122








-
-
-
+
-








	     (hash-table-set! vals (car key) (cadr key)))
	   keyvals)))
    ;; from the cached data set the vars
    (hash-table-for-each
     vals
     (lambda (key val)
       (debug:print 2 "setenv " key " " val)
       (if (and (string? key)
		(string? val))
	   (setenv key val)
       (safe-setenv key val)))
	   (debug:print 0 "ERROR: Malformed environment variable definition: var=" var ", val=" val))))
    (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target))
    (alist->env-vars (hash-table-ref/default *configdat* "env-override" '()))
    ;; Lets use this as an opportunity to put MT_RUNNAME in the environment
    (let ((runname  (if inrunname inrunname (rmt:get-run-name-from-id run-id))))
      (if runname
	  (setenv "MT_RUNNAME" runname)
	  (debug:print 0 "ERROR: no value for runname for id " run-id)))
︙
1152
1153
1154
1155
1156
1157
1158
1159

1160
1161
1162
1163
1164
1165
1166

1149
1150
1151
1152
1153
1154
1155

1156
1157
1158
1159
1160
1161
1162
1163








-
+








	 (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) ;; KILLED))
	((LAUNCHED REMOTEHOSTSTART RUNNING)  
	 (if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
				       (db:test-get-run_duration testdat)))
		600) ;; i.e. no update for more than 600 seconds
	     (begin
	       (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
	       (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f))
	       (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f))
	     (debug:print 2 "NOTE: " test-name " is already running")))
	(else      
	 (debug:print 0 "ERROR: Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat))
	 (case (string->symbol (test:get-state testdat)) 
	   ((COMPLETED INCOMPLETE)
	    (hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN))
	   (else
︙

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