Merge branch 'master' of git://factorcode.org/git/factor

basis/io/files/info/unix/linux/linux.factor

@@ -3,8 +3,9 @@
 USING: accessors alien.c-types alien.syntax combinators csv
 io.backend io.encodings.utf8 io.files io.files.info io.streams.string
 io.files.unix kernel math.order namespaces sequences sorting
-system unix unix.statfs.linux unix.statvfs.linux
-specialized-arrays.direct.uint arrays io.files.info.unix ;
+system unix unix.statfs.linux unix.statvfs.linux io.files.links
+specialized-arrays.direct.uint arrays io.files.info.unix assocs
+io.pathnames ;
 IN: io.files.info.unix.linux
 
 TUPLE: linux-file-system-info < unix-file-system-info
@@ -70,6 +71,16 @@ M: linux file-systems
         } cleave
     ] 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 ;
 
 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-calculations
     ] keep
-    
-    parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort
-    [ mount-point>> head? ] with find nip [ file-system-not-found ] unless*
+    find-mount-point
     {
         [ file-system-name>> >>device-name drop ]
         [ mount-point>> >>mount-point drop ]

basis/io/files/info/windows/windows.factor

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

basis/io/files/links/links-docs.factor

@@ -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
 
 HELP: make-link
@@ -13,11 +13,40 @@ HELP: copy-link
 { $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } }
 { $description "Copies a symbolic link without following the link." } ;
 
-{ 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 } "." } ;
+
+{ read-link follow-link follow-links } related-words
+
+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"
-"Reading and creating links:"
+"Reading links:"
 { $subsection read-link }
+{ $subsection follow-link }
+{ $subsection follow-links }
+"Creating links:"
 { $subsection make-link }
 "Copying links:"
 { $subsection copy-link }

basis/io/files/links/links-tests.factor

@@ -0,0 +1,31 @@
+USING: io.directories io.files.links tools.test
+io.files.unique tools.files fry ;
+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

basis/io/files/links/links.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel vocabs.loader ;
+USING: accessors io.backend io.files.info io.files.types
+io.pathnames kernel math namespaces system vocabs.loader ;
 IN: io.files.links
 
 HOOK: make-link os ( target symlink -- )
@@ -10,4 +11,25 @@ HOOK: read-link os ( symlink -- path )
 : copy-link ( target symlink -- )
     [ 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-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) ;

basis/io/files/links/unix/unix.factor

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