| ︙ | | |
15
16
17
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
|
15
16
17
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
|
-
+
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
(declare (unit dbfile))
;; (declare (uses debugprint))
|
| ︙ | | |
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
+
|
srfi-69
stack
system-information
;; files
;; ports
commonmod
debugprint
)
;; (import debugprint)
;;======================================================================
;; R E C O R D S
;;======================================================================
|
| ︙ | | |
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
|
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
|
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
-
+
|
)
(dbfile:print-err " db, " (dbr:dbdat-dbfile tmpdb) " already exists or fresh enough, not propogating data from\n " (dbr:dbdat-dbfile mtdb) " mod time delta: " modtimedelta) )
;; (db:multi-db-sync subdb 'old2new)) ;; migrate data from megatest.db automatically
tmpdb))
(define (dbfile:cautious-open-database fname init-proc #!optional (tries-left 50))
e-access? fname))
(dir-access (file-write-access? (pathname-directory fname)))
(retry (lambda ()
(thread-sleep! delay-time)
(if (> tries-left 0)
(dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
(if (and (file-write-access? fname)
(if (and (file-writable? fname)
(file-exists? busy-file))
(begin
(dbfile:print-err "INFO: dbfile:cautious-open-database: journal file " busy-file " exists, trying again in few seconds.")
(thread-sleep! 1)
(if (eq? tries-left 2)
(begin
(dbfile:print-err "INFO: forcing journal rollup "busy-file)
|
| ︙ | | |
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
|
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
|
-
+
-
+
|
(retry))
(exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.")
(retry))
(exn ()
(dbfile:print-err exn "ERROR: Unknown error with database " fname " message: "
((condition-property-accessor 'exn 'message) exn))
(retry)))))
#;(if (file-write-access? fname)
#;(if (file-writable? fname)
(dbfile:simple-file-release-lock lock-file))
result))))
(define (dbfile:brute-force-salvage-db fname)
(let* ((backupfname (conc fname"-"(current-process-id)".bak"))
(cmd (conc "cp "fname" "backupfname";mv "fname" "(conc fname ".delme;")
"cp "backupfname" "fname)))
(dbfile:print-err "WARNING: attempting recovery of file "fname" by running commands:\n"
" "cmd)
(system cmd)))
#;(define (dbfile:cautious-open-database-orig fname init-proc #!optional (tries-left 50))
(let* ((lock-file (conc fname".lock"))
(delay-time (* (- 51 tries-left) 1.1))
(retry (lambda ()
(thread-sleep! delay-time)
(if (> tries-left 0)
(dbfile:cautious-open-database fname init-proc (- tries-left 1))))))
(assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up."))
(if (and (file-write-access? fname) (not (dbfile:simple-file-lock lock-file expire-time: 3)))
(if (and (file-writable? fname) (not (dbfile:simple-file-lock lock-file expire-time: 3)))
(begin
(dbfile:print-err "INFO: dbfile:cautious-open-database: lock file " lock-file " exists, trying again in few seconds.")
(thread-sleep! 1)
(if (eq? tries-left 2)
(begin
(dbfile:print-err "INFO: stealing the lock "lock-file)
(delete-file* lock-file)))
|
| ︙ | | |
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
|
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
|
-
+
|
(retry))
(exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.")
(retry))
(exn ()
(dbfile:print-err exn "ERROR: Unknown error with database " fname " message: "
((condition-property-accessor 'exn 'message) exn))
(retry)))))
(if (file-write-access? fname)
(if (file-writable? fname)
(dbfile:simple-file-release-lock lock-file)
)
result))))
(define (dbfile:open-no-sync-db dbpath)
(if *no-sync-db*
|
| ︙ | | |