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" ] }
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
[
[ 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 ]
-! 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