mklink.pl revision 312826 
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};
54if ($^O eq "msys") { $symlink_exists=0 };
55foreach $file (@files) {
56    my $err = "";
57    if ($symlink_exists) {
58        if (!-l "$from/$file") {
59	    unlink "$from/$file";
60	    symlink("$to/$file", "$from/$file") or $err = " [$!]";
61	}
62    } elsif (-d "$from" && (!-f "$from/$file" || ((stat("$file"))[9] > (stat("$from/$file"))[9]))) {
63	unlink "$from/$file";
64	open (OLD, "<$file") or die "Can't open $file: $!";
65	open (NEW, ">$from/$file") or die "Can't open $from/$file: $!";
66	binmode(OLD);
67	binmode(NEW);
68	while (<OLD>) {
69	    print NEW $_;
70	}
71	close (OLD) or die "Can't close $file: $!";
72	close (NEW) or die "Can't close $from/$file: $!";
73    }
74    print $file . " => $from/$file$err\n";
75}
76