Index: .fossil-settings/ignore-glob ================================================================== --- .fossil-settings/ignore-glob +++ .fossil-settings/ignore-glob @@ -4,5 +4,8 @@ bin/* tests/megatest.db tests/monitor.db megatest dboard +tests/fullrun/tmp/* +tests/simpleruns +tests/simplelinks Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -4,11 +4,12 @@ INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ - fs-transport.scm zmq-transport.scm http-transport.scm + fs-transport.scm zmq-transport.scm http-transport.scm \ + client.scm GUISRCF = dashboard.scm dashboard-tests.scm dashboard-guimonitor.scm dashboard-main.scm OFILES = $(SRCFILES:%.scm=%.o) GOFILES = $(GUISRCF:%.scm=%.o) ADDED client.scm Index: client.scm ================================================================== --- /dev/null +++ client.scm @@ -0,0 +1,101 @@ + +;; Copyright 2006-2012, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;;====================================================================== +;; C L I E N T S +;;====================================================================== + +;; server:get-client-signature +(define (client:get-signature) + (if *my-client-signature* *my-client-signature* + (let ((sig (server:mk-signature))) + (set! *my-client-signature* sig) + *my-client-signature*))) + +;; server:client-login +(define (client:login serverdat) + (cdb:login serverdat *toppath* (server:get-client-signature))) + +;; Not currently used! But, I think it *should* be used!!! +(define (client:logout serverdat) + (let ((ok (and (socket? serverdat) + (cdb:logout serverdat *toppath* (server:get-client-signature))))) + ok)) + +;; Do all the connection work, look up the transport type and set up the +;; connection if required. +;; +;; There are two scenarios. +;; 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 +;; +;; server:client-setup +(define (client:setup #!key (numtries 50)) + (if (not *toppath*) + (if (not (setup-for-run)) + (begin + (debug:print 0 "ERROR: failed to find megatest.config, exiting") + (exit)))) + (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*) + (let* ((hostinfo (if (not *transport-type*) ;; If we dont' already have transport type set then figure it out + (open-run-close tasks:get-best-server tasks:open-db) + #f))) + ;; if have hostinfo then extract the transport type + ;; else fall back to fs + (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo) + (set! *transport-type* (if hostinfo + (string->symbol (tasks:hostinfo-get-transport hostinfo)) + 'fs)) + ;; ;; 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)))) + ((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) + (tasks:hostinfo-get-port hostinfo) + (tasks:hostinfo-get-pubport hostinfo))) + (else ;; default to fs + (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs") + (set! *transport-type* 'fs) + (set! *megatest-db* (open-db)))))) + +;; server:client-signal-handler +(define (client:signal-handler signum) + (handle-exceptions + exn + (debug:print " ... exiting ...") + (let ((th1 (make-thread (lambda () + "") ;; do nothing for now (was flush out last call if applicable) + "eat response")) + (th2 (make-thread (lambda () + (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") + (thread-sleep! 1) ;; give the flush one second to do it's stuff + (debug:print 0 " Done.") + (exit 4)) + "exit on ^C timer"))) + (thread-start! th2) + (thread-start! th1) + (thread-join! th2)))) + +;; server:client-launch +(define (client:launch) + (set-signal-handler! signal/int server:client-signal-handler) + (if (client:setup) + (debug:print-info 2 "connected as client") + (begin + (debug:print 0 "ERROR: Failed to connect as client") + (exit)))) + Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -127,11 +127,11 @@ ;; adds to ht if given (must be #f otherwise) ;; envion-patt is a regex spec that identifies sections that will be eval'd ;; in the environment on the fly ;; sections: #f => get all, else list of sections to gather (define (read-config path ht allow-system #!key (environ-patt #f)(curr-section #f)(sections #f)) - (debug:print-info 4 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections) + (debug:print-info 5 "read-config " path " allow-system " allow-system " environ-patt " environ-patt " curr-section: " curr-section " sections: " sections " pwd: " (current-directory)) (if (not (file-exists? path)) (begin (debug:print-info 4 "read-config - file not found " path " current path: " (current-directory)) (if (not ht)(make-hash-table) ht)) (let ((inp (open-input-file path)) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -967,25 +967,38 @@ ;;====================================================================== ;; Misc. test related queries ;;====================================================================== +;; MUST BE CALLED local! (define (db:test-get-paths-matching db keynames target fnamepatt #!key (res '())) - (let ((paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target db keynames target res))) - (if fnamepatt - (apply append - (map (lambda (p) - (glob (conc p "/" fnamepatt))) - paths-from-db)) - paths-from-db))) - -(define (db:test-get-paths-matching-keynames-target db keynames target res) + ;; BUG: Move the values derived from args to parameters and push to megatest.scm (let* ((testpatt (if (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%")) (statepatt (if (args:get-arg ":state") (args:get-arg ":state") "%")) (statuspatt (if (args:get-arg ":status") (args:get-arg ":status") "%")) (runname (if (args:get-arg ":runname") (args:get-arg ":runname") "%")) - (keystr (string-intersperse + (paths-from-db (cdb:remote-run db:test-get-paths-matching-keynames-target db keynames target res + testpatt: testpatt + statepatt: statepatt + statuspatt: statuspatt + runname: runname))) + (if fnamepatt + (apply append + (map (lambda (p) + (if (directory-exists? p) + (glob (conc p "/" fnamepatt)) + '())) + paths-from-db)) + paths-from-db))) + +(define (db:test-get-paths-matching-keynames-target db keynames target res + #!key + (testpatt "%") + (statepatt "%") + (statuspatt "%") + (runname "%")) + (let* ((keystr (string-intersperse (map (lambda (key val) (conc "r." key " like '" val "'")) keynames (string-split target "/")) " AND ")) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -61,10 +61,12 @@ (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) (ezsteps (assoc/default 'ezsteps cmdinfo)) ;; (runremote (assoc/default 'runremote cmdinfo)) (transport (assoc/default 'transport cmdinfo)) + (serverinf (assoc/default 'serverinf cmdinfo)) + (port (assoc/default 'port cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (test-id (assoc/default 'test-id cmdinfo)) (target (assoc/default 'target cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (env-ovrd (assoc/default 'env-ovrd cmdinfo)) @@ -82,10 +84,11 @@ (if (and (file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path (rollup-status 0)) + (change-directory top-path) (debug:print 2 "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) ;; Setup the *runremote* global var (if *runremote* (debug:print 2 "ERROR: I'm not expecting *runremote* to be set at this time")) ;; (set! *runremote* runremote) (set! *transport-type* (string->symbol transport)) @@ -109,11 +112,11 @@ (setenv "MT_ITEM_INFO" (conc itemdat)) (setenv "MT_RUNNAME" runname) (setenv "MT_MEGATEST" megatest) (setenv "MT_TARGET" target) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) - (change-directory top-path) + ;; (change-directory top-path) (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) @@ -584,10 +587,11 @@ (with-output-to-string (lambda () ;; (list 'hosts hosts) (write (list (list 'testpath test-path) ;; (list 'runremote *runremote*) (list 'transport (conc *transport-type*)) + (list 'serverinf *server-info*) (list 'toppath *toppath*) (list 'work-area work-area) (list 'test-name test-name) (list 'runscript runscript) (list 'run-id run-id ) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.53) +(define megatest-version 1.5301) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -139,16 +139,19 @@ "-execute" ;; run the command encoded in the base64 parameter "-step" ":runname" "-target" "-reqtarg" - ":item" - ":runname" + ":runname" + "-runname" ":state" + "-state" ":status" + "-status" "-list-runs" "-testpatt" + "-itempatt" "-setlog" "-set-toplog" "-runstep" "-logpro" "-m" @@ -240,10 +243,16 @@ (if (args:get-arg "-logging")(set! *logging* #t)) (if (debug:debug-mode 3) ;; we are obviously debugging (set! open-run-close open-run-close-no-exception-handling)) +(if (args:get-arg "-itempatt") + (let ((newval (conc (args:get-arg "-testpatt") "/" (args:get-arg "-itempatt")))) + (debug:print 0 "WARNING: -itempatt has been deprecated, please use -testpatt testpatt/itempatt method, new testpatt is "newval) + (hash-table-set! args:arg-hash "-testpatt" newval) + (hash-table-delete! args:arg-hash "-itempatt"))) + ;;====================================================================== ;; Misc general calls ;;====================================================================== (if (args:get-arg "-env2file") Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -136,70 +136,10 @@ (send-message pub-socket (db:obj->string (vector success/fail query-sig result))))) (else (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*) result))) -;;====================================================================== -;; C L I E N T S -;;====================================================================== - -(define (server:get-client-signature) - (if *my-client-signature* *my-client-signature* - (let ((sig (server:mk-signature))) - (set! *my-client-signature* sig) - *my-client-signature*))) - -(define (server:client-login serverdat) - (cdb:login serverdat *toppath* (server:get-client-signature))) - -;; Not currently used! But, I think it *should* be used!!! -(define (server:client-logout serverdat) - (let ((ok (and (socket? serverdat) - (cdb:logout serverdat *toppath* (server:get-client-signature))))) - ok)) - -;; Do all the connection work, look up the transport type and set up the -;; connection if required. -;; -;; There are two scenarios. -;; 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 -;; -(define (server:client-setup #!key (numtries 50)) - (if (not *toppath*) - (if (not (setup-for-run)) - (begin - (debug:print 0 "ERROR: failed to find megatest.config, exiting") - (exit)))) - (debug:print-info 11 "*transport-type* is " *transport-type* ", *runremote* is " *runremote*) - (let* ((hostinfo (if (not *transport-type*) ;; If we dont' already have transport type set then figure it out - (open-run-close tasks:get-best-server tasks:open-db) - #f))) - ;; if have hostinfo then extract the transport type - ;; else fall back to fs - (debug:print-info 11 "CLIENT SETUP, hostinfo=" hostinfo) - (set! *transport-type* (if hostinfo - (string->symbol (tasks:hostinfo-get-transport hostinfo)) - 'fs)) - ;; ;; 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)))) - ((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) - (tasks:hostinfo-get-port hostinfo) - (tasks:hostinfo-get-pubport hostinfo))) - (else ;; default to fs - (debug:print 0 "ERROR: unrecognised transport type " *transport-type* " attempting to continue with fs") - (set! *transport-type* 'fs) - (set! *megatest-db* (open-db)))))) ;; all routes though here end in exit ... (define (server:launch transport) (if (not *toppath*) @@ -215,30 +155,5 @@ ((zmq) (zmq-transport:launch)) (else (debug:print "WARNING: unrecognised transport " transport) (exit)))) -(define (server:client-signal-handler signum) - (handle-exceptions - exn - (debug:print " ... exiting ...") - (let ((th1 (make-thread (lambda () - "") ;; do nothing for now (was flush out last call if applicable) - "eat response")) - (th2 (make-thread (lambda () - (debug:print 0 "ERROR: Received ^C, attempting clean exit. Please be patient and wait a few seconds before hitting ^C again.") - (thread-sleep! 1) ;; give the flush one second to do it's stuff - (debug:print 0 " Done.") - (exit 4)) - "exit on ^C timer"))) - (thread-start! th2) - (thread-start! th1) - (thread-join! th2)))) - -(define (server:client-launch) - (set-signal-handler! signal/int server:client-signal-handler) - (if (server:client-setup) - (debug:print-info 2 "connected as client") - (begin - (debug:print 0 "ERROR: Failed to connect as client") - (exit)))) - Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -1,8 +1,8 @@ # run some tests -BINPATH=$(shell realpath ../bin) +BINPATH=$(PWD)/../bin MEGATEST=$(BINPATH)/megatest PATH := $(BINPATH):$(PATH) RUNNAME := $(shell date +w%V.%u.%H.%M) IPADDR := "-" # Set SERVER to "-server -" Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ tests/fullrun/runconfigs.config @@ -1,6 +1,9 @@ [include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config] + +# #{system echo 'VACKYVAR #{shell pwd}' > $MT_RUN_AREA_HOME/config/$USER.config} +[include ./config/#{getenv USER}.config] WACKYVAR0 #{get ubuntu/nfs/none CURRENT} WACKYVAR1 #{scheme (args:get-arg "-target")} [default/ubuntu/nfs] Index: tests/fullrun/tests/test_mt_vars/testconfig ================================================================== --- tests/fullrun/tests/test_mt_vars/testconfig +++ tests/fullrun/tests/test_mt_vars/testconfig @@ -12,10 +12,13 @@ # ALT_VAR should NOT be set altvarnotset altvarnotset.sh # EMPTY_VAR should be an empty string empty_var empty_var.sh + +# VACKYVAR should be set to a path +vackyvar vackyvar.sh # test-path and test-file test-path test-path-file.sh [requirements] ADDED tests/fullrun/tests/test_mt_vars/vackyvar.sh Index: tests/fullrun/tests/test_mt_vars/vackyvar.sh ================================================================== --- /dev/null +++ tests/fullrun/tests/test_mt_vars/vackyvar.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env bash + +grep VACKYVAR megatest.sh | grep fullrun