Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -54,11 +54,11 @@ ;; 1. We are a test manager and we received *transport-type* and *runremote* via cmdline ;; 2. We are a run tests, list runs or other interactive process and we mush figure out ;; *transport-type* and *runremote* from the monitor.db ;; ;; client:setup -(define (client:setup #!key (numtries 50)) +(define (client:setup #!key (numtries 3)) (if (not *toppath*) (if (not (setup-for-run)) (begin (debug:print 0 "ERROR: failed to find megatest.config, exiting") (exit)))) @@ -76,20 +76,22 @@ ;; ;; DEBUG STUFF ;; (if (eq? *transport-type* 'fs)(begin (print "ERROR!!!!!!! refusing to run with transport " *transport-type*)(exit 99))) (debug:print-info 11 "Using transport type of " *transport-type* (if hostinfo (conc " to connect to " hostinfo) "")) (case *transport-type* - ((fs) ;; (if (not *megatest-db*)(set! *megatest-db* (open-db)))) - ;; we are not doing fs any longer. let's cheat and start up a server - ;; if we are falling back on fs (not 100% supported) do an about face and start a server - (if (not (equal? (args:get-arg "-transport") "fs")) - (begin - (set! *transport-type* #f) - (system (conc "megatest -list-servers | grep " megatest-version " | grep alive || megatest -server - -daemonize && sleep 3")) - (thread-sleep! 1) - (if (> numtries 0) - (client:setup numtries: (- numtries 1)))))) + ((fs)(if (not *megatest-db*)(set! *megatest-db* (open-db)))) + ;; NB// Going back to enabling fs and possibly even make it the default. + ;; ;; we are not doing fs any longer. let's cheat and start up a server + ;; ;; if we are falling back on fs (not 100% supported) do an about face and start a server + ;; (if (not (equal? (args:get-arg "-transport") "fs")) + ;; (begin + ;; (set! *transport-type* #f) + ;; (system ;; (conc "megatest -list-servers | grep " (common:version-signature) " | grep alive || megatest -server - -daemonize && sleep 3")) + ;; "megatest -server - -daemonize") + ;; (thread-sleep! 1) + ;; (if (> numtries 0) + ;; (client:setup numtries: (- numtries 1)))))) ((http) (http-transport:client-connect (tasks:hostinfo-get-interface hostinfo) (tasks:hostinfo-get-port hostinfo))) ((zmq) (zmq-transport:client-connect (tasks:hostinfo-get-interface hostinfo) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -40,11 +40,11 @@ (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar ;; SERVER (define *my-client-signature* #f) -(define *transport-type* #f) +(define *transport-type* 'fs) (define *megatest-db* #f) (define *rpc:listener* #f) ;; if set up for server communication this will hold the tcp port (define *runremote* #f) ;; if set up for server communication this will hold (define *last-db-access* (current-seconds)) ;; update when db is accessed via server (define *max-cache-size* 0) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -373,20 +373,22 @@ (define (setup-for-run) ;; would set values for KEYS in the environment here for better support of env-override but ;; have chicken/egg scenario. need to read megatest.config then read it again. Going to ;; pass on that idea for now ;; special case - (set! *configinfo* (find-and-read-config - (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") - environ-patt: "env-override" - given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") - pathenvvar: "MT_RUN_AREA_HOME")) - (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) - (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) - (if *toppath* - (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated - (debug:print 0 "ERROR: failed to find the top path to your run setup.")) + (if (not (hash-table? *configdat*)) ;; no need to re-open on every call + (begin + (set! *configinfo* (find-and-read-config + (if (args:get-arg "-config")(args:get-arg "-config") "megatest.config") + environ-patt: "env-override" + given-toppath: (get-environment-variable "MT_RUN_AREA_HOME") + pathenvvar: "MT_RUN_AREA_HOME")) + (set! *configdat* (if (car *configinfo*)(car *configinfo*) #f)) + (set! *toppath* (if (car *configinfo*)(cadr *configinfo*) #f)) + (if *toppath* + (setenv "MT_RUN_AREA_HOME" *toppath*) ;; to be deprecated + (debug:print 0 "ERROR: failed to find the top path to your run setup.")))) *toppath*) (define (get-best-disk confdat) (let* ((disks (hash-table-ref/default confdat "disks" #f)) (best #f) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -253,14 +253,15 @@ (print megatest-version) (exit))) (define *didsomething* #f) -(if (and (or (args:get-arg "-list-targets") - (args:get-arg "-list-db-targets")) - (not (args:get-arg "-transport"))) - (hash-table-set! args:arg-hash "-transport" "fs")) +;; Force default transport to fs +(if ;; (and (or (args:get-arg "-list-targets") + ;; (args:get-arg "-list-db-targets")) + (not (args:get-arg "-transport")) + (hash-table-set! args:arg-hash "-transport" "fs")) ;;====================================================================== ;; Misc setup stuff ;;====================================================================== @@ -305,45 +306,39 @@ (if (args:get-arg "-server") (let ((transport (args:get-arg "-transport" "http"))) (debug:print 2 "Launching server using transport " transport) (server:launch (string->symbol transport))) + + ;; Not a server? This section will decide how to communicate + ;; (if (not (null? (lset-intersection equal? (hash-table-keys args:arg-hash) '("-runtests" "-list-runs" "-rollup" "-remove-runs" "-lock" "-unlock" - "-update-meta" "-extract-ods")))) + "-update-meta" "-extract-ods" "-list-servers" + "-stop-server" "-show-cmdinfo")))) (if (setup-for-run) - (let loop ((servers (open-run-close tasks:get-best-server tasks:open-db)) - (trycount 0)) - (if (or (not servers) - (null? servers)) - (begin - (if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds) - (begin - (debug:print 0 "INFO: Starting server as none running ...") - ;; (server:launch (string->symbol (args:get-arg "-transport" "http")))) - ;; no need to use fork, no need to do the list-servers trick. Just start the damn server, it will exit on it's own - ;; if there is an existing server - (system "megatest -server - -daemonize") - (thread-sleep! 3) - ;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http"))) - ;; (system (conc "megatest -list-servers | egrep '" megatest-version ".*alive' || megatest -server - -daemonize && sleep 3")) - ;; (process-fork (lambda () - ;; (daemon:ize) - ;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))) - ) - (begin - (debug:print-info 0 "Waiting for server to start") - (thread-sleep! 4))) - (if (< trycount 10) - (loop (open-run-close tasks:get-best-server tasks:open-db) - (+ trycount 1)) - (debug:print 0 "WARNING: Couldn't start or find a server."))) - (debug:print 0 "INFO: Server(s) running " servers) - ))))) + (begin + + ;; if not list or kill then start a client (if appropriate) + (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") + (eq? (length (hash-table-keys args:arg-hash)) 0)) + (debug:print-info 1 "Server connection not needed") + ;; ok, so lets connect to the server + (let ((transport-from-config (configf:lookup *configdat* "setup" "transport")) + (transport-from-cmdln (args:get-arg "-transport"))) + (cond + ((and transport-from-config (not (equal? transport-from-config "fs"))) + (server:ensure-running) + (client:launch)) + ((and transport-from-cmdln (not (equal? transport-from-cmdln "fs"))) + (server:ensure-running) + (client:launch)) + (else + (set! *transport-type* 'fs))))))))) (if (or (args:get-arg "-list-servers") (args:get-arg "-stop-server")) (let ((tl (setup-for-run))) (if tl @@ -388,17 +383,11 @@ (tasks:kill-server status hostname pullport pid transport))))) servers) (debug:print-info 1 "Done with listservers") (set! *didsomething* #t) (exit)) ;; must do, would have to add checks to many/all calls below - (exit))) - ;; if not list or kill then start a client (if appropriate) - (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") - (eq? (length (hash-table-keys args:arg-hash)) 0)) - (debug:print-info 1 "Server connection not needed") - ;; ok, so lets connect to the server - (client:launch))) + (exit)))) ;;====================================================================== ;; Weird special calls that need to run *after* the server has started? ;;====================================================================== @@ -453,15 +442,17 @@ (else (debug:print 0 "ERROR: -dumpmode of " (args:get-arg "-dumpmode") " not recognised"))) (set! *didsomething* #t))) (if (args:get-arg "-show-cmdinfo") - (let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))) - (if (equal? (args:get-arg "-dumpmode") "json") - (json-write data) - (pp data)) - (set! *didsomething* #t))) + (if (getenv "MT_CMDINFO") + (let ((data (read (open-input-string (base64:base64-decode (getenv "MT_CMDINFO")))))) + (if (equal? (args:get-arg "-dumpmode") "json") + (json-write data) + (pp data)) + (set! *didsomething* #t)) + (debug:print-info 0 "environment variable MT_CMDINFO is not set"))) ;;====================================================================== ;; Remove old run(s) ;;====================================================================== Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -51,11 +51,11 @@ (debug:print 0 "ERROR: cannot find megatest.config, exiting") (exit)))) (debug:print-info 2 "Starting server using " transport " transport") (set! *transport-type* transport) (case transport - ((fs) (exit)) ;; there is no "fs" transport + ((fs) (exit)) ;; there is no "fs" server transport ((http) (http-transport:launch)) ((zmq) (zmq-transport:launch)) (else (debug:print "WARNING: unrecognised transport " transport) (exit)))) @@ -117,5 +117,34 @@ (send-message pub-socket (db:obj->string (vector success/fail query-sig result))))) (else (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*) result))) +(define (server:ensure-running) + (let loop ((servers (open-run-close tasks:get-best-server tasks:open-db)) + (trycount 0)) + (if (or (not servers) + (null? servers)) + (begin + (if (even? trycount) ;; just do the server start every other time through this loop (every 8 seconds) + (begin + (debug:print 0 "INFO: Starting server as none running ...") + ;; (server:launch (string->symbol (args:get-arg "-transport" "http")))) + ;; no need to use fork, no need to do the list-servers trick. Just start the damn server, it will exit on it's own + ;; if there is an existing server + (system "megatest -server - -daemonize") + (thread-sleep! 3) + ;; (process-run (car (argv)) (list "-server" "-" "-daemonize" "-transport" (args:get-arg "-transport" "http"))) + ;; (system (conc "megatest -list-servers | egrep '" megatest-version ".*alive' || megatest -server - -daemonize && sleep 3")) + ;; (process-fork (lambda () + ;; (daemon:ize) + ;; (server:launch (string->symbol (args:get-arg "-transport" "http"))))) + ) + (begin + (debug:print-info 0 "Waiting for server to start") + (thread-sleep! 4))) + (if (< trycount 10) + (loop (open-run-close tasks:get-best-server tasks:open-db) + (+ trycount 1)) + (debug:print 0 "WARNING: Couldn't start or find a server."))) + (debug:print 0 "INFO: Server(s) running " servers) + ))) ADDED tests/fullrun/tests/ez_fail_quick/testconfig Index: tests/fullrun/tests/ez_fail_quick/testconfig ================================================================== --- /dev/null +++ tests/fullrun/tests/ez_fail_quick/testconfig @@ -0,0 +1,14 @@ +[requirements] +priority 10 + +[ezsteps] +# should fail on next step +lookitnada ls /nada + +[test_meta] +author matt +owner bob +description This test runs a single ezstep which fails immediately. + +tags first,single +reviewed 09/10/2011, by Matt Index: tests/installall/megatest.config ================================================================== --- tests/installall/megatest.config +++ tests/installall/megatest.config @@ -5,10 +5,11 @@ BUILD_TAG TEXT [setup] max_concurrent_jobs 6 linktree #{getenv MT_RUN_AREA_HOME}/links +testcopycmd cp --remove-destination -rsv TEST_SRC_PATH/. TEST_TARG_PATH/. >> TEST_TARG_PATH/mt_launch.log 2>> TEST_TARG_PATH/mt_launch.log [jobtools] useshell yes launcher nbfind Index: tests/installall/runconfigs.config ================================================================== --- tests/installall/runconfigs.config +++ tests/installall/runconfigs.config @@ -22,10 +22,11 @@ # Currently must have at least one variable in a section [4.8.0/trunk/bin/std] IUP_VERSION na [4.8.0.4/trunk/src/std] +CHICKEN_URL http://code.call-cc.org/releases/4.8.0/chicken-4.8.0.4.tar.gz IUP_VERSION na [4.8.1/trunk/src/std] IUP_VERSION na Index: tests/installall/tests/chicken/download.sh ================================================================== --- tests/installall/tests/chicken/download.sh +++ tests/installall/tests/chicken/download.sh @@ -2,16 +2,16 @@ # Run your step here source $PREFIX/buildsetup.sh -if ! [[ -e ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz ]]; then +if [ ! -e ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz ]; then if [ "${CHICKEN_URL}" == "" ]; then - (cd ${DOWNLOADS};wget http://code.call-cc.org/releases/${CHICKEN_VERSION}/chicken-${CHICKEN_VERSION}.tar.gz) - else - (cd ${DOWNLOADS};wget ${CHICKEN_URL}) + CHICKEN_URL=http://code.call-cc.org/releases/${CHICKEN_VERSION}/chicken-${CHICKEN_VERSION}.tar.gz fi + echo "Downloading $CHICKEN_URL" + (cd ${DOWNLOADS};wget ${CHICKEN_URL}) fi ls -l ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz tar xfvz ${DOWNLOADS}/chicken-${CHICKEN_VERSION}.tar.gz