Compare commits

...

1 Commits

Author SHA1 Message Date
Doug Coleman c318ac10d0 io.files.info: Fix linux file-system-info recursion 2020-01-05 13:22:01 -06:00
3 changed files with 15 additions and 16 deletions

View File

@ -39,17 +39,16 @@ HOOK: mount-points os ( -- assoc )
M: object mount-points M: object mount-points
file-systems [ [ mount-point>> ] keep ] H{ } map>assoc ; 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 [ resolve-symlinks canonicalize-path-full ] dip
2dup at* [ 2dup at* [
2nip 2nip
] [ ] [
drop [ parent-directory ] dip drop [ parent-directory ] dip (find-mount-point)
(find-mount-point)
] if ; ] if ;
: find-mount-point ( path -- path' ) : find-mount-point ( path -- object )
mount-points (find-mount-point) mount-point>> ; mount-points (find-mount-point) ;
{ {
{ [ os unix? ] [ "io.files.info.unix" ] } { [ os unix? ] [ "io.files.info.unix" ] }

View File

@ -68,9 +68,15 @@ frequency pass-number ;
CHAR: \s [ "/etc/mtab" utf8 file>csv ] with-delimiter CHAR: \s [ "/etc/mtab" utf8 file>csv ] with-delimiter
[ mtab-csv>mtab-entry ] map ; [ 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 ) : 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 ] [ file-system-name>> >>device-name ]
[ mount-point>> >>mount-point ] [ mount-point>> >>mount-point ]
@ -85,14 +91,8 @@ M: linux file-systems
parse-mtab [ mtab-entry>file-system-info ] map sift ; parse-mtab [ mtab-entry>file-system-info ] map sift ;
M: linux file-system-info ( path -- file-system-info ) M: linux file-system-info ( path -- file-system-info )
normalize-path normalize-path [ (file-system-info) ] [ ] bi
[ find-mount-point
[ 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
{ {
[ file-system-name>> >>device-name drop ] [ file-system-name>> >>device-name drop ]
[ mount-point>> >>mount-point drop ] [ mount-point>> >>mount-point drop ]

View File

@ -7,7 +7,7 @@ IN: mason.disk
: Gi ( n -- gibibits ) 30 2^ * ; inline : Gi ( n -- gibibits ) 30 2^ * ; inline
: sufficient-disk-space? ( -- ? ) : sufficient-disk-space? ( -- ? )
current-directory get find-mount-point current-directory get find-mount-point mount-point>>
file-system-info available-space>> 1 Gi > ; file-system-info available-space>> 1 Gi > ;
: check-disk-space ( -- ) : check-disk-space ( -- )
@ -18,7 +18,7 @@ IN: mason.disk
: Gi-str ( n -- string ) 1 Gi /f ; : Gi-str ( n -- string ) 1 Gi /f ;
: path>disk-usage ( path -- string ) : 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 [ used-space>> ] [ available-space>> ] [ total-space>> ] tri
2dup /f 100 * 2dup /f 100 *
[ [ Gi-str ] tri@ ] dip [ [ Gi-str ] tri@ ] dip