Megatest

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

;;======================================================================

(use srfi-18)

(declare (unit dbfile))
(declare (uses debugprint))
(declare (uses commonmod))

(module dbfile
	*
	
  (import scheme
	  chicken

(import scheme)
(cond-expand
 (chicken-4
  (import chicken
	  data-structures
	  extras
	  matchable)
  
(import (prefix sqlite3 sqlite3:)
	posix typed-records srfi-18 srfi-1
	srfi-69
	  posix

	stack
	files
	ports

	commonmod
	debugprint
	)
	  files
	  ports
	  )
  (define current-process-milliseconds current-milliseconds)
  )
  (chicken-5
   (import chicken.base
	   chicken.condition
	   chicken.file
	   chicken.file.posix
	   chicken.format
	   chicken.io
	   chicken.pathname
	   chicken.port
	   chicken.process
	   chicken.process-context.posix
	   chicken.sort
	   chicken.string
	   chicken.time
	   chicken.time.posix

	   system-information
	   )
   (define file-move move-file)
   (define file-write-access? file-writable?)
   ))

  (import (prefix sqlite3 sqlite3:))
  (import typed-records)
  (import srfi-18)
  (import srfi-1)
  (import srfi-69)
  (import stack)
  (import commonmod)
  (import debugprint)
  (import matchable)
  
;; parameters
;;
(define dbfile:testsuite-name (make-parameter #f))

(define keep-age-param        (make-parameter 10))      ;; qif file age, if over move to attic
(define num-run-dbs           (make-parameter 10))      ;; number of db's in .mtdb
(define dbfile:sync-method    (make-parameter 'attach)) ;; 'attach or 'original

                   readonly-slave-dbs))) -6)
    (else
     ;; (dbfile:print-err "db:sync-tables: args are good")

     (let ((stmts       (make-hash-table)) ;; table-field => stmt
	   (all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	   (numrecs     (make-hash-table))
	   (start-time  (current-milliseconds))
	   (start-time  (current-process-milliseconds))
	   (tot-count   0))
       (for-each ;; table
	(lambda (tabledat)
	  (let* ((tablename        (car tabledat))
		 (fields           (cdr tabledat))
		 (has-last-update  (member "last_update" fields))
		 (use-last-update  (cond

                 (if (member "last_update" field-names)
                    (db:create-trigger db tablename))))
	     (append (list todb) slave-dbs)
           )
          )
        )
	tbls)
       (let* ((runtime      (- (current-milliseconds) start-time))
       (let* ((runtime      (- (current-process-milliseconds) start-time))
	      (should-print (or ;; (debug:debug-mode 12)
			     (common:low-noise-print 120 "db sync")
			     (> runtime 500)))) ;; low and high sync times treated as separate.
	 (for-each 
	  (lambda (dat)
	    (let ((tblname (car dat))
		  (count   (cdr dat)))

;;======================================================================

;; call with dbinit=db:initialize-main-db
;;
(define (db:open-db dbstruct run-id dbinit)
  ;; (mutex-lock! *db-open-mutex*)
  (let* ((dbdat (dbfile:open-db dbstruct run-id dbinit)))
              #;(case (rmt:transport-mode)
		  ((http) (dbfile:open-db dbstruct run-id dbinit))
		  ((tcp)  (dbmod:open-db  dbstruct run-id dbinit))
		  (else (assert #f "FATAL: rmt:transport-node not correct value"(rmt:transport-mode))))
    (set! *db-write-access* (not (dbr:dbdat-read-only dbdat)))
    ;; (mutex-unlock! *db-open-mutex*)
    dbdat))

(define dbfile:db-init-proc (make-parameter #f))

;; in xmaxima this gives a curve close to what I want: