File Coverage

blib/lib/Archive/SelfExtract.pm

Criterion	Covered	Total	%
statement	67	94	71.2
branch	5	20	25.0
condition			n/a
subroutine	14	17	82.3
pod	2	3	66.6
total	88	134	65.6

=pod

=head1 NAME

Archive::SelfExtract - bundle compressed archives with Perl code

=head1 SYNOPSIS

    use Archive::SelfExtract;

    # writes output script to STDOUT
    Archive::SelfExtract::createExtractor( "perlcode.pl", "somefiles.zip" );

    # with various options:
    Archive::SelfExtract::createExtractor( "perlcode.pl", "somefiles.zip",
					   perlbin => "/opt/perl58/bin/perl",
					   output_fh => $someFileHandle,
					 );

See also the command line tool, L.

=cut

package Archive::SelfExtract;

use strict;
# implicit:
use Compress::Zlib;
use File::Spec;
# explicit:
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
use File::Temp qw(tempdir);
use File::Path qw(mkpath rmtree);
use IO::Scalar;
use Carp;

our $VERSION = '1.3';

# $Tempdir may be set before calling extract() to control where the
# zipfile is extracted to.
our $Tempdir;

use constant QUIET => 0;
use constant STD => 1;
use constant VERBOSE => 2;
use constant NOISY => 3;
use constant DEBUG => 4;

# $DebugLevel may be set before calling extract() to control how verbose
# the extraction process is.
our $DebugLevel = STD;

sub out {
  my($level, $msg) = @_;
  if ( $DebugLevel >= $level ) {
    print "$msg\n";
  }
}

sub createExtractor {
  my( $scriptfn, $zipfn, %options ) = @_;

  my $perlbin = "/usr/bin/perl";
  if ( exists($options{perlbin}) ) {
    $perlbin = delete $options{perlbin};
  }
  my $out;
  if ( exists($options{output_fh}) ) {
    $out = delete $options{output_fh};
  } else {
    $out = \*STDOUT;
  }
  if ( %options ) {
    croak "Unknown options (", join(",",keys %options), ") passed to createExtractor";
  }

  open(my $script, "$scriptfn") ||
    croak "Can't read script file $scriptfn ($!)";
  open(my $zipdata, "$zipfn") ||
    croak "Can't read zip file $zipfn ($!)";

  local $/=undef;

  print $out "#!$ {perlbin}\n";
  print $out "\n";
  print $out q{use warnings;}, "\n";
  print $out q{use strict;}, "\n";
  print $out q{use Archive::SelfExtract;}, "\n";
  print $out q{Archive::SelfExtract::_extract(\*DATA);}, "\n";
  print $out q{#}, "\n";
  print $out q{# Start user script}, "\n";
  print $out q{#}, "\n";
  print $out "\n";
  print $out +<$script>;
  print $out "\n";
  print $out q{#}, "\n";
  print $out q{# End user script}, "\n";
  print $out q{#}, "\n";
  print $out q{__DATA__}, "\n";
  # turn binmode on now: print raw data instead of text
  binmode($out);
  print $out scalar(<$zipdata>);

}

sub _extract {
  my($fh) = @_;
  if (defined($Tempdir)) {
    out(DEBUG, "Verifying existance of tempdir $Tempdir");
    mkpath($Tempdir, ($DebugLevel>=DEBUG), 0755) ||
      croak "Could not create temporary directory (\$Tempdir) '$Tempdir' ($!)";
  } else {
    out(DEBUG, "Creating tempdir");
    $Tempdir = tempdir();
  }
  out(STD, "Extracting into $Tempdir...");
  my $arc = Archive::Zip->new();
  out(DEBUG, "Reading from DATA into memory");
  my $data = do {
    local $/ = undef;
    binmode($fh);
    <$fh>;
  };
  # The alternative to this is to write a fh wrapper which
  # i can open on $0 and which will "ignore" the "header" (script).
  my $rwhandle = IO::Scalar->new( \$data );
  if ( AZ_OK==$arc->readFromFileHandle( $rwhandle ) ) {
    out(VERBOSE, "Unpacking ".$arc->numberOfMembers()." files");
    # first param must be undef (not ""!) to extract all files
    # second param must end with a "/", since AZ just concats the names
    $arc->extractTree( undef, "$ {Tempdir}/" );
  } else {
    croak "Could not read zipfile data ($!)";
  }
  out(STD, "OK");
}

# Remove the tempdir (and all its contents)
sub cleanup {
  if ( -d $Tempdir ) {
    rmtree( $Tempdir, ($DebugLevel>=DEBUG), 1);
  }
}

1;
__END__