1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
|
;; Copyright 2006-2013, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils)
(import (prefix sqlite3 sqlite3:))
(declare (unit mt))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
|
|
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
|
;; Copyright 2006-2013, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
(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 db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
|
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
|
(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 test-rundir ;; #f means no dir set yet
(file-exists? test-rundir)
(directory? test-rundir))
(begin
(push-directory test-rundir)
(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
;; Putting the commandline into ( )'s means no control over the shell.
;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
;; or equivalent. No need to do this. Just run it?
(let ((fullcmd (conc cmd " " test-id " " test-rundir " " trigger "&")))
(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
;;======================================================================
;; speed up for common cases with a little logic
(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
|
>
>
>
>
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
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
|
(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 test-rundir ;; #f means no dir set yet
(file-exists? test-rundir)
(directory? test-rundir))
(call-with-environment-variables
(list (cons "MT_TEST_NAME" test-name)
(cons "MT_TEST_RUN_DIR" test-rundir)
(cons "MT_ITEMPATH" (db:test-get-item-path test-dat)))
(lambda ()
(push-directory test-rundir)
(set! tconfig (mt:lazy-read-test-config test-name))
(for-each (lambda (trigger)
(let ((cmd (configf:lookup tconfig "triggers" trigger))
(logf (conc test-rundir "/last-trigger.log")))
(if cmd
;; Putting the commandline into ( )'s means no control over the shell.
;; stdout and stderr will be caught in the NBFAKE or mt_launch.log files
;; or equivalent. No need to do this. Just run it?
(let ((fullcmd (conc cmd " " test-id " " test-rundir " " trigger "&")))
(debug:print-info 0 "TRIGGERED on " trigger ", running command " fullcmd)
(process-run fullcmd)))))
(list
(conc state "/" status)
(conc state "/")
(conc "/" status)))
(pop-directory))
))))
;;======================================================================
;; S T A T E A N D S T A T U S F O R T E S T S
;;======================================================================
;; speed up for common cases with a little logic
(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
|