;; Copyright 2006-2012, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use srfi-1 posix regex srfi-69 directory-utils)
(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
;;(rmt:get-test-info-by-id run-id test-id) -> testdat
(define (ezsteps:run-from testdat start-step-name run-one)
;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test
(let* ((test-run-dir ;; (filedb:get-path *fdb*
(db:test-get-rundir testdat)) ;; )
(testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars"))
(ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))
(run-mutex (make-mutex))
(rollup-status 0)
(rollup-status-string #f)
(rollup-status-sym #f)
(exit-info (vector #t #t #t))
(test-id (db:test-get-id testdat))
(run-id (db:test-get-run_id testdat))
(test-name (db:test-get-testname testdat))
(kill-job #f)) ;; for future use (on re-factoring with launch.scm code
;; keep trying till NFS deigns to populate test run dir on this host
(let loop ((count 5))
(if (common:file-exists? test-run-dir)
(push-directory test-run-dir)
(if (> count 0)
(begin
(debug:print 0 *default-log-port* "WARNING: ezsteps attempting to run but test run directory " test-run-dir " is not there. Waiting and trying again " count " more times")
(sleep 3)
(loop (- count 1))))))
(debug:print-info 0 *default-log-port* "Running in directory " test-run-dir)
(if (not (common: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))
(message-window "ERROR: You can only re-run steps defined via ezsteps")
(begin
(let loop ((ezstep (car ezstepslst))
(tal (cdr ezstepslst))
(status-sym-so-far 'pass)
(prevstep "-")
;;(runflag #f)
(saw-start-step-name #f)) ;; flag used to skip steps when not starting at the beginning
(if (vector-ref exit-info 1)
(let* ((stepname (car ezstep)) ;; do stuff to run the step
(logpro-used (common:file-exists? (conc stepname ".logpro")))
(stepinfo (cadr ezstep))
(stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo))
(stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each
(stepcmd (list-ref stepparts 3))
(script (conc "mt_ezstep " stepname " " prevstep " " stepcmd)) ;; call the command using mt_ezstep
(saw-start-step-name-next (or saw-start-step-name (equal? stepname start-step-name)))
(proceed-with-this-step
(or (not start-step-name)
(equal? stepname start-step-name)
(and saw-start-step-name (not run-one))
saw-start-step-name-next
(and start-step-name (equal? stepname start-step-name)))))
(cond
((and (not proceed-with-this-step) (null? tal))
'done)
((not proceed-with-this-step)
(loop (car tal)
(cdr tal)
status-sym-so-far
stepname
;; #f
saw-start-step-name-next)))
(debug:print 4 *default-log-port* "ezsteps:\n stepname: " stepname " stepinfo: " stepinfo " stepparts: " stepparts
" stepparms: " stepparms " stepcmd: " stepcmd)
(debug:print 4 *default-log-port* "script: " script)
(rmt:teststep-set-status! run-id test-id stepname "start" "-" #f #f)
;; now launch the script
(let ((pid (process-run script)))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! run-mutex)
(vector-set! exit-info 0 pid)
(vector-set! exit-info 1 exit-status)
(vector-set! exit-info 2 exit-code)
(mutex-unlock! run-mutex)
(if (eq? pid-val 0)
(begin
(thread-sleep! 1)
(processloop (+ i 1))))
))
(let ((exinfo (vector-ref exit-info 2))
(logfna (if logpro-used (conc stepname ".html") "")))
(rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna))
(if logpro-used
(rmt:test-set-log! run-id test-id (conc stepname ".html")))
;; set the test final status
(let* ((this-step-status (cond
(logpro-used
(common:logpro-exit-code->status-sym (vector-ref exit-info 2)))
((eq? (vector-ref exit-info 2) 0)
'pass)
(else
'fail)))
(overall-status-sym (common:worse-status-sym this-step-status status-sym-so-far))
(overall-status-string (status-sym->string overall-status-sym)))
(debug:print 4 *default-log-port* "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used
" this-step-status: " this-step-status " overall-status: " overall-status-sym)
;;" next-status: " next-status " rollup-status: " rollup-status)
(set! rollup-status-string overall-status-string)
(set! rollup-status-sym overall-status-sym)
(tests:test-set-status! run-id test-id "RUNNING" overall-status-string #f #f)))
(if (and
(not run-one)
(common:steps-can-proceed-given-status-sym rollup-status-sym)
(not (null? tal)))
(loop (car tal)
(cdr tal)
rollup-status-sym
stepname
;; #f
saw-start-step-name-next)))
;; (if (and (steprun-good? logpro-used (vector-ref exit-info 2))
;; (not (null? tal)))
;; (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop
;; (loop (car tal) (cdr tal) stepname runflag))))
(debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep)))
;; Once done with step/steps update the test record
;;
(let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat))
(testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr
;; Am I completed?
(if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED"))
(let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status
;; "COMPLETED"
;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test
)
(new-status rollup-status-string)
;; (new-status (cond ;; bjbarcla -- what is this AUTO business??
;; ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run
;; ((eq? rollup-status 0)
;; ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO)
;; (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS"))
;; ((eq? rollup-status 1) "FAIL")
;; ((eq? rollup-status 2)
;; ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN)
;; (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN"))
;; (else "FAIL")))
) ;; (db:test-get-status testinfo)))
(debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
(tests:test-set-status! run-id test-id
new-state
new-status
(args:get-arg "-m") #f)
;; need to update the top test record if PASS or FAIL and this is a subtest
(if (not (equal? item-path ""))
(rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status #f))))
;; for automated creation of the rollup html file this is a good place...
(if (not (equal? item-path ""))
(tests:summarize-items run-id test-id test-name #f)) ;; don't force - just update if no
)))
(pop-directory)
rollup-status-string))
(define (ezsteps:spawn-run-from testdat start-step-name run-one)
(thread-start!
(make-thread
(lambda ()
(ezsteps:run-from testdat start-step-name run-one))
(conc "ezstep run single step " start-step-name " run-one="run-one)))
)