Merge commit 'origin/master' into emacs

basis/core-foundation/run-loop/run-loop.factor

@@ -19,9 +19,9 @@ FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
 FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
 
 FUNCTION: SInt32 CFRunLoopRunInMode (
-   CFStringRef mode,
+    CFStringRef mode,
-   CFTimeInterval seconds,
+    CFTimeInterval seconds,
-   Boolean returnAfterSourceHandled
+    Boolean returnAfterSourceHandled
 ) ;
 
 FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
@@ -31,27 +31,27 @@ FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
 ) ;
 
 FUNCTION: void CFRunLoopAddSource (
-   CFRunLoopRef rl,
+    CFRunLoopRef rl,
-   CFRunLoopSourceRef source,
+    CFRunLoopSourceRef source,
-   CFStringRef mode
+    CFStringRef mode
 ) ;
 
 FUNCTION: void CFRunLoopRemoveSource (
-   CFRunLoopRef rl,
+    CFRunLoopRef rl,
-   CFRunLoopSourceRef source,
+    CFRunLoopSourceRef source,
-   CFStringRef mode
+    CFStringRef mode
 ) ;
 
 FUNCTION: void CFRunLoopAddTimer (
-   CFRunLoopRef rl,
+    CFRunLoopRef rl,
-   CFRunLoopTimerRef timer,
+    CFRunLoopTimerRef timer,
-   CFStringRef mode
+    CFStringRef mode
 ) ;
 
 FUNCTION: void CFRunLoopRemoveTimer (
-   CFRunLoopRef rl,
+    CFRunLoopRef rl,
-   CFRunLoopTimerRef timer,
+    CFRunLoopTimerRef timer,
-   CFStringRef mode
+    CFStringRef mode
 ) ;
 
 : CFRunLoopDefaultMode ( -- alien )

basis/core-foundation/strings/strings.factor

@@ -23,11 +23,11 @@ TYPEDEF: int CFStringEncoding
 : kCFStringEncodingUTF32LE HEX: 1c000100 ;
 
 FUNCTION: CFStringRef CFStringCreateWithBytes (
-   CFAllocatorRef alloc,
+    CFAllocatorRef alloc,
-   UInt8* bytes,
+    UInt8* bytes,
-   CFIndex numBytes,
+    CFIndex numBytes,
-   CFStringEncoding encoding,
+    CFStringEncoding encoding,
-   Boolean isExternalRepresentation
+    Boolean isExternalRepresentation
 ) ;
 
 FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
@@ -35,16 +35,16 @@ FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
 FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
 
 FUNCTION: Boolean CFStringGetCString (
-   CFStringRef theString,
+    CFStringRef theString,
-   char* buffer,
+    char* buffer,
-   CFIndex bufferSize,
+    CFIndex bufferSize,
-   CFStringEncoding encoding
+    CFStringEncoding encoding
 ) ;
 
 FUNCTION: CFStringRef CFStringCreateWithCString (
-   CFAllocatorRef alloc,
+    CFAllocatorRef alloc,
-   char* cStr,
+    char* cStr,
-   CFStringEncoding encoding
+    CFStringEncoding encoding
 ) ;
 
 : <CFString> ( string -- alien )

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
+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
 
 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
-    
+    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 ]
         [ 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 ] keep ;
-        [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
-        [ ]
-    } cleave ;
 
 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
@@ -15,9 +15,38 @@ HELP: copy-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 } "." } ;
+
+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 ;
+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,8 @@
 ! 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.links.private io.files.types io.pathnames kernel math
+namespaces system unix vocabs.loader ;
 IN: io.files.links
 
 HOOK: make-link os ( target symlink -- )
@@ -10,4 +12,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-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) ;

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 ;

basis/x11/xim/xim.factor

@@ -9,14 +9,14 @@ IN: x11.xim
 SYMBOL: xim
 
 : (init-xim) ( classname medifier -- im )
-   XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
+    XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
-   [ dpy get f ] dip dup XOpenIM ;
+    [ dpy get f ] dip dup XOpenIM ;
 
 : init-xim ( classname -- )
-   dup "" (init-xim)
+    dup "" (init-xim)
-   [ nip ]
+    [ nip ]
-   [ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
+    [ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
-   xim set-global ;
+    xim set-global ;
 
 : close-xim ( -- )
     xim get-global XCloseIM drop f xim set-global ;