Megatest

;; Do NOT check if not on homehost!
;;
(define (common:exit-on-version-changed)
  (if (and *toppath*              ;; do nothing if *toppath* not yet provided
	   (common:on-homehost?))
      (if (common:api-changed?)
	  (let* ((mtconf (conc (get-environment-variable "MT_RUN_AREA_HOME") "/megatest.config"))
                 (dbfile  (conc (get-environment-variable "MT_RUN_AREA_HOME") ".megatest/main.db"))
                 (read-only (not (file-write-access? dbfile)))
                 (dbstruct (db:setup #t))) ;; (db:setup-db *dbstruct-dbs* *toppath* #f))) ;;  #t)))
	    (debug:print 0 *default-log-port*
			 "WARNING: Version mismatch!\n"
			 "   expected: " (common:version-signature) "\n"
			 "   got:      " (common:get-last-run-version))
            (cond

                 (print-call-chain (current-error-port))
                 (exit 1))
               (common:cleanup-db dbstruct)))
             ((not (common:file-exists? mtconf))
              (debug:print 0 *default-log-port* "   megatest.config does not exist in this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             ((not (common:file-exists? dbfile))
              (debug:print 0 *default-log-port* "   .megatest/main.db does not exist in this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             ((not (eq? (current-user-id)(file-owner mtconf)))
              (debug:print 0 *default-log-port* "   You do not own .megatest/main.db in this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             (read-only
              (debug:print 0 *default-log-port* "   You have read-only access to this area.  Cannot proceed with megatest version migration.")
              (exit 1))
             (else
              (debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
              (exit 1)))))))

					  (string-translate toppath "/" "."))
				    (conc "/tmp/" (current-process-id) ;; just in case we have an issue with the dir by own user name
					  "/megatest_localdb/"
					  tsname
					  (string-translate toppath "/" "."))
				    ))))
		(set! *db-cache-path* dbpath)
		;; ensure megatest area has .megatest
		(let ((dbarea (conc *toppath* "/.megatest")))
		  (if (not (file-exists? dbarea))
		      (create-directory dbarea)))
		;; ensure tmp area has .megatest
		(let ((dbarea (conc dbpath "/.megatest")))
		  (if (not (file-exists? dbarea))
		      (create-directory dbarea)))
		dbpath))
	  #f)))

(define (common:get-area-path-signature)
  (message-digest-string (md5-primitive) *toppath*))

(define last-copy-time 0)


;; Sync to tmp only if in read-only mode.

(define (sync-db-to-tmp tabdat)
  (let* ((db-file "./.megatest/main.db"))
    (if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5)))
      (begin
        (db:multi-db-sync (db:setup #f) 'old2new)
        (set! last-copy-time (current-seconds))
      )
    )
  )

	 (get-mtime wal-file)
	 (get-mtime shm-file))))
	 
;; (define (db:all-db-sync dbstruct)
;;   (let* ((dbdat (db:open-db dbstruct #f db:initialize-main-db))
;; 	 (data-synced       0) ;; count of changed records
;;     (tmp-area       (common:get-db-tmp-area))
;;     (dbfiles        (glob (conc tmp-area"/.megatest/*.db")))
;;     (sync-durations (make-hash-table))
;;     (no-sync-db        (db:open-no-sync-db)))
;;     (for-each
;;      (lambda (file) ;; tmp db file
;;        (debug:print-info 3 *default-log-port* "file: " file)
;;        (let* ((fname       (conc (pathname-file file) ".db")) ;; fname is tmp db file
;;               (wal-file (conc fname "-wal"))
;;               (shm-file (conc fname "-shm"))
;; 	      (fulln       (conc *toppath*"/.megatest/"fname)) ;; fulln is nfs db name
;;               (wal-time     (if (file-exists? wal-file)             
;; 			       (file-modification-time wal-file)
;;                                0))
;;               (shm-time     (if (file-exists? shm-file)             
;; 			       (file-modification-time shm-file)
;;                                0))
;; 	      (time1        (db:get-sqlite3-mod-time file))

	 (keys (db:get-keys dbstruct))
	 (sync-durations (make-hash-table)))

    ;; kill servers
    (if killservers (db:kill-servers))
    
    (if (not dbfiles)
	(debug:print-error 0 *default-log-port* "no dbfiles found in " (conc *toppath* "/.megatest"))
	(for-each
	 (lambda (srcfile)
	   (debug:print-info 3 *default-log-port* "file: " srcfile)
	   (let* ((fname    (conc (pathname-file srcfile) ".db"))
		  (basename (pathname-file srcfile))
		  (run-id   (if (string= basename "main") #f (string->number basename)))
		  (destfile (conc dest-area "/.mtdb/" fname))

		 (let* ((start-time (current-milliseconds))
			;; subdb is misnamed - should be dbdat (I think...)
			(subdb    (dbfile:open-db dbstruct run-id dbfile:db-init-proc))
			;;        (or (dbfile:get-subdb dbstruct run-id)
			;;            (dbfile:init-subdb dbstruct run-id dbfile:db-init-proc)))
			(mtdb      (dbr:subdb-mtdbdat subdb))
			;;
			;; BUG: -mrw- I think this next line is wrong. run-id should be the path to .megatest/<runid>.db
			;; 
			(tmpdb     (dbfile:open-db dbstruct run-id dbfile:db-init-proc)))
		   
		   (debug:print-info 2 *default-log-port* "delta syncing file: " srcfile ", time diff: " (- time1 time2) " seconds")
		   (if old2new
                       (begin
			 (if dejunk (db:clean-up run-id mtdb))