155714Skris#!/usr/local/bin/perl
255714Skris
355714Skris# mklink.pl
455714Skris
555714Skris# The first command line argument is a non-empty relative path
655714Skris# specifying the "from" directory.
755714Skris# Each other argument is a file name not containing / and
855714Skris# names a file in the current directory.
955714Skris#
1055714Skris# For each of these files, we create in the "from" directory a link
1155714Skris# of the same name pointing to the local file.
1255714Skris#
1355714Skris# We assume that the directory structure is a tree, i.e. that it does
1455714Skris# not contain symbolic links and that the parent of / is never referenced.
1555714Skris# Apart from this, this script should be able to handle even the most
1655714Skris# pathological cases.
1755714Skris
18238405Sjkimuse Cwd;
19160814Ssimon
2055714Skrismy $from = shift;
2155714Skrismy @files = @ARGV;
2255714Skris
23109998Smarkmmy @from_path = split(/[\\\/]/, $from);
24238405Sjkimmy $pwd = getcwd();
25160814Ssimonchomp($pwd);
26109998Smarkmmy @pwd_path = split(/[\\\/]/, $pwd);
2755714Skris
2855714Skrismy @to_path = ();
2955714Skris
3055714Skrismy $dirname;
3155714Skrisforeach $dirname (@from_path) {
3255714Skris
3355714Skris    # In this loop, @to_path always is a relative path from
3455714Skris    # @pwd_path (interpreted is an absolute path) to the original pwd.
3555714Skris
3655714Skris    # At the end, @from_path (as a relative path from the original pwd)
3755714Skris    # designates the same directory as the absolute path @pwd_path,
3855714Skris    # which means that @to_path then is a path from there to the original pwd.
3955714Skris
4055714Skris    next if ($dirname eq "" || $dirname eq ".");
4155714Skris
4255714Skris    if ($dirname eq "..") {
4355714Skris	@to_path = (pop(@pwd_path), @to_path);
4455714Skris    } else {
4555714Skris	@to_path = ("..", @to_path);
4655714Skris	push(@pwd_path, $dirname);
4755714Skris    }
4855714Skris}
4955714Skris
5055714Skrismy $to = join('/', @to_path);
5155714Skris
5255714Skrismy $file;
5376866Skris$symlink_exists=eval {symlink("",""); 1};
54238405Sjkimif ($^O eq "msys") { $symlink_exists=0 };
5555714Skrisforeach $file (@files) {
5668651Skris    my $err = "";
5776866Skris    if ($symlink_exists) {
58160814Ssimon	unlink "$from/$file";
5976866Skris	symlink("$to/$file", "$from/$file") or $err = " [$!]";
6076866Skris    } else {
61109998Smarkm	unlink "$from/$file";
62109998Smarkm	open (OLD, "<$file") or die "Can't open $file: $!";
63109998Smarkm	open (NEW, ">$from/$file") or die "Can't open $from/$file: $!";
64109998Smarkm	binmode(OLD);
65109998Smarkm	binmode(NEW);
66109998Smarkm	while (<OLD>) {
67109998Smarkm	    print NEW $_;
68109998Smarkm	}
69109998Smarkm	close (OLD) or die "Can't close $file: $!";
70109998Smarkm	close (NEW) or die "Can't close $from/$file: $!";
7176866Skris    }
7268651Skris    print $file . " => $from/$file$err\n";
7355714Skris}
74