;======================================================================
;; Copyright 2006-2016, 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/>.
;;
;;======================================================================
;; NOTE: This is the db module, long term it will replace db.scm.
;; WARN: This module conflicts with db.scm as it uses sql-de-lite
(declare (unit mtdb))
(declare (uses mtcommon))
(module mtdb
(
get-db-tmp-area
)
(import scheme chicken data-structures extras (prefix mtcommon common:))
(use (prefix sql-de-lite sql) posix typed-records)
(define *default-log-port* (current-error-port))
;;======================================================================
;; Database access
;;======================================================================
;;======================================================================
;; R E C O R D S
;;======================================================================
;; areas
;; run.db
;; runs => 1.db, 2.db ...
;; each db entry is a pair ( db . dbfilepath )
;; I propose this record evolves into the area record
;;
(defstruct dbr:dbstruct
(tmpdb #f)
(dbstack #f) ;; stack for tmp db handles, do not initialize with a stack
(mtdb #f)
(refndb #f)
(homehost #f) ;; not used yet
(on-homehost #f) ;; not used yet
(read-only #f)
) ;; goal is to converge on one struct for an area but for now it is too confusing
;; record for keeping state,status and count for doing roll-ups in
;; iterated tests
;;
(defstruct dbr:counts
(state #f)
(status #f)
(count 0))
;;======================================================================
;; SQLITE3 HELPERS
;;======================================================================
(define (general-sql-de-lite-error-dump exn stmt . params)
(let ((err-status ((condition-property-accessor 'sql-de-lite 'status #f) exn))) ;; RADT ... how does this work?
;; check for (exn sqlite3) ((condition-property-accessor 'exn 'message) exn)
(print "err-status: " err-status)
(common:print-error 0 *default-log-port* " query " stmt " failed, params: " params ", error: " ((condition-property-accessor 'exn 'message) exn))
(print-call-chain (current-error-port))))
;;======================================================================
;; Manage the /tmp/ db mirror area
;;======================================================================
(define (get-db-tmp-area area-path area-name)
(let ((dbdir (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
area-name "/"
(string-translate area-path "/" "."))))
(if area-path ;; common:get-create-writeable-dir
(handle-exceptions
exn
(begin
(common:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
(exit 1))
(let ((dbpath (common:get-create-writeable-dir
(list dbdir)))) ;; #t))))
dbpath))
#f)))
)