Compare commits
1 Commits
Author | SHA1 | Date |
---|---|---|
|
c318ac10d0 |
|
@ -39,17 +39,16 @@ HOOK: mount-points os ( -- assoc )
|
|||
M: object mount-points
|
||||
file-systems [ [ mount-point>> ] keep ] H{ } map>assoc ;
|
||||
|
||||
: (find-mount-point) ( path assoc -- path )
|
||||
: (find-mount-point) ( path assoc -- object )
|
||||
[ resolve-symlinks canonicalize-path-full ] dip
|
||||
2dup at* [
|
||||
2nip
|
||||
] [
|
||||
drop [ parent-directory ] dip
|
||||
(find-mount-point)
|
||||
drop [ parent-directory ] dip (find-mount-point)
|
||||
] if ;
|
||||
|
||||
: find-mount-point ( path -- path' )
|
||||
mount-points (find-mount-point) mount-point>> ;
|
||||
: find-mount-point ( path -- object )
|
||||
mount-points (find-mount-point) ;
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "io.files.info.unix" ] }
|
||||
|
|
|
@ -68,9 +68,15 @@ frequency pass-number ;
|
|||
CHAR: \s [ "/etc/mtab" utf8 file>csv ] with-delimiter
|
||||
[ mtab-csv>mtab-entry ] map ;
|
||||
|
||||
: (file-system-info) ( path -- file-system-info )
|
||||
[ new-file-system-info ] dip
|
||||
[ file-system-statfs statfs>file-system-info ]
|
||||
[ file-system-statvfs statvfs>file-system-info ] bi
|
||||
file-system-calculations ; inline
|
||||
|
||||
: mtab-entry>file-system-info ( mtab-entry -- file-system-info/f )
|
||||
'[
|
||||
_ [ mount-point>> file-system-info ] keep
|
||||
_ [ mount-point>> (file-system-info) ] [ ] bi
|
||||
{
|
||||
[ file-system-name>> >>device-name ]
|
||||
[ mount-point>> >>mount-point ]
|
||||
|
@ -85,14 +91,8 @@ M: linux file-systems
|
|||
parse-mtab [ mtab-entry>file-system-info ] map sift ;
|
||||
|
||||
M: linux file-system-info ( path -- file-system-info )
|
||||
normalize-path
|
||||
[
|
||||
[ new-file-system-info ] dip
|
||||
[ file-system-statfs statfs>file-system-info ]
|
||||
[ file-system-statvfs statvfs>file-system-info ] bi
|
||||
file-system-calculations
|
||||
] keep
|
||||
find-mount-point-info
|
||||
normalize-path [ (file-system-info) ] [ ] bi
|
||||
find-mount-point
|
||||
{
|
||||
[ file-system-name>> >>device-name drop ]
|
||||
[ mount-point>> >>mount-point drop ]
|
||||
|
|
|
@ -7,7 +7,7 @@ IN: mason.disk
|
|||
: Gi ( n -- gibibits ) 30 2^ * ; inline
|
||||
|
||||
: sufficient-disk-space? ( -- ? )
|
||||
current-directory get find-mount-point
|
||||
current-directory get find-mount-point mount-point>>
|
||||
file-system-info available-space>> 1 Gi > ;
|
||||
|
||||
: check-disk-space ( -- )
|
||||
|
@ -18,7 +18,7 @@ IN: mason.disk
|
|||
: Gi-str ( n -- string ) 1 Gi /f ;
|
||||
|
||||
: path>disk-usage ( path -- string )
|
||||
find-mount-point file-system-info
|
||||
find-mount-point mount-point>> file-system-info
|
||||
[ used-space>> ] [ available-space>> ] [ total-space>> ] tri
|
||||
2dup /f 100 *
|
||||
[ [ Gi-str ] tri@ ] dip
|
||||
|
|
Loading…
Reference in New Issue