#!/usr/bin/perl -w

# Author          : Johan Vromans
# Created On      : Thu Mar 23 07:54:19 2017
# Last Modified By: Johan Vromans
# Last Modified On: Thu Mar 23 21:05:34 2017
# Update Count    : 56
# Status          : Unknown, Use with caution!

################ Common stuff ################

use strict;
use warnings;

# Package name.
my $my_package = 'Sciurix';
# Program name and version.
my ($my_name, $my_version) = qw( rePAR 0.02 );

################ Command line parameters ################

use Getopt::Long 2.13;

# Command line options.
my $output;
my $split;
my $sha1sum;
my $verbose = 0;		# verbose processing

# Development options (not shown with -help).
my $debug = 0;			# debugging
my $trace = 0;			# trace (show process)
my $test = 0;			# test mode.

# Process command line options.
app_options();

# Post-processing.
$trace |= ($debug || $test);

################ Presets ################

my $TMPDIR = $ENV{TMPDIR} || $ENV{TEMP} || '/usr/tmp';

################ The Process ################

use Fcntl;

use constant PAR_SENTINEL   => "\012PAR.pm\012";
use constant FILE_SENTINEL  => "FILE";
use constant CACHE_SENTINEL => "\0CACHE";
use constant TRAILER_SIZE   => 40 + length(CACHE_SENTINEL) + 4 + length(PAR_SENTINEL);

my $orig = shift;
my $info = analyse($orig);

if ( $split ) {
    sysseek( $info->{fd}, $info->{zipoff}, 0 )
      or die( $orig . ": seek error" );

    sysopen( my $fd, $split, O_CREAT | O_WRONLY )
      or die( "$split: $!\n" );

    copy( $info->{fd}, $fd, $info->{origsz} - $info->{zipoff} - TRAILER_SIZE );
    close($fd)
      or die("$split: $!\n");

    if ( $verbose ) {
	warn("Wrote: $split\n");
    }
    system( "zip", "-A", $split );
}

elsif ( $output ) {
    my $newzip = shift;

    # Rewind original exe.
    sysseek( $info->{fd}, 0, 0 )
      or die( $orig . ": seek error" );

    # Open the new zip.
    sysopen( my $newfd, $newzip, O_RDONLY )
      or die( "$newzip: $!\n" );
    my $newsz = -s $newzip;

    # Create the new exe.
    sysopen( my $fd, $output, O_CREAT | O_WRONLY )
      or die( "$output: $!\n" );

    # Copy the preamble from the original to the new exe.
    copy( $info->{fd}, $fd, $info->{zipoff} );

    # Append the new zip. Create an unique sha1 for this app.
    # The sha1 is used to form a (unique) cache directory name where
    # the package well be expanded.
    my $sha1 = copy( $newfd, $fd, $newsz );

    # Close and fix zip links.
    close($fd)
      or die( "$newzip: $!\n" );
    system( "zip", "-A", $output );

    # Reopen to append trailer.
    undef $fd;
    sysopen( $fd, $output, O_RDWR | O_APPEND )
      or die( "$output: $!\n" );

    my $trailer = ( defined($sha1sum) ? $sha1sum : $sha1 ) .
      CACHE_SENTINEL;
    $trailer .=
      pack( 'N', $info->{embsz} + $newsz + length($trailer) ) .
	PAR_SENTINEL;
    die("trailer error " . length($trailer) . " <> " . TRAILER_SIZE)
      unless length($trailer) == TRAILER_SIZE;
    syswrite( $fd, $trailer, TRAILER_SIZE );

    close($fd)
      or die( "$output: $!\n" );
    if ( $verbose ) {
	warn("Wrote: $output\n");
    }
}

else {
    print( "Embedded FILEs at ", $info->{emboff}, "\n",
	   "Length of FILEs is ", $info->{embsz}, "\n",
	   "ZIP starts at ", $info->{zipoff}, "\n",
	   "SHA1 is ", $info->{sha1}, "\n",
	 );
}

################ Subroutines ################

sub analyse {
    my ( $orig ) = @_;

    sysopen( my $fd, $orig, 0 )
      or die( "$orig: $!\n" );

    my $size = -s $orig;
    sysseek( $fd, $size - TRAILER_SIZE, 0 )
      or die("$orig: seek error\n");

    my $data = "";

    my $n = sysread( $fd, $data, 512 );
    die("$orig: read returns $n bytes instead of " . TRAILER_SIZE . "\n")
      unless $n == TRAILER_SIZE;

    my $checksum = substr( $data, 0, 40, '' );
    my $CACHE = substr( $data, 0, length(CACHE_SENTINEL), '' );
    my $files = unpack( 'N', substr( $data, 0, 4, '' ) );
    my $sentinel = $data;

    die( "$orig: final sentinel is not \\nPAR.pm\\n but '$sentinel'\n" )
      unless $sentinel eq PAR_SENTINEL;
    die( "$orig: cache sentinel is not \\0CACHE but '$CACHE'\n" )
      unless $CACHE eq CACHE_SENTINEL;

    my $off = $size - length(PAR_SENTINEL) - 4 - $files;
    sysseek( $fd, $off, 0 );

    while ( 1 ) {

=for doc

  FILE
  unpack( 'N', length of file name )
  filename as XXXXXX/orig/file.pm (XXXXXX is a hex number)
  unpack( 'N', length of file )
  file contents

=cut

	$data = rd( $fd, 4 );
	last unless $data eq "FILE";

	$n = rdn( $fd, 4 );

	$data = rd( $fd, $n );
	my $file = $data;
	$n = rdn( $fd, 4 );

	warn("FILE $file, $n bytes\n") if $verbose > 1;
	sysseek( $fd, $n, 1 );
    }

    my $zip = sysseek( $fd, -4, 1 );

    return +{ fd      => $fd,
	      orig    => $orig,
	      origsz  => $size,
	      zipoff  => $zip,
	      emboff  => $off,
	      embsz   => $zip - $off,
	      sha1    => $checksum,
	    };
}

sub rd {
    my ( $fd, $exp ) = ( @_ );
    my $data = "";
    my $n = sysread( $fd, $data, $exp );
    die( "read error" ) if $n <= 0;
    die( "short read: $n instead of $exp" ) if $n < $exp;
    return $data;
}

sub rdn {
    unpack( 'N', &rd );
}

use Digest::SHA1;

sub copy {
    my ( $from, $to, $length ) = @_;

    my $sha1 = Digest::SHA1->new;

    while ( $length > 0 ) {
	my $n = $length;
	$n = 10240 if $n > 10240;
	my $buf = "";
	my $got = sysread( $from, $buf, $n );
	die("read error on copy") if $got <= 0;
	die("short read on copy") if $got != $n;
	syswrite( $to, $buf, $n );
	$sha1->add(substr($buf,0,$n));
	$length -= $n;
    }

    return $sha1->hexdigest;
}

################ Subroutines ################

sub app_options {
    my $help = 0;		# handled locally
    my $ident = 0;		# handled locally
    my $man = 0;		# handled locally

    my $pod2usage = sub {
        # Load Pod::Usage only if needed.
        require Pod::Usage;
        Pod::Usage->import;
        &pod2usage;
    };

    # Process options.
    if ( @ARGV > 0 ) {
	GetOptions('ident'	=> \$ident,
		   'split=s'	=> \$split,
		   'output=s'	=> \$output,
		   'sha1=s'	=> \$sha1sum,
		   'verbose+'	=> \$verbose,
		   'trace'	=> \$trace,
		   'help|?'	=> \$help,
		   'man'	=> \$man,
		   'debug'	=> \$debug)
	  or $pod2usage->(2);
    }
    if ( $ident or $help or $man ) {
	print STDERR ("This is $my_package [$my_name $my_version]\n");
    }
    if ( $man or $help ) {
	$pod2usage->(1) if $help;
	$pod2usage->(VERBOSE => 2) if $man;
    }
    if ( ( $split  && @ARGV != 1 )
	 ||
	 ( $output && @ARGV != 2 ) ) {
	$pod2usage->(2);
    }
}

__END__

################ Documentation ################

=head1 NAME

repar - tool to update binary PAR-packaged executables

=head1 SYNOPSIS

repar [options] orig.exe [ new.zip ]

 Options:
   --split=XXX		split the zip from the original executable
   --output=XXX		write the updated executable
   --ident		shows identification
   --help		shows a brief help message and exits
   --man                shows full documentation and exits
   --verbose		provides more verbose information

 --split and --output are mutually exclusve.

=head1 OPTIONS

=over 8

=item B<--split=>I<XXX>

Requires one additional command line argument, the name of the
original executable.

Writes the ZIP section of the original executable to the indicated
file, and runs "zip -A" to fix the internal links.

=item B<--output=>I<XXX>

Requires two additional command line argument, the name of the
original executable and the name of the new zip.

Replaces the ZIP section of the original executable by the new zip.
Internal links are fixed and a new executable is written to the
indicated file.

=item B<--help>

Prints a brief help message and exits.

=item B<--man>

Prints the manual page and exits.

=item B<--ident>

Prints program identification.

=item B<--verbose>

Provides more verbose information.

=back

=head1 DESCRIPTION

When run without B<--split> and B<--output> options, B<repar> analyses
the executable and prints some interesting info. This may be
considered a basic consistency check.

Basically, a PAR packaged standalone executable consists op de
following sections:

=over

=item *

A native executable to extract the package and invoke its main entry
point.

=item *

A collection of embedded files to support the extractor.

=item *

A zip with user modules and supporting files, produced by PAR.

=item *

A trailer with a.o. checksum information.

=back

With B<--split>, the zip with user modules and supporting files is
extracted to the indicated file, and the internal links are fixed.
This zip can then be updated with new modules and files.

With B<--output>, a new executable is written consisting of the first
two sections of the original executable, with the new zip appended and
updated links and checksum information.

=head1 AUTHOR

Johan Vromans C<< <jv at cpan dot org> >>

=head1 WARNING

Updating a PAR packaged executable for a foreign platform is only
possible if no updates are required to I<native> modules, e.g. XS modules
and system libraries.

=head1 DISCLAIMER

There is no guarantee this program will do something useful for you.

=cut

1;