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:
File Annotation