make a generic protocol for filling in the file-system-info obj in io.unix.files
Doug Coleman
parent
1f7b5ef6d0
commit
2a34339e65
|
|
@ -6,7 +6,7 @@ math.bitwise byte-arrays alien combinators calendar
|
|||
io.encodings.binary accessors sequences strings system
|
||||
io.files.private destructors vocabs.loader calendar.unix
|
||||
unix.stat alien.c-types arrays unix.users unix.groups
|
||||
environment fry io.encodings.utf8 alien.strings unix.statfs
|
||||
environment fry io.encodings.utf8 alien.strings
|
||||
combinators.short-circuit ;
|
||||
IN: io.unix.files
|
||||
|
||||
|
|
@ -76,15 +76,64 @@ M: unix copy-file ( from to -- )
|
|||
[ swap file-info permissions>> chmod io-error ]
|
||||
2bi ;
|
||||
|
||||
HOOK: stat>file-info os ( stat -- file-info )
|
||||
TUPLE: unix-file-system-info < file-system-info
|
||||
block-size preferred-block-size
|
||||
blocks blocks-free blocks-available
|
||||
files files-free files-available
|
||||
name-max flags id ;
|
||||
|
||||
HOOK: stat>type os ( stat -- file-info )
|
||||
HOOK: new-file-system-info os ( -- file-system-info )
|
||||
|
||||
HOOK: new-file-info os ( -- class )
|
||||
M: unix new-file-system-info ( -- ) unix-file-system-info new ;
|
||||
|
||||
HOOK: file-system-statfs os ( path -- statfs )
|
||||
|
||||
M: unix file-system-statfs drop f ;
|
||||
|
||||
HOOK: file-system-statvfs os ( path -- statvfs )
|
||||
|
||||
M: unix file-system-statvfs drop f ;
|
||||
|
||||
HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' )
|
||||
|
||||
M: unix statfs>file-system-info drop ;
|
||||
|
||||
HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' )
|
||||
|
||||
M: unix statvfs>file-system-info drop ;
|
||||
|
||||
: file-system-calculations ( file-system-info -- file-system-info' )
|
||||
{
|
||||
[ dup [ blocks-available>> ] [ block-size>> ] bi * >>free-space drop ]
|
||||
[ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ]
|
||||
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
||||
M: unix 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 ;
|
||||
|
||||
os {
|
||||
{ linux [ "io.unix.files.linux" require ] }
|
||||
{ macosx [ "io.unix.files.macosx" require ] }
|
||||
{ freebsd [ "io.unix.files.freebsd" require ] }
|
||||
{ netbsd [ "io.unix.files.netbsd" require ] }
|
||||
{ openbsd [ "io.unix.files.openbsd" require ] }
|
||||
} case
|
||||
|
||||
TUPLE: unix-file-info < file-info uid gid dev ino
|
||||
nlink rdev blocks blocksize ;
|
||||
|
||||
HOOK: new-file-info os ( -- file-info )
|
||||
|
||||
HOOK: stat>file-info os ( stat -- file-info )
|
||||
|
||||
HOOK: stat>type os ( stat -- file-info )
|
||||
|
||||
M: unix file-info ( path -- info )
|
||||
normalize-path file-status stat>file-info ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,24 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel unix math accessors
|
||||
combinators system io.backend alien.c-types unix.statfs
|
||||
io.files ;
|
||||
IN: io.unix.files.freebsd
|
||||
|
||||
M: freebsd file-system-statvfs ( path -- byte-array )
|
||||
"statvfs" <c-object> tuck statvfs io-error ;
|
||||
|
||||
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
|
||||
{
|
||||
[ statvfs-f_bavail >>blocks-available ]
|
||||
[ statvfs-f_bfree >>blocks-free ]
|
||||
[ statvfs-f_blocks >>blocks ]
|
||||
[ statvfs-f_favail >>files-available ]
|
||||
[ statvfs-f_ffree >>files-free ]
|
||||
[ statvfs-f_files >>files ]
|
||||
[ statvfs-f_bsize >>block-size ]
|
||||
[ statvfs-f_flag >>flags ]
|
||||
[ statvfs-f_frsize >>preferred-block-size ]
|
||||
[ statvfs-f_fsid >>id ]
|
||||
[ statvfs-f_namemax >>name-max ]
|
||||
} cleave ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
IN: io.unix.files.linux
|
||||
|
||||
TUPLE: linux-file-system-info < unix-file-system-info
|
||||
namelen spare ;
|
||||
|
||||
M: linux new-file-system-info unix-file-system-info new ;
|
||||
|
||||
M: linux file-system-statfs ( path -- byte-array )
|
||||
"statfs64" <c-object> tuck statfs64 io-error ;
|
||||
|
||||
M: linux statfs>file-system-info ( struct -- statfs )
|
||||
{
|
||||
[ statfs64-f_type >>type ]
|
||||
[ statfs64-f_bsize >>block-size ]
|
||||
[ statfs64-f_blocks >>blocks ]
|
||||
[ statfs64-f_bfree >>blocks-free ]
|
||||
[ statfs64-f_bavail >>blocks-available ]
|
||||
[ statfs64-f_files >>files ]
|
||||
[ statfs64-f_ffree >>files-free ]
|
||||
[ statfs64-f_fsid >>id ]
|
||||
[ statfs64-f_namelen >>namelen ]
|
||||
[ statfs64-f_frsize >>preferred-block-size ]
|
||||
[ statfs64-f_spare >>spare ]
|
||||
} cleave ;
|
||||
|
||||
M: linux file-system-statvfs ( path -- byte-array )
|
||||
"statvfs64" <c-object> tuck statvfs64 io-error ;
|
||||
|
||||
M: linux statvfs>file-system-info ( struct -- statfs )
|
||||
{
|
||||
[ statvfs64-f_flag >>flags ]
|
||||
[ statvfs64-f_namemax >>name-max ]
|
||||
} cleave ;
|
||||
|
||||
M: linux file-systems
|
||||
parse-mtab [
|
||||
[ mount-point>> file-system-info ] keep
|
||||
{
|
||||
[ file-system-name>> >>device-name ]
|
||||
[ mount-point>> >>mount-point ]
|
||||
[ type>> >>type ]
|
||||
} cleave
|
||||
] map ;
|
||||
|
||||
TUPLE: mtab-entry file-system-name mount-point type options
|
||||
frequency pass-number ;
|
||||
|
||||
: mtab-csv>mtab-entry ( csv -- mtab-entry )
|
||||
[ mtab-entry new ] dip
|
||||
{
|
||||
[ first >>file-system-name ]
|
||||
[ second >>mount-point ]
|
||||
[ third >>type ]
|
||||
[ fourth <string-reader> csv first >>options ]
|
||||
[ 4 swap nth >>frequency ]
|
||||
[ 5 swap nth >>pass-number ]
|
||||
} cleave ;
|
||||
|
||||
: parse-mtab ( -- array )
|
||||
[
|
||||
"/etc/mtab" utf8 <file-reader>
|
||||
CHAR: \s delimiter set csv
|
||||
] with-scope
|
||||
[ mtab-csv>mtab-entry ] map ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.strings combinators
|
||||
grouping io.encodings.utf8 io.files kernel math sequences
|
||||
system unix unix.statfs.macosx io.unix.files unix.statvfs.macosx ;
|
||||
IN: io.unix.files.macosx
|
||||
|
||||
TUPLE: macosx-file-system-info < unix-file-system-info
|
||||
io-size owner type-id filesystem-subtype ;
|
||||
|
||||
M: macosx file-systems ( -- array )
|
||||
f <void*> dup 0 getmntinfo64 dup io-error
|
||||
[ *void* ] dip
|
||||
"statfs64" heap-size [ * memory>byte-array ] keep group
|
||||
[ [ new-file-system-info ] dip statfs>file-system-info ] map ;
|
||||
|
||||
M: macosx new-file-system-info macosx-file-system-info new ;
|
||||
|
||||
M: macosx file-system-statfs ( normalized-path -- statfs )
|
||||
"statfs64" <c-object> tuck statfs64 io-error ;
|
||||
|
||||
M: macosx file-system-statvfs ( normalized-path -- statvfs )
|
||||
"statvfs" <c-object> tuck statvfs io-error ;
|
||||
|
||||
M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
|
||||
{
|
||||
[ statfs64-f_bsize >>block-size ]
|
||||
[ statfs64-f_iosize >>io-size ]
|
||||
[ statfs64-f_blocks >>blocks ]
|
||||
[ statfs64-f_bfree >>blocks-free ]
|
||||
[ statfs64-f_bavail >>blocks-available ]
|
||||
[ statfs64-f_files >>files ]
|
||||
[ statfs64-f_ffree >>files-free ]
|
||||
[ statfs64-f_fsid >>id ]
|
||||
[ statfs64-f_owner >>owner ]
|
||||
[ statfs64-f_type >>type-id ]
|
||||
[ statfs64-f_flags >>flags ]
|
||||
[ statfs64-f_fssubtype >>filesystem-subtype ]
|
||||
[ statfs64-f_fstypename utf8 alien>string >>type ]
|
||||
[ statfs64-f_mntonname utf8 alien>string >>mount-point ]
|
||||
[ statfs64-f_mntfromname utf8 alien>string >>device-name ]
|
||||
} cleave ;
|
||||
|
||||
M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' )
|
||||
{
|
||||
[ statvfs-f_frsize >>preferred-block-size ]
|
||||
[ statvfs-f_favail >>files-available ]
|
||||
[ statvfs-f_namemax >>name-max ]
|
||||
} cleave ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel unix.stat math unix
|
||||
combinators system io.backend accessors alien.c-types
|
||||
io.encodings.utf8 alien.strings unix.types unix.statfs io.files ;
|
||||
IN: io.unix.files.netbsd
|
||||
|
||||
TUPLE: netbsd-file-system-info < unix-file-system-info
|
||||
owner io-size blocks-reserved
|
||||
sync-reads sync-writes async-reads async-writes
|
||||
fsidx fstype mnotonname mntfromname mount-from spare ;
|
||||
|
||||
M: netbsd file-system-statvfs
|
||||
"statvfs" <c-object> tuck statvfs io-error ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax accessors combinators kernel
|
||||
unix.types math system io.backend alien.c-types unix
|
||||
unix.statfs io.files ;
|
||||
IN: io.unix.files.openbsd
|
||||
|
||||
M: openbsd >file-system-info ( file-system-info statvfs -- file-system-info' )
|
||||
{
|
||||
[ statvfs-f_bsize >>block-size ]
|
||||
[ statvfs-f_frsize >>preferred-block-size ]
|
||||
[ statvfs-f_blocks >>blocks ]
|
||||
[ statvfs-f_bfree >>blocks-free ]
|
||||
[ statvfs-f_bavail >>blocks-avail ]
|
||||
[ statvfs-f_files >>files ]
|
||||
[ statvfs-f_ffree >>files-free ]
|
||||
[ statvfs-f_favail >>files-available ]
|
||||
[ statvfs-f_fsid >>id ]
|
||||
[ statvfs-f_flag >>flags ]
|
||||
[ statvfs-f_namemax >>name-max ]
|
||||
} cleave ;
|
||||
|
||||
M: openbsd file-system-statvfs ( normalized-path -- statvfs )
|
||||
"statvfs" <c-object> tuck statvfs io-error ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
Loading…
Reference in New Issue