| 
									
										
										
										
											2008-12-14 21:03:00 -05:00
										 |  |  | ! Copyright (C) 2008 Slava Pestov, Doug Coleman. | 
					
						
							|  |  |  | ! See http://factorcode.org/license.txt for BSD license. | 
					
						
							| 
									
										
										
										
											2008-12-18 19:40:01 -05:00
										 |  |  | USING: accessors io.backend io.files.info io.files.types | 
					
						
							| 
									
										
										
										
											2011-11-02 14:23:41 -04:00
										 |  |  | io.pathnames kernel math namespaces system vocabs ;
 | 
					
						
							| 
									
										
										
										
											2008-12-14 21:03:00 -05:00
										 |  |  | IN: io.files.links | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-12-14 22:21:44 -05:00
										 |  |  | HOOK: make-link os ( target symlink -- )
 | 
					
						
							| 
									
										
										
										
											2008-12-14 21:03:00 -05:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2009-04-28 23:51:35 -04:00
										 |  |  | HOOK: make-hard-link os ( target link -- )
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-12-14 22:21:44 -05:00
										 |  |  | HOOK: read-link os ( symlink -- path )
 | 
					
						
							| 
									
										
										
										
											2008-12-14 21:03:00 -05:00
										 |  |  | 
 | 
					
						
							|  |  |  | : copy-link ( target symlink -- )
 | 
					
						
							| 
									
										
										
										
											2008-12-14 22:21:44 -05:00
										 |  |  |     [ read-link ] dip make-link ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-12-18 19:32:00 -05:00
										 |  |  | os unix? [ "io.files.links.unix" require ] when
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : follow-link ( path -- path' )
 | 
					
						
							| 
									
										
										
										
											2008-12-18 20:32:09 -05:00
										 |  |  |     [ parent-directory ] [ read-link ] bi append-path ;
 | 
					
						
							| 
									
										
										
										
											2008-12-18 19:32:00 -05:00
										 |  |  | 
 | 
					
						
							|  |  |  | SYMBOL: symlink-depth | 
					
						
							|  |  |  | 10 symlink-depth set-global
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | ERROR: too-many-symlinks path n ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | <PRIVATE
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : (follow-links) ( n path -- path' )
 | 
					
						
							| 
									
										
										
										
											2015-08-13 19:13:05 -04:00
										 |  |  |     over 0 = [ symlink-depth get too-many-symlinks ] when
 | 
					
						
							| 
									
										
										
										
											2015-08-05 21:33:35 -04:00
										 |  |  |     dup link-info symbolic-link? | 
					
						
							| 
									
										
										
										
											2009-08-13 20:21:44 -04:00
										 |  |  |     [ [ 1 - ] [ follow-link ] bi* (follow-links) ] | 
					
						
							| 
									
										
										
										
											2008-12-18 19:32:00 -05:00
										 |  |  |     [ nip ] if ; inline recursive
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | PRIVATE>
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : follow-links ( path -- path' )
 | 
					
						
							|  |  |  |     [ symlink-depth get ] dip normalize-path (follow-links) ;
 |