Megatest

;; (dbfile:sync-method 'none)
;; (dbfile:cache-method 'none)
;; (rmt:transport-mode 'nfs)

;; uncomment this block to test with tcp and cachedb
(dbfile:sync-method 'none) ;; original was causing crash on start. 
(dbfile:cache-method 'none)
(rmt:transport-mode 'nfs)

;; Copyright 2006-2012, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.


;; (define itemdat '((ripeness    "green ripe overripe")
;; 		     (temperature "cool medium hot")
;; 		     (season      "summer winter fall spring")))

(declare (unit items))
(declare (uses common))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses debugprint))

(import commonmod
	configfmod
	debugprint)

(include "common_records.scm")

;; NB// area-dat replaced by ttdat
;; 
(define (rmt:send-receive cmd run-id params #!key (attemptnum 1)(ttdat #f))
  (assert (or (not run-id) (number? run-id)) "FATAL: run-id is required to be a number or #f")
  (assert *toppath* "FATAL: rmt:send-receive called with *toppath* not set.")
  (let* ((areapath      *toppath*) ;; TODO - resolve from dbstruct to be compatible with multiple areas
	 (readonly-mode (rmtmod:calc-ro-mode ttdat *toppath*))
	 (testsuite     (common:get-testsuite-name)))





    (case (rmt:transport-mode)
      ((tcp)
       (let* ((start-time    (current-seconds)) ;; snapshot time so all use cases get same value
	      (attemptnum    (+ 1 attemptnum))
	      (mtexe         (common:find-local-megatest))
	      (dbfname       (conc (dbfile:run-id->dbnum run-id)".db"))
	      (ttdat         (rmt:set-ttdat areapath ttdat))
	      (conn          (tt:get-conn ttdat dbfname))

  (rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))

(define (rmt:test-get-archive-block-info archive-block-id)
  (rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))

(define (rmtmod:calc-ro-mode runremote *toppath*)
  (case (rmt:transport-mode)
    ((http)
     (if (and runremote
	      (remote-ro-mode-checked runremote))
	 (remote-ro-mode runremote)
	 (let* ((mtcfgfile  (conc *toppath* "/megatest.config"))
		(ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
	   (if runremote
	       (begin
		 (remote-ro-mode-set! runremote ro-mode)
		 (remote-ro-mode-checked-set! runremote #t)
		 ro-mode)
	       ro-mode))))
    ((tcp)
     (if (and runremote
	      (tt-ro-mode-checked runremote))
	 (tt-ro-mode runremote)
	 (let* ((mtcfgfile  (conc *toppath* "/megatest.config"))
		(ro-mode (not (file-write-access? mtcfgfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
	   (if runremote
	       (begin
		 (tt-ro-mode-set! runremote ro-mode)
		 (tt-ro-mode-checked-set! runremote #t)
		 ro-mode)
	       ro-mode))))))




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

(define (rmt:on-homehost? #!optional (runremote-in #f))

;;======================================================================
;; Move me elsewhere ...
;; RADT => Why do we meed the version check here, this is called only if version misma
;;
(define (common:cleanup-db dbstruct #!key (full #f))
  (case (rmt:transport-mode)
    ((http)
     (apply db:multi-db-sync 
	    dbstruct
	    'schema
	    'killservers
	    'adj-target
	    'new2old
	    '(dejunk)
	    ))
    ((tcp nfs)
     (apply db:multi-db-sync 
	    dbstruct
	    'schema
	    'killservers
	    'adj-target
	    'new2old