Megatest

Diff
Login

Differences From Artifact [847075e4b1]:

To Artifact [ff7cd2e663]:


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
;;======================================================================
;;  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))
	 (tconfig       #f))


    (if (and (file-exists? test-rundir)
	     (directory? test-rundir))
	(begin
	  (push-directory test-rundir)
	  (set! tconfig (mt:lazy-read-test-config test-dat))
	  (pop-directory)
	  (for-each (lambda (trigger)
		      (let ((cmd  (configf:lookup tconfig "triggers" trigger))
			    (logf (conc  test-rundir "/last-trigger.log")))
			(if cmd
			    (system (conc "(" cmd " " test-id " " test-rundir " " trigger ") >> " logf " 2>&1")))))


		    (list
		     (conc newstate "/" newstatus)
		     (conc newstate "/")
		     (conc "/" newstatus)))))))
    
;;======================================================================
;;  S T A T E   A N D   S T A T U S   F O R   T E S T S 
;;======================================================================

(define (mt:roll-up-pass-fail-counts run-id test-name item-path status)
  (if (and (not (equal? item-path ""))
	   (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))







|
>
>










|
>
>

|
|
|
|







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
;;======================================================================
;;  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))
	 (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))
	  (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)
			      (process-run fullcmd)))))
		    (list
		     (conc state "/" status)
		     (conc state "/")
		     (conc "/" status)))))))

;;======================================================================
;;  S T A T E   A N D   S T A T U S   F O R   T E S T S 
;;======================================================================

(define (mt:roll-up-pass-fail-counts run-id test-name item-path status)
  (if (and (not (equal? item-path ""))
	   (member status '("PASS" "WARN" "FAIL" "WAIVED" "RUNNING" "CHECK" "SKIP")))
138
139
140
141
142
143
144
145
146

147
148
149
150
151
152
153
154
155
156
157
158
159
160
    (if newstate   (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id))
    (if newstatus  (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id))
    (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id))))
   (mt:process-triggers test-id newstate newstatus)
   #t)

(define (mt:lazy-get-test-info-by-id test-id)
  (let ((tdat (hash-table-ref/default *test-info* test-id #f)))
    (if tdat 

	tdat
	;; 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)
  (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))))








|
|
>
|













142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
    (if newstate   (cdb:client-call *runremote* 'set-test-state #t *default-numtries* newstate test-id))
    (if newstatus  (cdb:client-call *runremote* 'set-test-status #t *default-numtries* newstatus test-id))
    (if newcomment (cdb:client-call *runremote* 'set-test-comment #t *default-numtries* newcomment test-id))))
   (mt:process-triggers test-id newstate newstatus)
   #t)

(define (mt:lazy-get-test-info-by-id test-id)
  (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)
  (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))))