summaryrefslogtreecommitdiff
path: root/Build/source/mswin32/tar-links.pl
blob: e87ec0f6112c4f14f4734bee25d9eb5a9fd8927c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
#
# Tool to correct links in tar files.
# Author: F. Popineau
# Date  : 22/12/97
# Time-stamp: <02/12/23 00:33:46 popineau>
#
# Usage: 
#        gzip -dc <file>.tar.gz | tar tvf - | perl tar-links.pl
#
require "newgetopt.pl";
use Cwd;

&main;

exit 0;

sub canon_dir
{
    local ($p, $rep) = @_;
    if ($rep eq '' || $rep eq '\\') {
	$p =~ s@/@\\@g;
	$p =~ s@\\[\\]+@\\@g;
	$p =~ s@\\.\\@\\@g;
	$p =~ s@\\([^\\]+)\\..\\@\\@g;
    }
    elsif ($rep eq '/') {
	$p =~ s@\\@/@g;
	$p =~ s@/[/]+@/@g;
	$p =~ s@/./@/@g;
	$p =~ s@/([^/]+)/../@/@g;
    }
    else {
	die ("canon_dir($p) : invalid separator $rep.\n");
    }
    return $p;
}

# Merges all elements in the list into a single path, adding
# directory separators as needed.
sub newpath
{
    local($p, $s);
    # Concatenates the arguments, adding path separators as needed
    $p = @_[0];
    for ($i = 1; $i <= $#_; $i++) {
	$p = $p . "\\" . $_[$i];
    }
    return &canon_dir($p);
}

sub dirname {
    local ($f) = @_;
    $f =~ m@^(.*[/\\])[^/\\]*@;
    return $1;
}

# Copy source to dest
sub copy
{
    local ($src, $dest) = @_;

    print "Copying $src to $dest\n" if ($opt_verbose);

    die "Copy : source file $src does not exist.\n" 
	unless (-f $src);
#    die "Copy : destination file $dest does not exist.\n" 
#	unless (-f $dest || -d $dest);
    if (-d $dest) {
	$dest = &newpath($dest, &basename($src));
    }
    open IN, "<$src";
    open OUT, ">$dest";
    binmode(IN);
    binmode(OUT);
    print OUT <IN>;
    close(IN);
    close(OUT);
}

sub make_link {
    local ($to, $from) = @_;
    $to = canon_dir($to);
    $from = newpath(dirname($to), $from);
    print "linking $from -> $to ...";
    if (-e $to) {
	unlink($to);
    }
    if (-d $from) {
      system("xcopy $from $to /f/r/i/e/d/k");
    }
    else {
	copy($from, $to);
    }
    print " done\n";
}

sub main {
    while (<>) {
	if ($_ =~ m/([^\s]+)\s*->\s*([^\s]+)/) {
	    make_link($1, $2);
	}
    }
}