638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
|
(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)
|
|
|
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
|
(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 dbstruct) ;; *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)
|
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
|
;; check space in dbdir and in megatest dir
;; returns: ok/not dbspace required-space
;;
(define (common:check-db-dir-space)
(let* ((required (string->number
(or (configf:lookup *configdat* "setup" "dbdir-space-required")
"100000")))
(dbdir (common:get-db-tmp-area)) ;; (db:get-dbdir))
(tdbspace (common:check-space-in-dir dbdir required))
(mdbspace (common:check-space-in-dir *toppath* required)))
(sort (list tdbspace mdbspace) (lambda (a b)
(< (cadr a)(cadr b))))))
;; check available space in dbdir, exit if insufficient
;;
|
|
|
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
|
;; check space in dbdir and in megatest dir
;; returns: ok/not dbspace required-space
;;
(define (common:check-db-dir-space)
(let* ((required (string->number
(or (configf:lookup *configdat* "setup" "dbdir-space-required")
"100000")))
(dbdir (common:get-db-tmp-area #f)) ;; (db:get-dbdir))
(tdbspace (common:check-space-in-dir dbdir required))
(mdbspace (common:check-space-in-dir *toppath* required)))
(sort (list tdbspace mdbspace) (lambda (a b)
(< (cadr a)(cadr b))))))
;; check available space in dbdir, exit if insufficient
;;
|