Megatest

(declare (uses apimod))
(declare (uses genexample))
(declare (uses rmtmod))
(declare (uses archivemod))
(declare (uses mutils))
(declare (uses odsmod))
(declare (uses testsmod))
(declare (uses diff-report))

(use srfi-69 readline)

(module mtbody
	*
	
(import scheme)
(cond-expand
 (chicken-4

	  files
	  matchable
	  md5
	  message-digest
	  pathname-expand
	  posix
	  posix-extras
	  readline
	  regex
	  regex-case
	  sparse-vectors
	  srfi-1
	  srfi-18
	  srfi-69
	  typed-records

	fsmod
	envmod
	apimod
	genexample
	mutils
	odsmod
	testsmod
	diff-report
        )

(include "common_records.scm")

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

;; (include "common_records.scm")

		(import dbfile)
		;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...

		(if *use-new-readline*
		    (begin
		      (install-history-file (get-environment-variable "HOME") ".megatest_history") ;;  [homedir] [filename] [nlines])
		      (current-input-port (make-readline-port "megatest> ")))
		    #;(begin
		      (gnu-history-install-file-manager
		       (string-append
			(or (get-environment-variable "HOME") ".") "/.megatest_history"))
		      (current-input-port (make-gnu-readline-port "megatest> "))))
		(if (args:get-arg "-repl")
		    (repl)
		    (load (args:get-arg "-load")))

	     (dest-db     (args:get-arg "-to"))
	     ;; (sync-period (args:get-arg-number "-period"))
	     ;; (sync-timeout (args:get-arg-number "-timeout"))
	     (sync-period-in  (args:get-arg "-period"))
	     (sync-timeout-in (args:get-arg "-timeout"))
	     (sync-period     (if sync-period-in (string->number sync-period-in) #f))
	     (sync-timeout    (if sync-timeout-in (string->number sync-timeout-in) #f))
	     (synclock-file   (conc dest-db".sync-lock"))
	     (keys        (db:get-keys #f))
	     (thesync     (lambda (last-update)
			    (debug:print-info 0 *default-log-port* "Attempting to sync data from "src-db" to "dest-db"...")
			    (debug:print-info 0 *default-log-port* "PID = " (current-process-id))
			    (if (not (file-exists? dest-db))
				(begin
				  (debug:print 0 *default-log-port* "Using copy to create "dest-db" from "src-db)
				  (file-copy src-db dest-db)
				  1)
				(let ((res (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys)))
				  (if res
				      (debug:print-info 2 *default-log-port* "Synced " res " records from "src-db" to "dest-db)
				      (debug:print-info 0 *default-log-port* "No sync due to permissions or other issue."))
				  res))))
	     (start-time  (current-seconds))
             (synclock-mod-time (if (file-exists? synclock-file)
				    (handle-exceptions
				     exn
				     #f
				     (file-modification-time synclock-file))
				    #f))
             (age (if synclock-mod-time (- (current-seconds) synclock-mod-time) 1000))
             )
	(if (and src-db dest-db)
	    (if (file-exists? src-db)
		(if (and (file-exists? synclock-file) (< age 20))
		    (debug:print 0 *default-log-port* "Lock "synclock-file" exists, skipping sync...")
                    (begin
                      (if (file-exists? synclock-file)
			  (begin
			    (debug:print 0 *default-log-port* "Deleting old lock file " synclock-file)
			    (delete-file synclock-file)
			    )
			  )
		      (dbfile:with-simple-file-lock
		       synclock-file
		       (lambda ()
			 (let loop ((last-changed (current-seconds))
				    (last-update  0))
			   (let* ((changes (handle-exceptions
					    exn
					    (begin
					      (debug:print 0 *default-log-port* "Exception in sync: "(condition->list exn))
					      (delete-file synclock-file)
					      (exit))
					    (thesync last-update)))
				  (now-time (current-seconds)))
			     (if (and sync-period sync-timeout) ;; 
				 (if (and (< (- now-time start-time) 600) ;; hard limit on how long we run for
					  (>  sync-timeout (- now-time last-changed)))
				     (begin
				       (if sync-period (thread-sleep! sync-period))
				       (loop (if (> changes 0) now-time last-changed) now-time))))))))
                      (debug:print 0 *default-log-port* "Releasing lock file " synclock-file)
                      )
		    )
		(debug:print 0 *default-log-port* "No sync due to unreadble or non-existant source file"src-db))
	    (debug:print 0 *default-log-port* "Usage for -db2db; -to and -from must be specified"))
	(set! *didsomething* #t)))

  (if (args:get-arg "-list-test-time")