diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index f5c45881b6..57f7e730d2 100644 --- a/basis/io/files/info/info.factor +++ b/basis/io/files/info/info.factor @@ -34,6 +34,20 @@ HOOK: file-readable? os ( path -- ? ) HOOK: file-writable? os ( path -- ? ) HOOK: file-executable? os ( path -- ? ) +: mount-points ( -- assoc ) + file-systems [ [ mount-point>> ] keep ] H{ } map>assoc ; + +: (find-mount-point-info) ( path assoc -- mtab-entry ) + [ resolve-symlinks ] dip + 2dup at* [ + 2nip + ] [ + drop [ parent-directory ] dip (find-mount-point-info) + ] if ; + +: find-mount-point-info ( path -- file-system-info ) + mount-points (find-mount-point-info) ; + { { [ os unix? ] [ "io.files.info.unix" ] } { [ os windows? ] [ "io.files.info.windows" ] } diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index dd04aecf6d..1bf37532f1 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -81,17 +81,6 @@ frequency pass-number ; M: linux file-systems parse-mtab [ mtab-entry>file-system-info ] map sift ; -: (find-mount-point) ( path mtab-paths -- mtab-entry ) - 2dup at* [ - 2nip - ] [ - drop [ parent-directory ] dip (find-mount-point) - ] if ; - -: find-mount-point ( path -- mtab-entry ) - resolve-symlinks - parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ; - M: linux file-system-info ( path -- file-system-info ) normalize-path [ @@ -100,7 +89,7 @@ M: linux file-system-info ( path -- file-system-info ) [ file-system-statvfs statvfs>file-system-info ] bi file-system-calculations ] keep - find-mount-point + find-mount-point-info { [ file-system-name>> >>device-name drop ] [ mount-point>> >>mount-point drop ] diff --git a/extra/mason/disk/disk.factor b/extra/mason/disk/disk.factor index 214b8f13fe..88b0414fe4 100644 --- a/extra/mason/disk/disk.factor +++ b/extra/mason/disk/disk.factor @@ -1,26 +1,29 @@ -! Copyright (C) 2010 Slava Pestov. +! Copyright (C) 2010 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors io.files.info io.pathnames kernel mason.config -math math.parser namespaces sequences ; +USING: accessors formatting io.files.info io.pathnames kernel +mason.config math namespaces ; IN: mason.disk -: gb ( -- n ) 30 2^ ; inline +: Gi ( n -- gibibits ) 30 2^ * ; inline : sufficient-disk-space? ( -- ? ) - ! We want at least 300Mb to be available before starting - ! a build. - "." file-system-info available-space>> gb > ; + current-directory get find-mount-point-info + file-system-info available-space>> + 1 Gi > ; : check-disk-space ( -- ) sufficient-disk-space? [ - "Less than 1 Gb free disk space." throw + "Less than 1 Gi free disk space." throw ] unless ; -: mb-str ( n -- string ) gb /i number>string ; +: Gi-str ( n -- string ) 1 Gi /f ; + +: path>disk-usage ( path -- string ) + find-mount-point-info + [ used-space>> ] [ available-space>> ] [ total-space>> ] tri + 2dup /f 100 * + [ [ Gi-str ] tri@ ] dip + "%0.2fGi used, %0.2fGi avail, %0.2fGi total, %0.2f%% free" sprintf ; : disk-usage ( -- string ) - builds-dir get file-system-info - [ used-space>> ] [ total-space>> ] bi - [ [ mb-str ] bi@ " / " glue " Gb used" append ] - [ [ 100 * ] dip /i number>string "(" "%)" surround ] 2bi - " " glue ; + builds-dir get path>disk-usage ; \ No newline at end of file