Megatest

;;======================================================================
;; 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.
;;======================================================================

(use sqlite3 srfi-1 posix regex-case base64 format dot-locking csv-xml z3 call-with-environment-variables)
(require-extension sqlite3 regex posix)

(require-extension (srfi 18) extras tcp rpc)

(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))

       (setenv key val))
      (debug:print 0 "ERROR: bad value for setenv, key=" key ", value=" val)))

(define home (getenv "HOME"))
(define user (getenv "USER"))

;; GLOBAL GLETCHES
;; (define *db-keys* #f)
;; (define *configinfo* #f)
;; (define *configdat*  #f)
;; (define *toppath*    #f)
;; (define *already-seen-runconfig-info* #f)
;; (define *waiting-queue*     (make-hash-table))
;; (define *test-meta-updated* (make-hash-table))
;; (define *globalexitstatus*  0) ;; attempt to work around possible thread issues
;; (define *passnum*           0) ;; when running track calls to run-tests or similar
;; (define *write-frequency*   (make-hash-table)) ;; run-id => (vector (current-seconds) 0))
;; (define *alt-log-file* #f)  ;; used by -log
;; (define *common:denoise*    (make-hash-table)) ;; for low noise printing

;; All the above *theoretically* replaced by ...
(define *testsuite-data* (make-hash-table)) ;; area-path => testsuite-vector < toppath linktree configdat envvars dbstruct >

;; MULTI-TESTSUITE support, use when the env-vars are in use (set up and take down using call-with-environment-variables.)
(define *testsuite-mutex* (make-mutex))

;; DATABASE
(define *dbstruct-db*  #f)
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex*      (make-mutex))
(define *db-sync-mutex*       (make-mutex))
(define *db-multi-sync-mutex* (make-mutex))

  (set! *env-vars-by-run-id* (make-hash-table))
  (set! *test-id-cache*      (make-hash-table)))

;; Generic string database
(define sdb:qry #f) ;; (make-sdb:qry)) ;;  'init #f)
;; Generic path database
(define *fdb* #f)

;;======================================================================
;; G E N E R I C   S E T U P   F O R   A   T E S T S U I T E
;;======================================================================

;; set up the very basics needed for doing anything here.
;; this returns a common_records:testsuite record: < toppath linktree configdat envvars >
;;
(define (common:multi-setup-for-run #!key (force #f)(configdat-in #f))
  (mutex-lock! *testsuite-mutex*)
  (let* ((configinfo (or (if (get-environment-variable "MT_CMDINFO") ;; we are inside a test - do not reprocess configs
			     (let ((alistconfig (conc (get-environment-variable "MT_LINKTREE") "/"
						      (get-environment-variable "MT_TARGET")   "/"
						      (get-environment-variable "MT_RUNNAME")  "/"
						      ".megatest.cfg")))
			       (if (file-exists? alistconfig)
				   (list (configf:read-alist alistconfig)
					 (get-environment-variable "MT_RUN_AREA_HOME"))
				   #f))
			     #f) ;; no config cached - give up
			 (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")))
	 (configdat  (if (car configinfo)(car configinfo) #f))
	 (toppath    (if (car configinfo)(cadr configinfo) #f))
	 (linktree   (configf:lookup configdat "setup" "linktree")) ;; link tree is critical
	 (failed     #f))
    (if linktree
	(if (not (file-exists? linktree))
	    (begin
	      (handle-exceptions
	       exn
	       (begin
		 (debug:print 0 "ERROR: Something went wrong when trying to create linktree dir at " linktree)
		 (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
		 (set! failed #t))
	       (create-directory linktree #t))))
	(begin
	  (debug:print 0 "ERROR: linktree not defined in [setup] section of megatest.config")
	  (set! failed #t)))
    (if linktree
	(let ((dbdir (or (configf:lookup configdat "setup" "dbdir") ;; not really supported yet, placeholder only
			 (conc linktree "/.db"))))
	  (handle-exceptions
	   exn
	   (begin
	     (debug:print 0 "ERROR: failed to create the " dbdir " area for your database files")
	     (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn))
	     (set! failed #t))
	   (if (not (directory-exists? dbdir))(create-directory dbdir))))
	;; (setenv "MT_LINKTREE" linktree))
	(begin
	  (debug:print 0 "ERROR: linktree is required in your megatest.config [setup] section")
	  (set! failed #t)))
    (if (not (and toppath
		  (directory-exists? toppath)))
	(begin
	  (debug:print 0 "ERROR: failed to find the top path to your Megatest area.")
	  (set! failed #t)))
    (mutex-unlock! *testsuite-mutex*)
    (let ((testsuite-data (vector toppath linktree configinfo
				  (list (cons "MT_LINKTREE" linktree)
					(cons "MT_RUN_AREA_HOME" toppath))
				  #f)))
      (if failed
	  #f
	  (begin
	    (hash-table-set! *testsuite-data* toppath testsuite-data)
	    testsuite-data)))))

;; get the vars from the testsuite-data envvars store and run proc
;;
(define (common:with-vars testsuite-data proc . additional-vars)
  (mutex-lock! *testsuite-mutex*)
  (let* ((envvars (append (common_records:testsuite-get-envvars testsuite-data)
			  additional-vars))
	 (res (call-with-environment-variables envvars proc)))
    (mutex-unlock! *testsuite-mutex*)
    res))

;;======================================================================
;; L O C K E R S   A N D   B L O C K E R S 
;;======================================================================

;; block further accesses to databases. Call this before shutting db down
(define (common:db-block-further-queries)