File Annotation
Not logged in
ae6dbecf17 2011-05-02          matt: 
ae6dbecf17 2011-05-02          matt: ;; Copyright 2006-2011, Matthew Welland.
ae6dbecf17 2011-05-02          matt: ;;
ae6dbecf17 2011-05-02          matt: ;;  This program is made available under the GNU GPL version 2.0 or
ae6dbecf17 2011-05-02          matt: ;;  greater. See the accompanying file COPYING for details.
ae6dbecf17 2011-05-02          matt: ;;
ae6dbecf17 2011-05-02          matt: ;;  This program is distributed WITHOUT ANY WARRANTY; without even the
ae6dbecf17 2011-05-02          matt: ;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
ae6dbecf17 2011-05-02          matt: ;;  PURPOSE.
ae6dbecf17 2011-05-02          matt: 
ae6dbecf17 2011-05-02          matt: ;;======================================================================
ae6dbecf17 2011-05-02          matt: ;; launch a task - this runs on the originating host, tests themselves
ae6dbecf17 2011-05-02          matt: ;;
ae6dbecf17 2011-05-02          matt: ;;======================================================================
ae6dbecf17 2011-05-02          matt: 
e0c173490e 2011-10-09          matt: (use regex regex-case base64 sqlite3)
3469edbbf7 2011-10-09          matt: (import (prefix base64 base64:))
e0c173490e 2011-10-09          matt: (import (prefix sqlite3 sqlite3:))
3469edbbf7 2011-10-09          matt: 
3469edbbf7 2011-10-09          matt: (declare (unit launch))
3469edbbf7 2011-10-09          matt: (declare (uses common))
3469edbbf7 2011-10-09          matt: (declare (uses configf))
3469edbbf7 2011-10-09          matt: (declare (uses db))
3469edbbf7 2011-10-09          matt: 
3469edbbf7 2011-10-09          matt: (include "common_records.scm")
3469edbbf7 2011-10-09          matt: (include "key_records.scm")
3469edbbf7 2011-10-09          matt: (include "db_records.scm")
37589f80eb 2011-10-09          matt: 
37589f80eb 2011-10-09          matt: (define (launch:execute encoded-cmd)
37589f80eb 2011-10-09          matt:   (let* ((cmdinfo   (read (open-input-string (base64:base64-decode encoded-cmd)))))
37589f80eb 2011-10-09          matt:     (setenv "MT_CMDINFO" encoded-cmd)
37589f80eb 2011-10-09          matt:     (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1))
37589f80eb 2011-10-09          matt: 	(let* ((testpath  (assoc/default 'testpath  cmdinfo))
37589f80eb 2011-10-09          matt: 	       (work-area (assoc/default 'work-area cmdinfo))
37589f80eb 2011-10-09          matt: 	       (test-name (assoc/default 'test-name cmdinfo))
37589f80eb 2011-10-09          matt: 	       (runscript (assoc/default 'runscript cmdinfo))
37589f80eb 2011-10-09          matt: 	       (db-host   (assoc/default 'db-host   cmdinfo))
37589f80eb 2011-10-09          matt: 	       (run-id    (assoc/default 'run-id    cmdinfo))
37589f80eb 2011-10-09          matt: 	       (itemdat   (assoc/default 'itemdat   cmdinfo))
37589f80eb 2011-10-09          matt: 	       (env-ovrd  (assoc/default 'env-ovrd  cmdinfo))
37589f80eb 2011-10-09          matt: 	       (runname   (assoc/default 'runname   cmdinfo))
37589f80eb 2011-10-09          matt: 	       (megatest  (assoc/default 'megatest  cmdinfo))
37589f80eb 2011-10-09          matt: 	       (mt-bindir-path (assoc/default 'mt-bindir-path cmdinfo))
37589f80eb 2011-10-09          matt: 	       (fullrunscript (conc testpath "/" runscript))
37589f80eb 2011-10-09          matt: 	       (db        #f))
37589f80eb 2011-10-09          matt: 	  (debug:print 2 "Exectuing " test-name " on " (get-host-name))
37589f80eb 2011-10-09          matt: 	  (change-directory testpath)
37589f80eb 2011-10-09          matt: 	  (setenv "MT_TEST_RUN_DIR" work-area)
37589f80eb 2011-10-09          matt: 	  (setenv "MT_TEST_NAME" test-name)
37589f80eb 2011-10-09          matt: 	  (setenv "MT_ITEM_INFO" (conc itemdat))
37589f80eb 2011-10-09          matt: 	  (setenv "MT_RUNNAME"   runname)
37589f80eb 2011-10-09          matt: 	  (setenv "MT_MEGATEST"  megatest)
37589f80eb 2011-10-09          matt: 	  (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path)))
37589f80eb 2011-10-09          matt: 
37589f80eb 2011-10-09          matt: 	  (if (not (setup-for-run))
37589f80eb 2011-10-09          matt: 	      (begin
37589f80eb 2011-10-09          matt: 		(debug:print 0 "Failed to setup, exiting")
37589f80eb 2011-10-09          matt: 		(exit 1)))
37589f80eb 2011-10-09          matt: 	  ;; now can find our db
37589f80eb 2011-10-09          matt: 	  (set! db (open-db))
37589f80eb 2011-10-09          matt: 	  (change-directory work-area)
37589f80eb 2011-10-09          matt: 	  (set-run-config-vars db run-id)
37589f80eb 2011-10-09          matt: 	  ;; environment overrides are done *before* the remaining critical envars.
37589f80eb 2011-10-09          matt: 	  (alist->env-vars env-ovrd)
37589f80eb 2011-10-09          matt: 	  (set-megatest-env-vars db run-id)
37589f80eb 2011-10-09          matt: 	  (set-item-env-vars itemdat)
37589f80eb 2011-10-09          matt: 	  (save-environment-as-files "megatest")
37589f80eb 2011-10-09          matt: 	  (test-set-meta-info db run-id test-name itemdat)
37589f80eb 2011-10-09          matt: 	  (test-set-status! db run-id test-name "REMOTEHOSTSTART" "n/a" itemdat (args:get-arg "-m") #f)
37589f80eb 2011-10-09          matt: 	  (if (args:get-arg "-xterm")
37589f80eb 2011-10-09          matt: 	      (set! fullrunscript "xterm")
37589f80eb 2011-10-09          matt: 	      (if (not (file-execute-access? fullrunscript))
37589f80eb 2011-10-09          matt: 		  (system (conc "chmod ug+x " fullrunscript))))
37589f80eb 2011-10-09          matt: 	  ;; We are about to actually kick off the test
37589f80eb 2011-10-09          matt: 	  ;; so this is a good place to remove the records for
37589f80eb 2011-10-09          matt: 	  ;; any previous runs
37589f80eb 2011-10-09          matt: 	  ;; (db:test-remove-steps db run-id testname itemdat)
37589f80eb 2011-10-09          matt: 
37589f80eb 2011-10-09          matt: 	  ;; from here on out we will open and close the db
37589f80eb 2011-10-09          matt: 	  ;; on every access to reduce the probablitiy of
37589f80eb 2011-10-09          matt: 	  ;; contention or stuck access on nfs.
37589f80eb 2011-10-09          matt: 	  (sqlite3:finalize! db)
37589f80eb 2011-10-09          matt: 
37589f80eb 2011-10-09          matt: 	  (let* ((m            (make-mutex))
37589f80eb 2011-10-09          matt: 		 (kill-job?    #f)
37589f80eb 2011-10-09          matt: 		 (exit-info    (make-vector 3))
37589f80eb 2011-10-09          matt: 		 (job-thread   #f)
37589f80eb 2011-10-09          matt: 		 (runit        (lambda ()
37589f80eb 2011-10-09          matt: 				 ;; (let-values
37589f80eb 2011-10-09          matt: 				 ;;  (((pid exit-status exit-code)
37589f80eb 2011-10-09          matt: 				 ;;    (run-n-wait fullrunscript)))
37589f80eb 2011-10-09          matt: 				 (let ((pid (process-run fullrunscript)))
37589f80eb 2011-10-09          matt: 				   (let loop ((i 0))
37589f80eb 2011-10-09          matt: 				     (let-values
37589f80eb 2011-10-09          matt: 				      (((pid-val exit-status exit-code) (process-wait pid #t)))
37589f80eb 2011-10-09          matt: 				      (mutex-lock! m)
37589f80eb 2011-10-09          matt: 				      (vector-set! exit-info 0 pid)
37589f80eb 2011-10-09          matt: 				      (vector-set! exit-info 1 exit-status)
37589f80eb 2011-10-09          matt: 				      (vector-set! exit-info 2 exit-code)
37589f80eb 2011-10-09          matt: 				      (mutex-unlock! m)
37589f80eb 2011-10-09          matt: 				      (if (eq? pid-val 0)
37589f80eb 2011-10-09          matt: 					  (begin
37589f80eb 2011-10-09          matt: 					    (thread-sleep! 2)
37589f80eb 2011-10-09          matt: 					    (loop (+ i 1)))
37589f80eb 2011-10-09          matt: 					  ))))))
37589f80eb 2011-10-09          matt: 		 (monitorjob   (lambda ()
37589f80eb 2011-10-09          matt: 				 (let* ((start-seconds (current-seconds))
37589f80eb 2011-10-09          matt: 					(calc-minutes  (lambda ()
37589f80eb 2011-10-09          matt: 							 (inexact->exact
37589f80eb 2011-10-09          matt: 							  (round
37589f80eb 2011-10-09          matt: 							   (-
37589f80eb 2011-10-09          matt: 							    (current-seconds)
37589f80eb 2011-10-09          matt: 							    start-seconds)))))
37589f80eb 2011-10-09          matt: 					(kill-tries 0))
37589f80eb 2011-10-09          matt: 				   (let loop ((minutes   (calc-minutes)))
37589f80eb 2011-10-09          matt: 				     (let* ((db       (open-db))
37589f80eb 2011-10-09          matt: 					    (cpuload  (get-cpu-load))
37589f80eb 2011-10-09          matt: 					    (diskfree (get-df (current-directory)))
37589f80eb 2011-10-09          matt: 					    (tmpfree  (get-df "/tmp")))
37589f80eb 2011-10-09          matt: 				       (if (not cpuload)  (begin (debug:print 0 "WARNING: CPULOAD not found.")  (set! cpuload "n/a")))
37589f80eb 2011-10-09          matt: 				       (if (not diskfree) (begin (debug:print 0 "WARNING: DISKFREE not found.") (set! diskfree "n/a")))
37589f80eb 2011-10-09          matt: 				       (set! kill-job? (test-get-kill-request db run-id test-name itemdat))
37589f80eb 2011-10-09          matt: 				       (test-update-meta-info db run-id test-name itemdat minutes cpuload diskfree tmpfree)
37589f80eb 2011-10-09          matt: 				       (if kill-job?
37589f80eb 2011-10-09          matt: 					   (begin
37589f80eb 2011-10-09          matt: 					     (mutex-lock! m)
37589f80eb 2011-10-09          matt: 					     (let* ((pid (vector-ref exit-info 0)))
37589f80eb 2011-10-09          matt: 					       (if (number? pid)
37589f80eb 2011-10-09          matt: 						   (begin
37589f80eb 2011-10-09          matt: 						     (debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")")
37589f80eb 2011-10-09          matt: 						     (let ((processes (cmd-run->list (conc "pgrep -l -P " pid))))
37589f80eb 2011-10-09          matt: 						       (for-each
37589f80eb 2011-10-09          matt: 							(lambda (p)
37589f80eb 2011-10-09          matt: 							  (let* ((parts  (string-split p))
37589f80eb 2011-10-09          matt: 								 (p-id   (if (> (length parts) 0)
37589f80eb 2011-10-09          matt: 									     (string->number (car parts))
37589f80eb 2011-10-09          matt: 									     #f)))
37589f80eb 2011-10-09          matt: 							    (if p-id
37589f80eb 2011-10-09          matt: 								(begin
37589f80eb 2011-10-09          matt: 								  (debug:print 0 "Killing " (cadr parts) "; kill -9  " p-id)
37589f80eb 2011-10-09          matt: 								  (system (conc "kill -9 " p-id))))))
37589f80eb 2011-10-09          matt: 							(car processes))
37589f80eb 2011-10-09          matt: 						       (system (conc "kill -9 " pid))))
37589f80eb 2011-10-09          matt: 						   (begin
37589f80eb 2011-10-09          matt: 						     (debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
37589f80eb 2011-10-09          matt: 						     (test-set-status! db run-id test-name "KILLED"  "FAIL"
37589f80eb 2011-10-09          matt: 								       itemdat (args:get-arg "-m") #f)
37589f80eb 2011-10-09          matt: 						     (sqlite3:finalize! db)
37589f80eb 2011-10-09          matt: 						     (exit 1))))
37589f80eb 2011-10-09          matt: 					     (set! kill-tries (+ 1 kill-tries))
37589f80eb 2011-10-09          matt: 					     (mutex-unlock! m)))
37589f80eb 2011-10-09          matt: 				       (sqlite3:finalize! db)
37589f80eb 2011-10-09          matt: 				       (thread-sleep! (+ 8 (random 4))) ;; add some jitter to the call home time to spread out the db accesses
37589f80eb 2011-10-09          matt: 				       (loop (calc-minutes)))))))
37589f80eb 2011-10-09          matt: 		 (th1          (make-thread monitorjob))
37589f80eb 2011-10-09          matt: 		 (th2          (make-thread runit)))
37589f80eb 2011-10-09          matt: 	    (set! job-thread th2)
37589f80eb 2011-10-09          matt: 	    (thread-start! th1)
37589f80eb 2011-10-09          matt: 	    (thread-start! th2)
37589f80eb 2011-10-09          matt: 	    (thread-join! th2)
37589f80eb 2011-10-09          matt: 	    (mutex-lock! m)
37589f80eb 2011-10-09          matt: 	    (set! db (open-db))
37589f80eb 2011-10-09          matt: 	    (let* ((item-path (item-list->path itemdat))
37589f80eb 2011-10-09          matt: 		   (testinfo  (db:get-test-info db run-id test-name item-path)))
37589f80eb 2011-10-09          matt: 	      (if (not (equal? (db:test-get-state testinfo) "COMPLETED"))
37589f80eb 2011-10-09          matt: 		  (begin
37589f80eb 2011-10-09          matt: 		    (debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result")
37589f80eb 2011-10-09          matt: 		    (test-set-status! db run-id test-name
37589f80eb 2011-10-09          matt: 				      (if kill-job? "KILLED" "COMPLETED")
37589f80eb 2011-10-09          matt: 				      (if (vector-ref exit-info 1) ;; look at the exit-status
37589f80eb 2011-10-09          matt: 					  (if (and (not kill-job?)
37589f80eb 2011-10-09          matt: 						   (eq? (vector-ref exit-info 2) 0))
37589f80eb 2011-10-09          matt: 					      "PASS"
37589f80eb 2011-10-09          matt: 					      "FAIL")
37589f80eb 2011-10-09          matt: 					  "FAIL") itemdat (args:get-arg "-m") #f)))
37589f80eb 2011-10-09          matt: 	      ;; for automated creation of the rollup html file this is a good place...
37589f80eb 2011-10-09          matt: 	      (if (not (equal? item-path ""))
37589f80eb 2011-10-09          matt: 		  (tests:summarize-items db run-id test-name #f)) ;; don't force - just update if no
37589f80eb 2011-10-09          matt: 	      )
37589f80eb 2011-10-09          matt: 	    (mutex-unlock! m)
37589f80eb 2011-10-09          matt: 	    ;; (exec-results (cmd-run->list fullrunscript)) ;;  (list ">" (conc test-name "-run.log"))))
37589f80eb 2011-10-09          matt: 	    ;; (success      exec-results)) ;; (eq? (cadr exec-results) 0)))
37589f80eb 2011-10-09          matt: 	    (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area "
37589f80eb 2011-10-09          matt: 			 work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n")
37589f80eb 2011-10-09          matt: 	    (sqlite3:finalize! db)
37589f80eb 2011-10-09          matt: 	    (if (not (vector-ref exit-info 1))
37589f80eb 2011-10-09          matt: 		(exit 4)))))))
3469edbbf7 2011-10-09          matt: 
ae6dbecf17 2011-05-02          matt: (define (setup-for-run)
ae6dbecf17 2011-05-02          matt:   (set! *configinfo* (find-and-read-config (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config")))
ae6dbecf17 2011-05-02          matt:   (set! *configdat*  (if (car *configinfo*)(car *configinfo*) #f))
ae6dbecf17 2011-05-02          matt:   (set! *toppath*    (if (car *configinfo*)(cadr *configinfo*) #f))
ae6dbecf17 2011-05-02          matt:   (if *toppath*
e38c4a9bdd 2011-05-03          matt:       (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated
bcc1c96231 2011-07-11      mrwellan:       (debug:print 0 "ERROR: failed to find the top path to your run setup."))
ae6dbecf17 2011-05-02          matt:   *toppath*)
ae6dbecf17 2011-05-02          matt: 
ae6dbecf17 2011-05-02          matt: (define (get-best-disk confdat)
ae6dbecf17 2011-05-02          matt:   (let* ((disks    (hash-table-ref/default confdat "disks" #f))
ae6dbecf17 2011-05-02          matt: 	 (best     #f)
ae6dbecf17 2011-05-02          matt: 	 (bestsize 0))
ae6dbecf17 2011-05-02          matt:     (if disks
ae6dbecf17 2011-05-02          matt: 	(for-each
ae6dbecf17 2011-05-02          matt: 	 (lambda (disk-num)
ae6dbecf17 2011-05-02          matt: 	   (let* ((dirpath    (cadr (assoc disk-num disks)))
ae6dbecf17 2011-05-02          matt: 		  (freespc    (if (directory? dirpath)
ae6dbecf17 2011-05-02          matt: 				  (get-df dirpath)
ae6dbecf17 2011-05-02          matt: 				  (begin
bcc1c96231 2011-07-11      mrwellan: 				    (debug:print 0 "WARNING: path " dirpath " in [disks] section not valid")
ae6dbecf17 2011-05-02          matt: 				    0))))
ae6dbecf17 2011-05-02          matt: 	     (if (> freespc bestsize)
ae6dbecf17 2011-05-02          matt: 		 (begin
ae6dbecf17 2011-05-02          matt: 		   (set! best     dirpath)
ae6dbecf17 2011-05-02          matt: 		   (set! bestsize freespc)))))
ae6dbecf17 2011-05-02          matt: 	 (map car disks)))
b5de223c55 2011-07-19      mrwellan:     (if best
b5de223c55 2011-07-19      mrwellan: 	best
b5de223c55 2011-07-19      mrwellan: 	(begin
b5de223c55 2011-07-19      mrwellan: 	  (debug:print 0 "ERROR: No valid disks found in megatest.config. Please add some to your [disks] section")
b5de223c55 2011-07-19      mrwellan: 	  (exit 1)))))
ae6dbecf17 2011-05-02          matt: 
ae6dbecf17 2011-05-02          matt: (define (create-work-area db run-id test-path disk-path testname itemdat)
d73b2c1642 2011-06-27      mrwellan:   (let* ((run-info (db:get-run-info db run-id))
ae6dbecf17 2011-05-02          matt: 	 (item-path (let ((ip (item-list->path itemdat)))
ae6dbecf17 2011-05-02          matt: 		      (if (equal? ip "") "" (conc "/" ip))))
d73b2c1642 2011-06-27      mrwellan: 	 (runname  (db:get-value-by-header (db:get-row run-info)
ae6dbecf17 2011-05-02          matt: 					   (db:get-header run-info)
ae6dbecf17 2011-05-02          matt: 					   "runname"))
ae6dbecf17 2011-05-02          matt: 	 (key-vals (get-key-vals db run-id))
ae6dbecf17 2011-05-02          matt: 	 (key-str  (string-intersperse key-vals "/"))
ae6dbecf17 2011-05-02          matt: 	 (dfullp   (conc disk-path "/" key-str "/" runname "/" testname
ae6dbecf17 2011-05-02          matt: 			 item-path))
00761e1112 2011-05-15          matt: 	 (toptest-path (conc disk-path "/" key-str "/" runname "/" testname))
6e469f08c6 2011-05-08          matt: 	 (runsdir  (config-lookup *configdat* "setup" "runsdir"))
6e469f08c6 2011-05-08          matt: 	 (lnkpath  (conc (if runsdir runsdir (conc *toppath* "/runs"))
6e469f08c6 2011-05-08          matt: 			 "/" key-str "/" runname item-path)))
00761e1112 2011-05-15          matt:     ;; since this is an iterated test this is as good a place as any to
00761e1112 2011-05-15          matt:     ;; update the toptest record with its location rundir
00761e1112 2011-05-15          matt:     (if (not (equal? item-path ""))
00761e1112 2011-05-15          matt: 	(db:test-set-rundir! db run-id testname "" toptest-path))
bcc1c96231 2011-07-11      mrwellan:     (debug:print 2 "Setting up test run area")
bcc1c96231 2011-07-11      mrwellan:     (debug:print 2 " - creating run area in " dfullp)
ae6dbecf17 2011-05-02          matt:     (system  (conc "mkdir -p " dfullp))
bcc1c96231 2011-07-11      mrwellan:     (debug:print 2 " - creating link from " dfullp "/" testname " to " lnkpath)
ae6dbecf17 2011-05-02          matt:     (system  (conc "mkdir -p " lnkpath))
6654e3905e 2011-07-19          matt: 
6654e3905e 2011-07-19          matt: ;; I suspect this section was deleting test directories under some
6654e3905e 2011-07-19          matt: ;; wierd sitations
6654e3905e 2011-07-19          matt: 
6654e3905e 2011-07-19          matt: ;;    (if (file-exists? (conc lnkpath "/" testname))
6654e3905e 2011-07-19          matt: ;;	(system (conc "rm -f " lnkpath "/" testname)))
ae6dbecf17 2011-05-02          matt:     (system  (conc "ln -sf " dfullp " " lnkpath "/" testname))
ae6dbecf17 2011-05-02          matt:     (if (directory? dfullp)
ae6dbecf17 2011-05-02          matt: 	(begin
bcc1c96231 2011-07-11      mrwellan: 	  (let* ((cmd    (conc "rsync -av" (if (> *verbosity* 1) "" "q") " " test-path "/ " dfullp "/"))
bcc1c96231 2011-07-11      mrwellan: 		 (status (system cmd)))
bcc1c96231 2011-07-11      mrwellan: 	    (if (not (eq? status 0))
bcc1c96231 2011-07-11      mrwellan: 		(debug:print 2 "ERROR: problem with running \"" cmd "\"")))
00761e1112 2011-05-15          matt: 	  (list dfullp toptest-path))
00761e1112 2011-05-15          matt: 	(list #f #f))))
ae6dbecf17 2011-05-02          matt: 
ae6dbecf17 2011-05-02          matt: ;; 1. look though disks list for disk with most space
ae6dbecf17 2011-05-02          matt: ;; 2. create run dir on disk, path name is meaningful
ae6dbecf17 2011-05-02          matt: ;; 3. create link from run dir to megatest runs area
ae6dbecf17 2011-05-02          matt: ;; 4. remotely run the test on allocated host
ae6dbecf17 2011-05-02          matt: ;;    - could be ssh to host from hosts table (update regularly with load)
ae6dbecf17 2011-05-02          matt: ;;    - could be netbatch
ae6dbecf17 2011-05-02          matt: ;;      (launch-test db (cadr status) test-conf))
ae6dbecf17 2011-05-02          matt: (define (launch-test db run-id test-conf keyvallst test-name test-path itemdat)
5c3fd5b583 2011-05-25      mrwellan:   (change-directory *toppath*)
dc5aae878a 2011-08-04      mrwellan:   (let ((useshell   (config-lookup *configdat* "jobtools"     "useshell"))
dc5aae878a 2011-08-04      mrwellan: 	(launcher   (config-lookup *configdat* "jobtools"     "launcher"))
ae6dbecf17 2011-05-02          matt: 	(runscript  (config-lookup test-conf   "setup"        "runscript"))
ae6dbecf17 2011-05-02          matt: 	(diskspace  (config-lookup test-conf   "requirements" "diskspace"))
ae6dbecf17 2011-05-02          matt: 	(memory     (config-lookup test-conf   "requirements" "memory"))
ae6dbecf17 2011-05-02          matt: 	(hosts      (config-lookup *configdat* "jobtools"     "workhosts"))
ae6dbecf17 2011-05-02          matt: 	(remote-megatest (config-lookup *configdat* "setup" "executable"))
ae6dbecf17 2011-05-02          matt: 	(local-megatest  (car (argv)))
ae6dbecf17 2011-05-02          matt: 	;; (item-path  (item-list->path itemdat)) test-path is the full path including the item-path
ae6dbecf17 2011-05-02          matt: 	(work-area  #f)
00761e1112 2011-05-15          matt: 	(toptest-work-area #f) ;; for iterated tests the top test contains data relevant for all
ae6dbecf17 2011-05-02          matt: 	(diskpath   #f)
ae6dbecf17 2011-05-02          matt: 	(cmdparms   #f)
e38c4a9bdd 2011-05-03          matt: 	(fullcmd    #f) ;; (define a (with-output-to-string (lambda ()(write x))))
e38c4a9bdd 2011-05-03          matt: 	(mt-bindir-path #f))
ae6dbecf17 2011-05-02          matt:     (if hosts (set! hosts (string-split hosts)))
e38c4a9bdd 2011-05-03          matt:     (if (not remote-megatest)(set! remote-megatest local-megatest)) ;; "megatest"))
e38c4a9bdd 2011-05-03          matt:     (set! mt-bindir-path (pathname-directory remote-megatest))
ae6dbecf17 2011-05-02          matt:     (if launcher (set! launcher (string-split launcher)))
ae6dbecf17 2011-05-02          matt:     ;; set up the run work area for this test
ae6dbecf17 2011-05-02          matt:     (set! diskpath (get-best-disk *configdat*))
ae6dbecf17 2011-05-02          matt:     (if diskpath
00761e1112 2011-05-15          matt: 	(let ((dat  (create-work-area db run-id test-path diskpath test-name itemdat)))
00761e1112 2011-05-15          matt: 	  (set! work-area (car dat))
00761e1112 2011-05-15          matt: 	  (set! toptest-work-area (cadr dat)))
ae6dbecf17 2011-05-02          matt: 	(begin
ae6dbecf17 2011-05-02          matt: 	  (set! work-area test-path)
bcc1c96231 2011-07-11      mrwellan: 	  (debug:print 0 "WARNING: No disk work area specified - running in the test directory")))
ae6dbecf17 2011-05-02          matt:     (set! cmdparms (base64:base64-encode (with-output-to-string
ae6dbecf17 2011-05-02          matt: 				    (lambda () ;; (list 'hosts     hosts)
ae6dbecf17 2011-05-02          matt: 				      (write (list (list 'testpath  test-path)
ae6dbecf17 2011-05-02          matt: 						   (list 'work-area work-area)
ae6dbecf17 2011-05-02          matt: 						   (list 'test-name test-name)
ae6dbecf17 2011-05-02          matt: 						   (list 'runscript runscript)
ae6dbecf17 2011-05-02          matt: 						   (list 'run-id    run-id   )
00761e1112 2011-05-15          matt: 						   (list 'itemdat   itemdat  )
00761e1112 2011-05-15          matt: 						   (list 'megatest  remote-megatest)
5c3fd5b583 2011-05-25      mrwellan: 						   (list 'env-ovrd  (hash-table-ref/default *configdat* "env-override" '()))
adc62d626a 2011-05-08          matt: 						   (list 'runname   (args:get-arg ":runname"))
e38c4a9bdd 2011-05-03          matt: 						   (list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " "))))
51810ab5ab 2011-06-16      mrwellan:     ;; clean out step records from previous run if they exist
51810ab5ab 2011-06-16      mrwellan:     (db:delete-test-step-records db run-id test-name itemdat)
ae6dbecf17 2011-05-02          matt:     (change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
ae6dbecf17 2011-05-02          matt:     (cond
ae6dbecf17 2011-05-02          matt:      ((and launcher hosts) ;; must be using ssh hostname
ae6dbecf17 2011-05-02          matt:       (set! fullcmd (append launcher (car hosts)(list remote-megatest "-execute" cmdparms))))
ae6dbecf17 2011-05-02          matt:      (launcher
ae6dbecf17 2011-05-02          matt:       (set! fullcmd (append launcher (list remote-megatest "-execute" cmdparms))))
ae6dbecf17 2011-05-02          matt:      (else
ae6dbecf17 2011-05-02          matt:       (set! fullcmd (list remote-megatest "-execute" cmdparms))))
ae6dbecf17 2011-05-02          matt:     (if (args:get-arg "-xterm")(set! fullcmd (append fullcmd (list "-xterm"))))
bcc1c96231 2011-07-11      mrwellan:     (debug:print 1 "Launching megatest for test " test-name " in " work-area" ...")
ebea00e4bb 2011-08-24      mrwellan:     (test-set-status! db run-id test-name "LAUNCHED" "n/a" itemdat #f #f) ;; (if launch-results launch-results "FAILED"))
e38c4a9bdd 2011-05-03          matt:     ;; set
e38c4a9bdd 2011-05-03          matt:     ;; set pre-launch-env-vars before launching, keep the vars in prevvals and put the envionment back when done
e0c173490e 2011-10-09          matt:     (debug:print 4 "fullcmd: " fullcmd)
e38c4a9bdd 2011-05-03          matt:     (let* ((commonprevvals (alist->env-vars
e38c4a9bdd 2011-05-03          matt: 			    (hash-table-ref/default *configdat* "env-override" '())))
e38c4a9bdd 2011-05-03          matt: 	   (testprevvals   (alist->env-vars
ae6dbecf17 2011-05-02          matt: 			    (hash-table-ref/default test-conf "pre-launch-env-overrides" '())))
0d6213c6ea 2011-05-18          matt: 	   (miscprevvals   (alist->env-vars ;; consolidate this code with the code in megatest.scm for "-execute"
0d6213c6ea 2011-05-18          matt: 			    (append (list (list "MT_TEST_NAME" test-name)
0d6213c6ea 2011-05-18          matt: 					  (list "MT_ITEM_INFO" (conc itemdat))
0d6213c6ea 2011-05-18          matt: 					  (list "MT_RUNNAME"   (args:get-arg ":runname")))
0d6213c6ea 2011-05-18          matt: 				    itemdat)))
ae6dbecf17 2011-05-02          matt: 	   (launch-results (apply cmd-run-proc-each-line
dc5aae878a 2011-08-04      mrwellan: 				  (if useshell
dc5aae878a 2011-08-04      mrwellan: 				      (string-intersperse fullcmd " ")
dc5aae878a 2011-08-04      mrwellan: 				      (car fullcmd))
ae6dbecf17 2011-05-02          matt: 				  print
dc5aae878a 2011-08-04      mrwellan: 				  (if useshell
dc5aae878a 2011-08-04      mrwellan: 				      '()
dc5aae878a 2011-08-04      mrwellan: 				      (cdr fullcmd))))) ;;  launcher fullcmd)));; (apply cmd-run-proc-each-line launcher print fullcmd))) ;; (cmd-run->list fullcmd))
bcc1c96231 2011-07-11      mrwellan:       (debug:print 2 "Launching completed, updating db")
62d813cd5f 2011-07-12          matt:       (debug:print 4 "Launch results: " launch-results)
62d813cd5f 2011-07-12          matt:       (if (not launch-results)
62d813cd5f 2011-07-12          matt: 	  (begin
70aaddfbce 2011-07-13          matt: 	    (print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now")
70aaddfbce 2011-07-13          matt: 	    (sqlite3:finalize! db)
70aaddfbce 2011-07-13          matt: 	    ;; good ole "exit" seems not to work
70aaddfbce 2011-07-13          matt: 	    ;; (_exit 9)
70aaddfbce 2011-07-13          matt: 	    ;; but this hack will work! Thanks go to Alan Post of the Chicken email list
dc5aae878a 2011-08-04      mrwellan: 	    ;; NB// Is this still needed? Should be safe to go back to "exit" now?
70aaddfbce 2011-07-13          matt: 	    (process-signal (current-process-id) signal/kill)
70aaddfbce 2011-07-13          matt: 	    ))
0d6213c6ea 2011-05-18          matt:       (alist->env-vars miscprevvals)
e38c4a9bdd 2011-05-03          matt:       (alist->env-vars testprevvals)
70aaddfbce 2011-07-13          matt:       (alist->env-vars commonprevvals)
70aaddfbce 2011-07-13          matt:       launch-results)))
ae6dbecf17 2011-05-02          matt: