mklink.pl revision 194206
1#!/usr/local/bin/perl 2 3# mklink.pl 4 5# The first command line argument is a non-empty relative path 6# specifying the "from" directory. 7# Each other argument is a file name not containing / and 8# names a file in the current directory. 9# 10# For each of these files, we create in the "from" directory a link 11# of the same name pointing to the local file. 12# 13# We assume that the directory structure is a tree, i.e. that it does 14# not contain symbolic links and that the parent of / is never referenced. 15# Apart from this, this script should be able to handle even the most 16# pathological cases. 17 18my $pwd; 19eval 'use Cwd;'; 20if ($@) 21 { 22 $pwd = `pwd`; 23 } 24else 25 { 26 $pwd = getcwd(); 27 } 28 29my $from = shift; 30my @files = @ARGV; 31 32my @from_path = split(/[\\\/]/, $from); 33chomp($pwd); 34my @pwd_path = split(/[\\\/]/, $pwd); 35 36my @to_path = (); 37 38my $dirname; 39foreach $dirname (@from_path) { 40 41 # In this loop, @to_path always is a relative path from 42 # @pwd_path (interpreted is an absolute path) to the original pwd. 43 44 # At the end, @from_path (as a relative path from the original pwd) 45 # designates the same directory as the absolute path @pwd_path, 46 # which means that @to_path then is a path from there to the original pwd. 47 48 next if ($dirname eq "" || $dirname eq "."); 49 50 if ($dirname eq "..") { 51 @to_path = (pop(@pwd_path), @to_path); 52 } else { 53 @to_path = ("..", @to_path); 54 push(@pwd_path, $dirname); 55 } 56} 57 58my $to = join('/', @to_path); 59 60my $file; 61$symlink_exists=eval {symlink("",""); 1}; 62foreach $file (@files) { 63 my $err = ""; 64 if ($symlink_exists) { 65 unlink "$from/$file"; 66 symlink("$to/$file", "$from/$file") or $err = " [$!]"; 67 } else { 68 unlink "$from/$file"; 69 open (OLD, "<$file") or die "Can't open $file: $!"; 70 open (NEW, ">$from/$file") or die "Can't open $from/$file: $!"; 71 binmode(OLD); 72 binmode(NEW); 73 while (<OLD>) { 74 print NEW $_; 75 } 76 close (OLD) or die "Can't close $file: $!"; 77 close (NEW) or die "Can't close $from/$file: $!"; 78 } 79 print $file . " => $from/$file$err\n"; 80} 81