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 |