Megatest

Artifact [612a4b6ce6]
Login

Artifact 612a4b6ce66edcbb626f331a561f372ddbd54202:



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