Megatest

	
(import scheme
	chicken
	data-structures
	extras
	files

	format
	(prefix sqlite3 sqlite3:)
	matchable
	posix
	typed-records
	srfi-1
	srfi-18
	srfi-69

			    (tmpadj  "")       ;; add to tmp path
			    (syncdir 'todisk)) ;; todisk is used when caching in /tmp and writing data back to MTRAH
  (let* ((dbstruct     (or dbstruct-in (make-dbr:dbstruct areapath: areapath)))
	 (dbfname      (or dbfname-in (dbmod:run-id->dbfname run-id)))
	 (dbpath       (dbmod:get-dbdir dbstruct))             ;; directory where all the .db files are kept
	 (dbfullname   (conc dbpath"/"dbfname)) ;; (dbmod:run-id->full-dbfname dbstruct run-id))
	 (dbexists     (file-exists? dbfullname))
	 (tmpdir       (common:make-tmpdir-name areapath tmpadj))
	 (tmpdb        (let* ((fname (conc tmpdir"/"dbfname)))
			 fname))
	 (cachedb        (dbmod:open-cachedb-db init-proc
					    ;; (if (eq? (dbfile:cache-method) 'cachedb)
					    ;; 	#f
					    tmpdb
					    ;; )

    (dbr:dbstruct-dbfile-set!    dbstruct dbfullname)
    (dbr:dbstruct-dbtmpname-set! dbstruct tmpdb)
    (dbr:dbstruct-dbfname-set!   dbstruct dbfname)
    (dbr:dbstruct-sync-proc-set! dbstruct
				 (lambda (last-update)
				   (if *sync-in-progress*
				       (debug:print 3 *default-log-port* "WARNING: overlapping calls to sync to disk")




























				       (begin



					 ;; turn off writes - send busy or block?
					 ;; call db2db internally
					 ;; turn writes back on
					 ;;
					 (set! *api-halt-writes* #t) ;; do we need a mutex?
					 ;; (dbmod:db-to-db-sync src-db dest-db last-update (dbfile:db-init-proc) keys)
					 (debug:print-info 2 *default-log-port* "Internal sync running from "tmpdb" to "dbfullname)

					 (dbmod:db-to-db-sync tmpdb dbfullname last-update (dbfile:db-init-proc) keys)
					 (set! *api-halt-writes* #f)
					 ))))




    ;; (dbmod:sync-tables tables #f db cachedb)
    ;; 
    (thread-sleep! 1) ;; let things settle before syncing in needed data
    (dbmod:sync-gasket tables #f cachedb db dbfullname 'fromdest keys) ;; ) ;; load into cachedb
    (dbr:dbstruct-last-update-set! dbstruct (+ (current-seconds) -10)) ;; should this be offset back in time by one second?
    dbstruct))

		   (sdb    (dbmod:safely-open-db src-db init-proc #t))
		   (ddb    (dbmod:safely-open-db dest-db init-proc d-wr))
		   (res    (dbmod:sync-gasket tables last-update sdb ddb dest-db 'todisk keys)))
	      (sqlite3:finalize! sdb)
	      (sqlite3:finalize! ddb)
	      res)))
      #f))

;; ======================================================================
;; dbstats
;;======================================================================

;; (define *dbstruct-dbs*         #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this.
;; db stats
(define *db-stats*            (make-hash-table)) ;; hash of vectors < count duration-total >
(define *db-stats-mutex*      (make-mutex))

(define (rmt:print-db-stats)
  (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f"
    (debug:print 0 *default-log-port* "DB Stats\n========")
    (debug:print 0 *default-log-port* (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg"))
    (for-each (lambda (cmd)
		(let* ((dat     (hash-table-ref *db-stats* cmd))
		       (count   (dbstat-cnt dat))
		       (tottime (dbstat-tottime dat)))
		  (debug:print 0 *default-log-port*
			       (format #f fmtstr cmd count tottime
				       (/ tottime count)))))
	      (sort (hash-table-keys *db-stats*)
		    (lambda (a b)
		      (> (dbstat-tottime (hash-table-ref *db-stats* a))
			 (dbstat-tottime (hash-table-ref *db-stats* b))))))))

(defstruct dbstat
  (cnt 0)
  (tottime 0))

(define (db:add-stats cmd run-id params delta)
  (let* ((modified-cmd (if (eq? cmd 'general-call)
			   (string->symbol (conc "general-call-" (car params)))
			   cmd))
	 (rec          (hash-table-ref/default *db-stats* modified-cmd #f)))
    (if (not rec)
	(let ((new-rec  (make-dbstat)))
	  (hash-table-set! *db-stats* modified-cmd new-rec)
	  (set! rec new-rec)))
    (dbstat-cnt-set! rec (+ (dbstat-cnt rec) 1))
    (dbstat-tottime-set! rec (+ (dbstat-tottime rec) delta))))
    


)


;; ATTIC

					 #;(let* ((syncer-logfile    (conc areapath"/logs/"dbfname"-syncer.log"))
					      (sync-cmd          (if (eq? syncdir 'todisk)
								     (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "tmpdb" -to "dbfullname" -period 5 -timeout 10 > /dev/null 2&>1)&")
								     (conc "(NBFAKE_LOG="syncer-logfile" nbfake megatest -db2db -from "dbfullname" -to "tmpdb" -period 5 -timeout 10 > /dev/null 2&>1)&")))
					      (synclock-file     (conc dbfullname".lock"))
					      (syncer-running-file (conc dbfullname"-sync-running"))
					      (synclock-mod-time (if (file-exists? synclock-file)
								     (handle-exceptions
									 exn
								       #f
								       (file-modification-time synclock-file))
								     #f))
					      (thethread         (lambda ()
								   (thread-start!
								    (make-thread
								     (lambda ()
								       (set! *sync-in-progress* #t)
								       (debug:print-info "Running "sync-cmd)
								       (if (file-exists? syncer-running-file)
									   (debug:print-info 0 *default-log-port* "Syncer still running, skipping syncer start.")
									   (system sync-cmd))
								       (set! *sync-in-progress* #f)))))))
					 (if ((if (eq? syncdir 'todisk) < >) ;; use less than for todisk, greater than for from disk
					      (file-modification-time tmpdb)
					      (file-modification-time dbfullname))
					     (debug:print 4 *default-log-port* "Skipping sync, "tmpdb" older than "dbfullname)
					     (if synclock-mod-time
						 (if (> (- (current-seconds) synclock-mod-time) 20) ;; something wrong with sync, remove file
						     (begin
						       (handle-exceptions
							   exn
							 #f
                                                         (begin
                                                           (debug:print 0 *default-log-port* "Sync lock file " synclock-file "is older than 20 seconds ("  synclock-mod-time " seconds). Removing it")
							   (delete-file synclock-file)
                                                         )
                                                       )
						       (thethread))
						     (debug:print 0 *default-log-port* "Skipping sync, lockfile "synclock-file" found."))
						 (thethread))))