! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel system math math.bitwise strings arrays
-sequences combinators combinators.short-circuit alien.c-types
-vocabs.loader calendar calendar.unix io.files.info io.backend
-unix unix.stat unix.time unix.users unix.groups ;
+USING: accessors alien.c-types alien.data arrays calendar
+calendar.unix classes.struct combinators
+combinators.short-circuit io.backend io.directories
+io.files.info io.files.types kernel literals math math.bitwise
+sequences specialized-arrays strings system unix unix.ffi
+unix.groups unix.stat unix.time unix.users vocabs ;
IN: io.files.info.unix
+SPECIALIZED-ARRAY: timeval
TUPLE: unix-file-system-info < file-system-info
block-size preferred-block-size
HOOK: new-file-system-info os ( -- file-system-info )
-M: unix new-file-system-info ( -- ) unix-file-system-info new ;
+M: unix new-file-system-info unix-file-system-info new ;
HOOK: file-system-statfs os ( path -- statfs )
M: unix new-file-info ( -- class ) unix-file-info new ;
+CONSTANT: standard-unix-block-size 512
+
M: unix stat>file-info ( stat -- file-info )
[ new-file-info ] dip
{
[ stat>type >>type ]
- [ stat-st_size >>size ]
- [ stat-st_mode >>permissions ]
- [ stat-st_ctimespec timespec>unix-time >>created ]
- [ stat-st_mtimespec timespec>unix-time >>modified ]
- [ stat-st_atimespec timespec>unix-time >>accessed ]
- [ stat-st_uid >>uid ]
- [ stat-st_gid >>gid ]
- [ stat-st_dev >>dev ]
- [ stat-st_ino >>ino ]
- [ stat-st_nlink >>nlink ]
- [ stat-st_rdev >>rdev ]
- [ stat-st_blocks >>blocks ]
- [ stat-st_blksize >>blocksize ]
+ [ st_size>> >>size ]
+ [ st_mode>> >>permissions ]
+ [ st_ctimespec>> timespec>unix-time >>created ]
+ [ st_mtimespec>> timespec>unix-time >>modified ]
+ [ st_atimespec>> timespec>unix-time >>accessed ]
+ [ st_uid>> >>uid ]
+ [ st_gid>> >>gid ]
+ [ st_dev>> >>dev ]
+ [ st_ino>> >>ino ]
+ [ st_nlink>> >>nlink ]
+ [ st_rdev>> >>rdev ]
+ [ st_blocks>> >>blocks ]
+ [ st_blksize>> >>blocksize ]
+ [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
} cleave ;
: n>file-type ( n -- type )
} case ;
M: unix stat>type ( stat -- type )
- stat-st_mode n>file-type ;
+ st_mode>> n>file-type ;
<PRIVATE
: stat-mode ( path -- mode )
- normalize-path file-status stat-st_mode ;
+ normalize-path file-status st_mode>> ;
: chmod-set-bit ( path mask ? -- )
[ dup stat-mode ] 2dip
- [ bitor ] [ unmask ] if chmod io-error ;
+ [ bitor ] [ unmask ] if [ chmod ] unix-system-call drop ;
GENERIC# file-mode? 1 ( obj mask -- ? )
PRIVATE>
-: ch>file-type ( ch -- type )
- {
- { CHAR: b [ +block-device+ ] }
- { CHAR: c [ +character-device+ ] }
- { CHAR: d [ +directory+ ] }
- { CHAR: l [ +symbolic-link+ ] }
- { CHAR: s [ +socket+ ] }
- { CHAR: p [ +fifo+ ] }
- { CHAR: - [ +regular-file+ ] }
- [ drop +unknown+ ]
- } case ;
-
-: file-type>ch ( type -- string )
- {
- { +block-device+ [ CHAR: b ] }
- { +character-device+ [ CHAR: c ] }
- { +directory+ [ CHAR: d ] }
- { +symbolic-link+ [ CHAR: l ] }
- { +socket+ [ CHAR: s ] }
- { +fifo+ [ CHAR: p ] }
- { +regular-file+ [ CHAR: - ] }
- [ drop CHAR: - ]
- } case ;
-
-: UID OCT: 0004000 ; inline
-: GID OCT: 0002000 ; inline
-: STICKY OCT: 0001000 ; inline
-: USER-ALL OCT: 0000700 ; inline
-: USER-READ OCT: 0000400 ; inline
-: USER-WRITE OCT: 0000200 ; inline
-: USER-EXECUTE OCT: 0000100 ; inline
-: GROUP-ALL OCT: 0000070 ; inline
-: GROUP-READ OCT: 0000040 ; inline
-: GROUP-WRITE OCT: 0000020 ; inline
-: GROUP-EXECUTE OCT: 0000010 ; inline
-: OTHER-ALL OCT: 0000007 ; inline
-: OTHER-READ OCT: 0000004 ; inline
-: OTHER-WRITE OCT: 0000002 ; inline
-: OTHER-EXECUTE OCT: 0000001 ; inline
+CONSTANT: UID 0o0004000
+CONSTANT: GID 0o0002000
+CONSTANT: STICKY 0o0001000
+CONSTANT: USER-ALL 0o0000700
+CONSTANT: USER-READ 0o0000400
+CONSTANT: USER-WRITE 0o0000200
+CONSTANT: USER-EXECUTE 0o0000100
+CONSTANT: GROUP-ALL 0o0000070
+CONSTANT: GROUP-READ 0o0000040
+CONSTANT: GROUP-WRITE 0o0000020
+CONSTANT: GROUP-EXECUTE 0o0000010
+CONSTANT: OTHER-ALL 0o0000007
+CONSTANT: OTHER-READ 0o0000004
+CONSTANT: OTHER-WRITE 0o0000002
+CONSTANT: OTHER-EXECUTE 0o0000001
+CONSTANT: ALL-READ 0o0000444
+CONSTANT: ALL-WRITE 0o0000222
+CONSTANT: ALL-EXECUTE 0o0000111
: uid? ( obj -- ? ) UID file-mode? ;
: gid? ( obj -- ? ) GID file-mode? ;
: set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
: set-file-permissions ( path n -- )
- [ normalize-path ] dip chmod io-error ;
+ [ normalize-path ] dip [ chmod ] unix-system-call drop ;
: file-permissions ( path -- n )
normalize-path file-info permissions>> ;
-<PRIVATE
+: add-file-permissions ( path n -- )
+ over file-permissions bitor set-file-permissions ;
-: make-timeval-array ( array -- byte-array )
- [ [ "timeval" <c-object> ] unless* ] map concat ;
+: remove-file-permissions ( path n -- )
+ over file-permissions [ bitnot ] dip bitand set-file-permissions ;
+
+M: unix copy-file-and-info ( from to -- )
+ [ copy-file ] [ swap file-permissions set-file-permissions ] 2bi ;
+
+<PRIVATE
: timestamp>timeval ( timestamp -- timeval )
unix-1970 time- duration>microseconds make-timeval ;
: timestamps>byte-array ( timestamps -- byte-array )
- [ dup [ timestamp>timeval ] when ] map make-timeval-array ;
+ [ [ timestamp>timeval ] [ \ timeval <struct> ] if* ] map
+ timeval >c-array ;
PRIVATE>
: set-file-times ( path timestamps -- )
#! set access, write
[ normalize-path ] dip
- timestamps>byte-array utimes io-error ;
+ timestamps>byte-array [ utimes ] unix-system-call drop ;
: set-file-access-time ( path timestamp -- )
f 2array set-file-times ;
f swap 2array set-file-times ;
: set-file-ids ( path uid gid -- )
- [ normalize-path ] 2dip
- [ [ -1 ] unless* ] bi@ chown io-error ;
+ [ normalize-path ] 2dip [ -1 or ] bi@
+ [ chown ] unix-system-call drop ;
GENERIC: set-file-user ( path string/id -- )
: file-user-id ( path -- uid )
normalize-path file-info uid>> ;
-: file-username ( path -- string )
- file-user-id username ;
+: file-user-name ( path -- string )
+ file-user-id user-name ;
: file-group-id ( path -- gid )
normalize-path file-info gid>> ;
: file-group-name ( path -- string )
file-group-id group-name ;
+
+: ch>file-type ( ch -- type )
+ {
+ { CHAR: b [ +block-device+ ] }
+ { CHAR: c [ +character-device+ ] }
+ { CHAR: d [ +directory+ ] }
+ { CHAR: l [ +symbolic-link+ ] }
+ { CHAR: s [ +socket+ ] }
+ { CHAR: p [ +fifo+ ] }
+ { CHAR: - [ +regular-file+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+: file-type>ch ( type -- ch )
+ {
+ { +block-device+ [ CHAR: b ] }
+ { +character-device+ [ CHAR: c ] }
+ { +directory+ [ CHAR: d ] }
+ { +symbolic-link+ [ CHAR: l ] }
+ { +socket+ [ CHAR: s ] }
+ { +fifo+ [ CHAR: p ] }
+ { +regular-file+ [ CHAR: - ] }
+ [ drop CHAR: - ]
+ } case ;
+
+<PRIVATE
+
+: file-type>executable ( directory-entry -- string )
+ name>> any-execute? "*" "" ? ;
+
+PRIVATE>
+
+: file-type>trailing ( directory-entry -- string )
+ dup type>>
+ {
+ { +directory+ [ drop "/" ] }
+ { +symbolic-link+ [ drop "@" ] }
+ { +fifo+ [ drop "|" ] }
+ { +socket+ [ drop "=" ] }
+ { +whiteout+ [ drop "%" ] }
+ { +unknown+ [ file-type>executable ] }
+ { +regular-file+ [ file-type>executable ] }
+ [ drop file-type>executable ]
+ } case ;
+
+"io.files.info.unix." os name>> append require
projects / factor.git / blobdiff