Add follow-link/follow-links, use it in file-system-info on linux. add

docs and unit tests.  fix indentation
db4
erg 2008-12-18 18:32:00 -06:00
parent cfca27ba5f
commit 7103cc3cda
6 changed files with 103 additions and 14 deletions

View File

@ -3,8 +3,9 @@
USING: accessors alien.c-types alien.syntax combinators csv USING: accessors alien.c-types alien.syntax combinators csv
io.backend io.encodings.utf8 io.files io.files.info io.streams.string io.backend io.encodings.utf8 io.files io.files.info io.streams.string
io.files.unix kernel math.order namespaces sequences sorting io.files.unix kernel math.order namespaces sequences sorting
system unix unix.statfs.linux unix.statvfs.linux system unix unix.statfs.linux unix.statvfs.linux io.files.links.unix
specialized-arrays.direct.uint arrays io.files.info.unix ; specialized-arrays.direct.uint arrays io.files.info.unix assocs
io.pathnames ;
IN: io.files.info.unix.linux IN: io.files.info.unix.linux
TUPLE: linux-file-system-info < unix-file-system-info TUPLE: linux-file-system-info < unix-file-system-info
@ -70,6 +71,16 @@ M: linux file-systems
} cleave } cleave
] map ; ] map ;
: (find-mount-point) ( path mtab-paths -- mtab-entry )
[ follow-links ] dip 2dup at* [
2nip
] [
drop [ parent-directory ] dip (find-mount-point)
] if ;
: find-mount-point ( path -- mtab-entry )
parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
ERROR: file-system-not-found ; ERROR: file-system-not-found ;
M: linux file-system-info ( path -- ) M: linux file-system-info ( path -- )
@ -80,9 +91,7 @@ M: linux file-system-info ( path -- )
[ file-system-statvfs statvfs>file-system-info ] bi [ file-system-statvfs statvfs>file-system-info ] bi
file-system-calculations file-system-calculations
] keep ] keep
find-mount-point
parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort
[ mount-point>> head? ] with find nip [ file-system-not-found ] unless*
{ {
[ file-system-name>> >>device-name drop ] [ file-system-name>> >>device-name drop ]
[ mount-point>> >>mount-point drop ] [ mount-point>> >>mount-point drop ]

View File

@ -102,10 +102,7 @@ M: windows link-info ( path -- info )
[ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ; [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
: calculate-file-system-info ( file-system-info -- file-system-info' ) : calculate-file-system-info ( file-system-info -- file-system-info' )
{ [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ;
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
[ ]
} cleave ;
TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ; TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ;

View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io.files.info ; USING: help.markup help.syntax io.files.info math ;
IN: io.files.links IN: io.files.links
HELP: make-link HELP: make-link
@ -15,9 +15,38 @@ HELP: copy-link
{ make-link read-link copy-link } related-words { make-link read-link copy-link } related-words
HELP: follow-link
{ $values
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Returns an absolute path from " { $link read-link } "." } ;
HELP: follow-links
{ $values
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Follows a chain of symlinks up to " { $link symlink-depth } "." } ;
HELP: symlink-depth
{ $values
{ "value" integer }
}
{ $description "The number of redirections " { $link follow-links } " will follow." } ;
HELP: too-many-symlinks
{ $values
{ "path" "a pathname string" } { "n" integer }
}
{ $description "An error thrown when the number of redirections in a chain of symlinks surpasses the value in the " { $link symlink-depth } " variable." } ;
ARTICLE: "io.files.links" "Symbolic links" ARTICLE: "io.files.links" "Symbolic links"
"Reading and creating links:" "Reading links:"
{ $subsection read-link } { $subsection read-link }
{ $subsection follow-link }
{ $subsection follow-links }
"Creating links:"
{ $subsection make-link } { $subsection make-link }
"Copying links:" "Copying links:"
{ $subsection copy-link } { $subsection copy-link }

View File

@ -0,0 +1,31 @@
USING: io.directories io.files.links tools.test
io.files.unique tools.files ;
IN: io.files.links.tests
: make-test-links ( n path -- )
[ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ]
[ [ number>string ] dip prepend touch-file ] 2bi ; inline
[ t ] [
[
5 "lol" make-test-links
"lol1" follow-links
current-directory get "lol5" append-path =
] with-unique-directory
] unit-test
[
[
100 "laf" make-test-links "laf1" follow-links
] with-unique-directory
] [ too-many-symlinks? ] must-fail-with
[ t ] [
110 symlink-depth [
[
100 "laf" make-test-links
"laf1" follow-links
current-directory get "laf100" append-path =
] with-unique-directory
] with-variable
] unit-test

View File

@ -1,6 +1,8 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman. ! Copyright (C) 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: system kernel vocabs.loader ; USING: accessors io.backend io.files.info
io.files.links.private io.files.types io.pathnames kernel math
namespaces system unix vocabs.loader ;
IN: io.files.links IN: io.files.links
HOOK: make-link os ( target symlink -- ) HOOK: make-link os ( target symlink -- )
@ -10,4 +12,25 @@ HOOK: read-link os ( symlink -- path )
: copy-link ( target symlink -- ) : copy-link ( target symlink -- )
[ read-link ] dip make-link ; [ read-link ] dip make-link ;
os unix? [ "io.files.links.unix" require ] when os unix? [ "io.files.links.unix" require ] when
: follow-link ( path -- path' )
[ parent-directory ] [ read-symbolic-link ] bi append-path ;
SYMBOL: symlink-depth
10 symlink-depth set-global
ERROR: too-many-symlinks path n ;
<PRIVATE
: (follow-links) ( n path -- path' )
over 0 = [ symlink-depth get too-many-symlinks ] when
dup link-info type>> +symbolic-link+ =
[ [ 1- ] [ follow-link ] bi* (follow-links) ]
[ nip ] if ; inline recursive
PRIVATE>
: follow-links ( path -- path' )
[ symlink-depth get ] dip normalize-path (follow-links) ;

View File

@ -7,4 +7,4 @@ M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ; normalize-path symlink io-error ;
M: unix read-link ( path -- path' ) M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ; normalize-path read-symbolic-link ;