| ︙ | | |
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
+
-
+
|
(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)
(use srfi-69 readline)
(module mtbody
*
(import scheme)
(cond-expand
(chicken-4
|
| ︙ | | |
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
+
|
files
matchable
md5
message-digest
pathname-expand
posix
posix-extras
readline
regex
regex-case
sparse-vectors
srfi-1
srfi-18
srfi-69
typed-records
|
| ︙ | | |
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
+
|
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")
|
| ︙ | | |
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
|
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
|
-
+
|
(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
#;(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")))
|
| ︙ | | |
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
|
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
|
-
+
-
+
-
-
+
+
-
+
-
-
+
+
-
+
-
+
-
+
|
(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))
(lockfile (conc dest-db".sync-lock"))
(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? lockfile)
(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? lockfile) (< age 20))
(debug:print 0 *default-log-port* "Lock "lockfile" exists, skipping sync...")
(if (and (file-exists? synclock-file) (< age 20))
(debug:print 0 *default-log-port* "Lock "synclock-file" exists, skipping sync...")
(begin
(if (file-exists? lockfile)
(if (file-exists? synclock-file)
(begin
(debug:print 0 *default-log-port* "Deleting old lock file " lockfile)
(delete-file lockfile)
(debug:print 0 *default-log-port* "Deleting old lock file " synclock-file)
(delete-file synclock-file)
)
)
(dbfile:with-simple-file-lock
lockfile
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 lockfile)
(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 " lockfile)
(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")
|
| ︙ | | |