mklink.pl 1.9 KB
Newer Older
1 2
#!/usr/local/bin/perl

3
# mklink.pl
4 5 6

# The first command line argument is a non-empty relative path
# specifying the "from" directory.
B
Bodo Möller 已提交
7 8
# Each other argument is a file name not containing / and
# names a file in the current directory.
9 10 11 12
#
# For each of these files, we create in the "from" directory a link
# of the same name pointing to the local file.
#
B
Bodo Möller 已提交
13 14
# We assume that the directory structure is a tree, i.e. that it does
# not contain symbolic links and that the parent of / is never referenced.
15 16 17 18 19 20
# Apart from this, this script should be able to handle even the most
# pathological cases.

my $from = shift;
my @files = @ARGV;

21
my @from_path = split(/[\\\/]/, $from);
22 23
my $pwd = `pwd`;
chop($pwd);
24
my @pwd_path = split(/[\\\/]/, $pwd);
25 26

my @to_path = ();
27 28 29

my $dirname;
foreach $dirname (@from_path) {
30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49

    # In this loop, @to_path always is a relative path from
    # @pwd_path (interpreted is an absolute path) to the original pwd.

    # At the end, @from_path (as a relative path from the original pwd)
    # designates the same directory as the absolute path @pwd_path,
    # which means that @to_path then is a path from there to the original pwd.

    next if ($dirname eq "" || $dirname eq ".");

    if ($dirname eq "..") {
	@to_path = (pop(@pwd_path), @to_path);
    } else {
	@to_path = ("..", @to_path);
	push(@pwd_path, $dirname);
    }
}

my $to = join('/', @to_path);

50
my $file;
51
$symlink_exists=eval {symlink("",""); 1};
52
foreach $file (@files) {
53
    my $err = "";
54 55 56
    if ($symlink_exists) {
	symlink("$to/$file", "$from/$file") or $err = " [$!]";
    } else {
57 58 59 60 61 62 63 64 65 66
	unlink "$from/$file"; 
	open (OLD, "<$file") or die "Can't open $file: $!";
	open (NEW, ">$from/$file") or die "Can't open $from/$file: $!";
	binmode(OLD);
	binmode(NEW);
	while (<OLD>) {
	    print NEW $_;
	}
	close (OLD) or die "Can't close $file: $!";
	close (NEW) or die "Can't close $from/$file: $!";
67
    }
68
    print $file . " => $from/$file$err\n";
69
}