Megatest

# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
PREFIX=$(PWD)
CSCOPTS= 
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 \
	   http-transport.scm nmsg-transport.scm filedb.scm \
           client.scm gutils.scm synchash.scm daemon.scm mt.scm dcommon.scm \
	   tree.scm ezsteps.scm lock-queue.scm sdb.scm \
	   rmt.scm api.scm tdb.scm rpc-transport.scm \
	   portlogger.scm archive.scm env.scm

# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
     dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
     json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
     spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3

;;======================================================================
;; Copyright 2006-2013, 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.
;;======================================================================

(declare (unit env))

(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 nanomsg srfi-18 call-with-environment-variables)

(define (env:open-db fname)
  (let* ((db-exists (file-exists? fname))
	 (db        (open-database fname)))
    (if (not db-exists)
	(begin
	  (exec (sql db "CREATE TABLE envvars (
                    id INTEGER PRIMARY KEY,
                    context TEXT NOT NULL,
                    var TEXT NOT NULL,
                    val TEXT NOT NULL,
                       CONSTRAINT envvars_constraint UNIQUE (context,var))"))))
    (set-busy-handler! db (busy-timeout 10000))
    db))

;; save vars in given context, this is NOT incremental by default
;;
(define (env:save-env-vars db context #!key (incremental #f))
  (with-transaction
   db
   (lambda ()
     ;; first clear out any vars for this context
     (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context))
     (for-each
      (lambda (varval)
	(let ((var (car varval))
	      (val (cdr varval)))
	  (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var))
	  (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val)))
	(get-environment-variables)))))

;; apply contexts to current environment
;;  - each context is applied in the given order
;;  - variables in the paths list are split on the separator and the components
;;    merged using simple delta addition
;;
(define (env:apply-contexts db basecontext contexts paths outputf formats)
  
  (for-each
   (lambda (context)
     (query
      (for-each-row
       (lambda (row)
	 (let ((var  (car row))
	       (vala (cadr row))
	       (valb (caddr row)))
	    ;;(print "var: " var " vala: " vala " valb" valb " paths: " paths)
	   (if (assoc var paths) ;; this var is a PATH
	       (let ((current (get-environment-variable var))) ;; use this NOT vala
	         ;;(pp paths)
                 ;;(pp var)
		 (env:process-path-envvar var (cadr (assoc var paths)) current valb))
	       (begin
		 (setenv var valb))))))
      (sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=? AND a.val != b.val")
      ;;(sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=?")
      basecontext context))
   contexts))

(define (env:blind-merge l1 l2)
  (if (null? l1) l2
      (if (null? l2) l1
	  (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2)))))))

;; given a before and an after envvar calculate a new merged path
;;
(define (env:merge-path-envvar separator patha pathb)
  (let* ((patha-parts  (string-split patha separator))
	 (pathb-parts  (string-split pathb separator))
	 (common-parts (lset-intersection equal? patha-parts pathb-parts))
	 (final        (delete-duplicates ;; env:blind-merge 
			(append pathb-parts common-parts patha-parts))))
;;     (print "BEFORE:   " (string-intersperse patha-parts  "\n       "))
;;     (print "AFTER:    " (string-intersperse pathb-parts  "\n       "))
;;     (print "COMMON:   " (string-intersperse common-parts "\n       "))
    (string-intersperse final separator)))

(define (env:process-path-envvar varname separator patha pathb)
  (begin
    (print "Process-path-envvar: " varname)
  ) 
  (let ((newpath (env:merge-path-envvar separator patha pathb)))
    (setenv varname newpath)))

(define (env:have-context db context)
  (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context)
     0))

;; this is so the calling block does not need to import sql-de-lite
(define (env:close-database db)
  (close-database db))

(declare (uses daemon))
(declare (uses db))

(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")

  -load file.scm          : load and run file.scm
  -mark-incompletes       : find and mark incomplete tests
  -ping run-id|host:port  : ping server, exit with 0 if found
  -debug N|N,M,O...       : enable debug 0-N or N and M and O ...

Utilities
  -env2file fname         : write the environment to fname.csh and fname.sh
  -envcap fname=context   : save current variables labeled as context in file fname
  -refdb2dat refdb        : convert refdb to sexp or to format specified by -dumpmode
                            formats: perl, ruby, sqlite3, csv (for csv the -o param
                            will substitute %s for the sheet name in generating 
                            multiple sheets)
  -o                      : output file for refdb2dat (defaults to stdout)
  -archive cmd            : archive runs specified by selectors to one of disks specified
                            in the [archive-disks] section.

			"-stop-server"
			"-transport"
			"-kill-server"
			"-port"
			"-extract-ods"
			"-pathmod"
			"-env2file"
			"-envcap"
			"-setvars"
			"-set-state-status"
			"-set-run-status"
			"-debug" ;; for *verbosity* > 2
			"-gen-megatest-test"
			"-override-timeout"
			"-test-files"  ;; -test-paths is for listing all

    (let ((tl        (launch:setup-for-run))
	  (run-id    (and (args:get-arg "-run-id")
			  (string->number (args:get-arg "-run-id")))))
      (if run-id
	  (begin
	    (server:launch run-id)
	    (set! *didsomething* #t))
	  (debug:print 0 "ERROR: server requires run-id be specified with -run-id"))))

    ;; Not a server? This section will decide how to communicate
    ;;
    ;;  Setup client for all expect listed here
    ;; (if (null? (lset-intersection 
    ;;     	     equal?
    ;;     	     (hash-table-keys args:arg-hash)
    ;;     	     '("-list-servers"
    ;;     	       "-stop-server"
    ;;     	       "-show-cmdinfo"
    ;;     	       "-list-runs"
    ;;     	       "-ping")))
    ;;     (if (launch:setup-for-run)
    ;;         (let ((run-id    (and (args:get-arg "-run-id")
    ;;     			  (string->number (args:get-arg "-run-id")))))
    ;;           ;; (set! *fdb*   (filedb:open-db (conc *toppath* "/db/paths.db")))
    ;;           ;; 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")
    ;;     	  (begin
    ;;     	    ;; (if run-id 
    ;;     	    ;;     (client:launch run-id) 
    ;;     	    ;;     (client:launch 0)      ;; without run-id we'll start a server for "0"
    ;;     	    #t
    ;;     	    ))))))

;; MAY STILL NEED THIS
;;		       (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t))))))))))

(if (or (args:get-arg "-list-servers")
	(args:get-arg "-stop-server"))
    (let ((tl (launch:setup-for-run)))

(if (args:get-arg "-sync-to-megatest.db")
    (begin
      (db:multi-db-sync 
       #f ;; do all run-ids
       'new2old
       )
      (set! *didsomething* #t)))

;;======================================================================
;; Capture, save and manipulate environments
;;======================================================================

(let ((envcap (args:get-arg "-envcap")))
  (if envcap
      (if (substring-index "=" envcap)
	  (let* ((parts   (string-split envcap "="))
		 (fname   (car parts))
		 (context (cadr parts))
		 (db      (env:open-db fname)))
	    (env:save-env-vars db context)
	    (env:close-database db)
	    (set! *didsomething* #t))
	  (begin
	    (debug:print 0 "ERROR: Parameter to -envcap should be <filename>=<context>. E.G. envdat=original, got: " envcap)
	    (set! *didsomething* #t)))))

;;======================================================================
;; Exit and clean up
;;======================================================================

(if *runremote* (close-all-connections!))

#!/bin/bash

if [[ ! -e "$HOME/.megatest" ]];then
   mkdir -p "$HOME/.megatest"
fi
# if [[ ! -e "$HOME/.megatest/areas.dat" ]];then
#    echo "Creating some placeholder files in ~/.megatest"
#    cat > "$HOME/.megatest/areas.dat" << EOF
# [default]
# mfstest /mfs/matt/data/megatest/tests/fullrun
# mfsbig /mfs/matt/data/megatest/tests/fdktestqa/testqa
# [local]
# localtest /home/matt/data/megatest/tests/fullrun
# EOF
# fi
if [[ ! -e "$HOME/.megatest/default.dat" ]];then
   cat > "$HOME/.megatest/default.dat" << EOF
[fullrun]
path /mfs/matt/data/megatest/tests/fullrun
order 1
# [bigrun]
# path /mfs/matt/data/megatest/tests/fdktestqa/testqa