#!/usr/athena/bin/perl -- -*-perl-*-
# parch.perl V1.0 by Peter Orbaek (poe@daimi.aau.dk)
# archive multiple files in a perl-archive

sub usage {
    print "Usage: parch [-l archive] files...\n";
    die "";
}

# process options if there are any

while($_ = shift @ARGV) {
    unshift(ARGV, $_) && last unless /^-\w/;
    if(/^-l/) {
	# list contents of parch archive
	$arch = shift(@ARGV) || &usage;
	open(ARC, "< $arch") || die "Couldn't open $arch: $!\n";
	print "Contents of $arch:\n";
	while(<ARC>) {
	    next unless /^X(A|U)\s+(.+)/;
	    print "uuencoded " if($1 eq 'U');
	    print "archive: $2\n";
	}
	close ARC;
    }
}

exit(0) if @ARGV == ();

# print the header that will extract the archive

print <<'EOH';
#!/usr/local/bin/perl
 LOOP:
    while(<DATA>) {
	if(/^X(A|U)\s+(.+)/) {
	    close OUT if $open;
	    if(-e $2) {
		warn "Won't clobber existing file: $2\n";
		while(<DATA>) { /^X[^X]/ && ($line = $_) && last;};
		exit(0) if eof(DATA);
		$_ = $line;
		redo LOOP;
	    }
	    ($open = open(OUT, "> $2")) || die "Couldn't open $2: $!";
	    print STDERR "uudecoding and " if ($uu = ($1 eq 'U'));
	    print STDERR "extracting $2\n";
	    next LOOP;
	}
	elsif(/^XE/) { exit(0); }
	if($uu) {
	    /^XX/ ? print OUT unpack("u", substr($_,1)) 
		: print OUT unpack("u", $_);
	} else {
	    /^XX/ ? print OUT substr($_,1) : print OUT $_;
	}
    }
EOH

print "__","END__\n";

# now process each of the files on the commandline

while($file = shift @ARGV) {
    $binfile = -B $file;
    open(IN, "< $file") || die "Couldn't open $file: $!\n";

    $binfile ? print "XU $file\n" : print "XA $file\n";
    while(<IN>) {
	if($binfile) {
	    print pack("u", $_);
	} else {
	    if(/^X/) {
		print "X$_";
	    } else {
		print;
	    }
	}
    }
}

print "XE\n";