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