131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
(define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another
(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
(define *task-db* #f) ;; (vector db path-to-db)
(define *db-access-allowed* #t) ;; flag to allow access
(define *db-access-mutex* (make-mutex))
(define *db-transaction-mutex* (make-mutex))
(define *db-cache-path* #f)
(define *db-with-db-mutex* (make-mutex))
(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times)
;; no sync db
(define *no-sync-db* #f)
;; SERVER
(define *my-client-signature* #f)
|
|
|
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
(define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another
(define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync*
;; task db
(define *task-db* #f) ;; (vector db path-to-db)
(define *db-access-allowed* #t) ;; flag to allow access
(define *db-access-mutex* (make-mutex))
(define *db-transaction-mutex* (make-mutex))
;; (define *db-cache-path* #f)
(define *db-with-db-mutex* (make-mutex))
(define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times)
;; no sync db
(define *no-sync-db* #f)
;; SERVER
(define *my-client-signature* #f)
|
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
|
(getenv "MT_TESTSUITE_NAME")
(if (string? *toppath* )
(pathname-file *toppath*)
#f))) ;; (pathname-file (current-directory)))))
(define common:get-area-name common:get-testsuite-name)
(define (common:get-db-tmp-area . junk)
(if *db-cache-path*
*db-cache-path*
(if *toppath* ;; common:get-create-writeable-dir
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
(exit 1))
(let ((dbpath (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
(common:get-testsuite-name) "/"
(string-translate *toppath* "/" ".")))))) ;; #t))))
(set! *db-cache-path* dbpath)
dbpath))
#f)))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
(define (common:get-signature str)
(message-digest-string (md5-primitive) str))
|
>
>
>
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
|
(getenv "MT_TESTSUITE_NAME")
(if (string? *toppath* )
(pathname-file *toppath*)
#f))) ;; (pathname-file (current-directory)))))
(define common:get-area-name common:get-testsuite-name)
;; WARNING: This code falls back to using the global Megatest
;; variable *toppath*
;;
(define (common:get-db-tmp-area dbstruct)
(if (and dbstruct (dbr:dbstruct-tmpdb-path dbstruct)) ;; *db-cache-path*
(dbr:dbstruct-tmpdb-path) ;; *db-cache-path*
(let ((toppath (or (and dbstruct (dbr:dbstruct-area-path dbstruct)) *toppath*))
(tsname (or (and dbstruct (dbr:dbstruct-area-name dbstruct))(common:get-testsuite-name))))
(if toppath ;; common:get-create-writeable-dir
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir)
(exit 1))
(let ((dbpath (common:get-create-writeable-dir
(list (conc "/tmp/" (current-user-name)
"/megatest_localdb/"
tsname "/"
(string-translate toppath "/" ".")))))) ;; #t))))
;; (set! *db-cache-path* dbpath)
(if dbstruct (dbr:dbstruct-tmpdb-path-set! dbstruct dbpath))
dbpath))
#f))))
(define (common:get-area-path-signature)
(message-digest-string (md5-primitive) *toppath*))
(define (common:get-signature str)
(message-digest-string (md5-primitive) str))
|