make copy-tree and delete-tree symlink aware

core/io/files/files.factor

@@ -3,7 +3,7 @@
 USING: io.backend io.files.private io hashtables kernel math
 memory namespaces sequences strings assocs arrays definitions
 system combinators splitting sbufs continuations io.encodings
-io.encodings.binary init ;
+io.encodings.binary init accessors ;
 IN: io.files
 
 HOOK: (file-reader) io-backend ( path -- stream )
@@ -145,8 +145,14 @@ PRIVATE>
 TUPLE: file-info type size permissions modified ;
 
 HOOK: file-info io-backend ( path -- info )
+
+! Symlinks
 HOOK: link-info io-backend ( path -- info )
 
+HOOK: make-link io-backend ( path1 path2 -- )
+
+HOOK: read-link io-backend ( path -- info )
+
 SYMBOL: +regular-file+
 SYMBOL: +directory+
 SYMBOL: +character-device+
@@ -218,14 +224,14 @@ HOOK: delete-file io-backend ( path -- )
 
 HOOK: delete-directory io-backend ( path -- )
 
-: (delete-tree) ( path dir? -- )
-    [
-        dup directory* [ (delete-tree) ] assoc-each
-        delete-directory
-    ] [ delete-file ] if ;
-
 : delete-tree ( path -- )
-    dup directory? (delete-tree) ;
+    dup link-info type>> +directory+ = [
+        dup directory over [
+            [ first delete-tree ] each
+        ] with-directory delete-directory
+    ] [
+        delete-file
+    ] if ;
 
 : to-directory over file-name append-path ;
 
@@ -258,10 +264,10 @@ M: object copy-file
 DEFER: copy-tree-into
 
 : copy-tree ( from to -- )
-    over directory? [
+    over link-info type>> +directory+ = [
-        >r dup directory swap r> [
+        >r dup directory r> rot [
-            >r swap first append-path r> copy-tree-into
+            [ >r first r> copy-tree-into ] curry each
-        ] 2curry each
+        ] with-directory
     ] [
         copy-file
     ] if ;

extra/io/unix/files/files.factor

@@ -3,7 +3,7 @@
 USING: io.backend io.nonblocking io.unix.backend io.files io
 unix unix.stat unix.time kernel math continuations
 math.bitfields byte-arrays alien combinators calendar
-io.encodings.binary ;
+io.encodings.binary accessors sequences strings ;
 
 IN: io.unix.files
 
@@ -49,7 +49,7 @@ M: unix-io touch-file ( path -- )
     close ;
 
 M: unix-io move-file ( from to -- )
-    [ normalize-pathname ] 2apply rename io-error ;
+    [ normalize-pathname ] bi@ rename io-error ;
 
 M: unix-io delete-file ( path -- )
     normalize-pathname unlink io-error ;
@@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- )
     ] with-disposal ;
 
 M: unix-io copy-file ( from to -- )
-    [ normalize-pathname ] 2apply
+    [ normalize-pathname ] bi@
     [ (copy-file) ]
     [ swap file-info file-info-permissions chmod io-error ]
     2bi ;
@@ -84,7 +84,7 @@ M: unix-io copy-file ( from to -- )
         { [ dup S_ISLNK  ] [ +symbolic-link+    ] }
         { [ dup S_ISSOCK ] [ +socket+           ] }
         { [ t            ] [ +unknown+          ] }
-      } cond nip ;
+    } cond nip ;
 
 : stat>file-info ( stat -- info )
     {
@@ -100,3 +100,14 @@ M: unix-io file-info ( path -- info )
 
 M: unix-io link-info ( path -- info )
     normalize-pathname lstat* stat>file-info ;
+
+M: unix-io make-link ( path1 path2 -- )
+    normalize-pathname symlink io-error ;
+
+M: unix-io read-link ( path -- path' )
+    normalize-pathname
+    PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
+    dup io-error head-slice >string ;
+
+: copy-link ( path1 path2 -- )
+    >r read-link r> make-link ;

extra/unix/unix.factor

@@ -77,6 +77,7 @@ FUNCTION: int pclose ( void* file ) ;
 FUNCTION: int pipe ( int* filedes ) ;
 FUNCTION: void* popen ( char* command, char* type ) ;
 FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
+FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
 FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ;
 FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;
 FUNCTION: int rename ( char* from, char* to ) ;
@@ -93,6 +94,7 @@ FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_
 FUNCTION: int setuid ( uid_t uid ) ;
 FUNCTION: int socket ( int domain, int type, int protocol ) ;
 FUNCTION: char* strerror ( int errno ) ;
+FUNCTION: int symlink ( char* path1, char* path2 ) ;
 FUNCTION: int system ( char* command ) ;
 FUNCTION: int unlink ( char* path ) ;
 FUNCTION: int utimes ( char* path, timeval[2] times ) ;
@@ -102,6 +104,8 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ;
 
 FUNCTION: int kill ( pid_t pid, int sig ) ;
 
+: PATH_MAX 1024 ; inline
+
 : PRIO_PROCESS 0 ; inline
 : PRIO_PGRP 1 ; inline
 : PRIO_USER 2 ; inline