mklink.pl revision 160815
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 18use Cwd; 19 20my $from = shift; 21my @files = @ARGV; 22 23my @from_path = split(/[\\\/]/, $from); 24my $pwd = getcwd(); 25chomp($pwd); 26my @pwd_path = split(/[\\\/]/, $pwd); 27 28my @to_path = (); 29 30my $dirname; 31foreach $dirname (@from_path) { 32 33 # In this loop, @to_path always is a relative path from 34 # @pwd_path (interpreted is an absolute path) to the original pwd. 35 36 # At the end, @from_path (as a relative path from the original pwd) 37 # designates the same directory as the absolute path @pwd_path, 38 # which means that @to_path then is a path from there to the original pwd. 39 40 next if ($dirname eq "" || $dirname eq "."); 41 42 if ($dirname eq "..") { 43 @to_path = (pop(@pwd_path), @to_path); 44 } else { 45 @to_path = ("..", @to_path); 46 push(@pwd_path, $dirname); 47 } 48} 49 50my $to = join('/', @to_path); 51 52my $file; 53$symlink_exists=eval {symlink("",""); 1}; 54foreach $file (@files) { 55 my $err = ""; 56 if ($symlink_exists) { 57 unlink "$from/$file"; 58 symlink("$to/$file", "$from/$file") or $err = " [$!]"; 59 } else { 60 unlink "$from/$file"; 61 open (OLD, "<$file") or die "Can't open $file: $!"; 62 open (NEW, ">$from/$file") or die "Can't open $from/$file: $!"; 63 binmode(OLD); 64 binmode(NEW); 65 while (<OLD>) { 66 print NEW $_; 67 } 68 close (OLD) or die "Can't close $file: $!"; 69 close (NEW) or die "Can't close $from/$file: $!"; 70 } 71 print $file . " => $from/$file$err\n"; 72} 73