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