#!perl -w
use strict;
use Archive::Zip qw ( :ERROR_CODES );
use IO::File;
use File::Basename;
use Getopt::Std;
my $VERSION = '1.1';
my %opt;
getopt( 'lu', \%opt );
my @files = @ARGV;
if ( !$opt{u} or !@files ) {
print <<".";
Pare version $VERSION - pare down PAR file sizes by removing files found
in another PAR and making the reduced PAR "use" the other PAR.
Usage: pare [-l <logfile>] -u <usedfile> <reducedfiles> . . .
.
exit;
}
my $lh;
if ( $opt{l} ) {
my $mode = -f $opt{l} ? '>>' : '>';
open $lh, "$mode$opt{l}" or die "Can't open log file $opt{l}: $!\n";
}
else {
open $lh, ">&STDOUT";
}
print $lh <<".";
-----------------------------------
Common files in $opt{u} removed from:
@files
-----------------------------------
.
for (@files) {
remove( $_, $opt{u} );
}
close $lh;
sub remove {
my ( $par, $dep_par ) = @_;
my ( $loader, $buf, $cache_name );
my $fh = IO::File->new( $par, 'r' ) or die "Can't open $par: $!\n";
binmode($fh);
my $th = IO::File->new_tmpfile() or die "Can't open temp file: $!\n";
binmode($th);
select( ( select($th), $| = 1 )[0] );
$loader = 0;
read $fh, $buf, 4;
if ( $buf ne "PK\003\004" ) {
seek $fh, -8, 2;
read $fh, $buf, 8;
if ($buf ne "\nPAR.pm\n") {
die "File $par doesn't look like a zip or PAR file!\n";
}
seek $fh, -12, 2;
read $fh, $buf, 4;
seek $fh, -12 - unpack( "N", $buf ), 2;
$loader = tell $fh;
seek $fh, -18, 2;
read $fh, $buf, 6;
if ($buf eq "\0CACHE") {
seek $fh, -58, 2;
read $fh, $cache_name, 41;
}
seek $fh, 0, 0;
read $fh, $buf, $loader;
print $th $buf;
read $fh, $buf, 4;
while ( $buf eq "FILE" ) {
print $th $buf;
# file name
read $fh, $buf, 4;
print $th $buf;
read $fh, $buf, unpack( "N", $buf );
print $th $buf;
# file contents
read $fh, $buf, 4;
print $th $buf;
read $fh, $buf, unpack( "N", $buf );
print $th $buf;
read $fh, $buf, 4;
}
if ($buf ne "PK\003\004") {
die "Can't find start of zip in $par\n";
}
seek $fh, -4, 1;
}
my $par_zip = Archive::Zip->new();
$par_zip->readFromFileHandle($fh, $par) == AZ_OK or die "Can't read zip in $par\n";
my $manifest = $par_zip->contents('MANIFEST');
die "Can't find MANIFEST in $par\n" if !$manifest;
my $main_pl = $par_zip->contents('script/main.pl');
die "Can't find main.pl in $par\n" if !$main_pl;
my $dep_zip = Archive::Zip->new($dep_par);
die "Can't find or read $dep_par\n" if !$dep_zip;
print $lh "$par depends on $dep_par for:\n";
my $base_par = basename($dep_par);
my $used = 'use PAR qw(';
if ( $main_pl =~ /^\Q$used/ ) {
if ( $main_pl !~ /$base_par/ ) {
$main_pl =~ s/^\Q$used/$used $base_par/;
}
}
else {
$main_pl = "use PAR qw( $base_par );\n$main_pl";
}
for ( $dep_zip->memberNames() ) {
if ( $par_zip->memberNamed($_) ) {
if ( !( /MANIFEST/ or /META.yml/ or /^script\// ) ) {
$par_zip->removeMember($_);
$manifest =~ s/$_\n//;
print $lh " $_\n";
}
}
}
print $lh "\n";
$par_zip->contents( 'MANIFEST', $manifest );
$par_zip->contents( 'script/main.pl', $main_pl );
$par_zip->writeToFileHandle($th);
if ($loader) {
if ($cache_name) {
$th->print($cache_name, "CACHE");
}
$th->print( pack( 'N', $th->tell - $loader ) );
$th->print("\nPAR.pm\n");
}
$fh->close;
$fh = IO::File->new( $par, 'w' ) or die "Can't open $par for writing: $!\n";
binmode($fh);
seek $th, 0, 0;
while ( read( $th, $buf, 32768 ) ) {
print $fh $buf;
}
close $fh;
} ## end sub remove