18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
;;
;;======================================================================
;;======================================================================
;; Database access
;;======================================================================
(require-extension (srfi 18) extras tcp)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
(declare (uses db))
(include "common_records.scm")
(include "db_records.scm")
(include "key_records.scm")
(include "run_records.scm")
;;======================================================================
;;
;; T E S T D A T A B A S E S
;;
;;======================================================================
;;======================================================================
;; T E S T S P E C I F I C D B
;;======================================================================
;; Create the sqlite db for the individual test(s)
;;
;; Moved these tables into <runid>.db
;; THIS CODE TO BE REMOVED
;;
(define (open-test-db work-area)
(debug:print-info 11 *default-log-port* "open-test-db " work-area)
(if (and work-area
(directory? work-area)
(file-read-access? work-area))
(let* ((dbpath (conc work-area "/testdat.db"))
(dbexists (common:file-exists? dbpath))
(work-area-writeable (file-write-access? work-area))
(db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem
exn
(begin
(print-call-chain (current-error-port))
(debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
((condition-property-accessor 'exn 'message) exn))
(set! dbexists #f) ;; must force re-creation of tables, more tom-foolery
(sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access
(if (or work-area-writeable
dbexists)
(sqlite3:open-database dbpath)
(sqlite3:open-database ":memory:"))))
(tdb-writeable (and (file-write-access? work-area)
(file-write-access? dbpath)))
(handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000))))
(if (and tdb-writeable
*db-write-access*)
(sqlite3:set-busy-handler! db handler))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
;;
;;======================================================================
;;======================================================================
;; Database access
;;======================================================================
;; (require-extension (srfi 18) extras tcp)
;; (use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64)
;; (import (prefix sqlite3 sqlite3:))
;; (import (prefix base64 base64:))
;;
;; (declare (unit tdb))
;; (declare (uses common))
;; (declare (uses keys))
;; (declare (uses ods))
;; (declare (uses client))
;; (declare (uses mt))
;; (declare (uses db))
;;
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "key_records.scm")
;; (include "run_records.scm")
;;======================================================================
;;
;; T E S T D A T A B A S E S
;;
;;======================================================================
;;======================================================================
;; T E S T S P E C I F I C D B
;;======================================================================
;; Create the sqlite db for the individual test(s)
;;
;; Moved these tables into <runid>.db
;; THIS CODE TO BE REMOVED
;;
(define (open-test-db work-area)
(debug:print-info 11 *default-log-port* "open-test-db " work-area)
(if (and work-area
(directory? work-area)
(file-readable? work-area))
(let* ((dbpath (conc work-area "/testdat.db"))
(dbexists (common:file-exists? dbpath))
(work-area-writeable (file-writable? work-area))
(db (handle-exceptions ;; open the db if area writeable or db pre-existing. open in-mem otherwise. if exception, open in-mem
exn
(begin
(print-call-chain (current-error-port))
(debug:print 2 *default-log-port* "ERROR: problem accessing test db " work-area ", you probably should clean and re-run this test"
((condition-property-accessor 'exn 'message) exn))
(set! dbexists #f) ;; must force re-creation of tables, more tom-foolery
(sqlite3:open-database ":memory:")) ;; open an in-memory db to allow readonly access
(if (or work-area-writeable
dbexists)
(sqlite3:open-database dbpath)
(sqlite3:open-database ":memory:"))))
(tdb-writeable (and (file-writable? work-area)
(file-writable? dbpath)))
(handler (sqlite3:make-busy-timeout (if (args:get-arg "-override-timeout")
(string->number (args:get-arg "-override-timeout"))
136000))))
(if (and tdb-writeable
*db-write-access*)
(sqlite3:set-busy-handler! db handler))
|