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