http://qs321.pair.com?node_id=318105
Category: Utility Scripts
Author/Contact Info Dan Hetrick (wraith@planetshogo.com)
Description: This is a complete rewrite of Self Extracting Perl Archive, turning it into a complete, usable utility named SIP (Sip Isn't Par).

The latest version will always be avaliable from the SIP Website.

Takes a list of files and converts them into a Perl script that extracts the files when ran, with the ability to display text or files, check file integrity with MD5 hashes, run commands before and after extraction, and create 'silent' extractors. SIP's main purpose is NOT to be an alternative to par, but to be the basis for a Perl software installation system. Uses File::Basename, Digest::MD5, File::Find, File::Path, and Getopt::Mixed.

Usage:
sip.pl OPTIONS file,file,...

Options:
-v,--version Print version and exit
-h,--help Print this text
-n,--nobanner Do not print banner in output script
-N,--name text Changes the name displayed in the banner
-s,--silent Output script executes silently
-p,--text text Print text at beginning of output script
-P,--print filename Prints the contents of a text file at beginning of output script
-m,--md5 Verify file integrity. Output script will require Digest::MD5
-f,--force Force extraction of damaged files
-o,--output filename Write output to file
-w,--overwrite Automatically overwrite existing files with output
-r,--run command Execute a command after extraction
-R,--pre command Execute a command before extraction
-d,--dir path Add all files in directory to script
-D,--recursive path Add all files in directory (recursive) to script. Directory structure is recreated on extraction.
-t,--temp Extract all files to temp directory
-l,--location directory Extract files to the specified directory
-b,--noshebang Do not add shebang to output
-B,--shebang text Adds a shebang other than #!/usr/bin/perl

UPDATE: Added the -r option, so you can use SEPA scripts as installers.
UPDATE: Added the -R and -f options, making using SEPA as an installer system more viable.
UPDATE: Added the -d and -D options, making it possible to add all files in a directory to a script
UPDATE: Added the -t option, allowing for temp directory extraction, and changed the name of the program to reflect on some comments :-)
UPDATE: Fixed a bug with the -r and -i options together
UPDATE: Fixed a bug with the -D option, and added the -e option
UPDATE: Fixed a whole slew of bugs and added the -l option. If the -D option is used, the directory structure is recreated upon extraction.
UPDATE: Even more bugfixes and options. Added the -b,-B,-w, and -N options, allowing you to remove the shebang from the output script, add a different shebang, automatically overwrite files on output, or change the name displayed in the banner, respectively.
UPDATE: More bugfixes and I added POD documentation.

 
#!/usr/bin/perl
#
# sip.pl
#
# Sip Isn't Par
#
# A utility for combining any number of files into
# a Perl script that extracts it's contents upon
# execution.
#
# Usage:
# sip.pl [ OPTIONS ] file file ...
#
# Version: 0.45
# Author:  Dan Hetrick
# License: GPL
#
# Options:
#
# -v,--version              Print version and exit
# -h,--help                 Print this text
# -r,--run <file/cmd>       Execute a script/command after extraction
# -R,--pre <file/cmd>       Execute a script/command before extraction
# -n,--nobanner             Do not print banner in output script
# -N,--name <text>          Changes the displayed name in the banner
# -s,--silent               Output script executes silently
# -p,--text <text>          Print text at beginning of output script
# -P,--print <filename>     Prints the contents of a text file at
#                           at beginning of output script
# -m,--md5                  Verify file integrity
#                           Output script will require Digest::MD5
# -f,--force                Force extraction of damaged files
# -d,--dir <path>           Add all files in directory to script
# -D,--recursive <path>     Add all files in directory (recursive) to 
+script
#                           Directory structure is recreated on extrac
+tion
# -t,--temp                 Extract all files to temp directory
# -l,--location <dir>       Extract all files to a specific directory
# -o,--output <filename>    Write output to file
# -w,--overwrite            Automatically overwrite existing files wit
+h output
# -b,--noshebang            Do NOT add shebang to output script
# -B,--shebang <text>       Use another shebang instead of #!/usr/bin/
+perl
#

use strict;
use File::Basename;
use File::Find;
use Digest::MD5;
use Getopt::Mixed "nextOption";
my $option;
my $value;

# ========
# SETTINGS
# ========

my $APPNAME            = "sip.pl";
my $VERSION            = "0.45";
my $output_file        = 0;
my $output_filename    = "";
my $verify_mode        = 0;
my $stub_delimiter     = '%%BREAK%%';
my $print_banner       = 1;
my $silent_mode        = 0;
my $text_mode          = 0;
my $text_display       = "";
my $print_mode         = 0;
my $print_display      = "";
my $run_mode           = 0;
my $run_file           = "";
my $pre_mode           = 0;
my $pre_file           = "";
my $force_mode         = 0;
my $add_dir            = 0;
my $add_dir_name       = "";
my $radd_dir           = 0;
my $radd_dir_name      = "";
my $temp_mode          = 0;
my $location_mode      = 0;
my $location_dir       = "";
my $overwrite_mode     = 0;
my $shebang_option     = 1;
my $alt_shebang_option = 0;
my $alt_shebang        = "";
my $package_name       = "Self Extracting Perl Archive";
my $banner             = "";

my @rFilelist = ();    # Contains local paths
my @DirTree   = ();    # Contains a list of directories to create
my @oFileList = ();    # Contains extracted paths
my $basedir   = "";

# ===========
# MAIN SCRIPT
# ===========

# Handle commandline options
Getopt::Mixed::init(
"v version>v l=s N=s name>N location>l t temp>t d=s dir>d D=s recursiv
+e>D r=s run>r f force>f R=s pre>R m md5>m o=s output>o P=s print>P p=
+s text>p h help>h n nobanner>n s silent>s w overwrite>w b noshebang>b
+ B=s shebang>B"
);

while ( ( $option, $value ) = nextOption() ) {
    if ( $option =~ /v/ ) { print "$VERSION\n"; exit; }
    if ( $option =~ /r/ ) { $run_mode           = 1; $run_file      = 
+$value; }
    if ( $option =~ /R/ ) { $pre_mode           = 1; $pre_file      = 
+$value; }
    if ( $option =~ /d/ ) { $add_dir            = 1; $add_dir_name  = 
+$value; }
    if ( $option =~ /D/ ) { $radd_dir           = 1; $radd_dir_name = 
+$value; }
    if ( $option =~ /l/ ) { $location_mode      = 1; $location_dir  = 
+$value; }
    if ( $option =~ /a/ ) { $alt_shebang_option = 1; $alt_shebang   = 
+$value; }
    if ( $option =~ /N/ ) { $package_name   = $value; }
    if ( $option =~ /w/ ) { $overwrite_mode = 1; }
    if ( $option =~ /m/ ) { $verify_mode    = 1; }
    if ( $option =~ /t/ ) { $temp_mode      = 1; }
    if ( $option =~ /f/ ) { $force_mode     = 1; }
    if ( $option =~ /n/ ) { $print_banner   = 0; }
    if ( $option =~ /b/ ) { $shebang_option = 0; }
    if ( $option =~ /s/ ) { $silent_mode    = 1; }
    if ( $option =~ /p/ ) { $text_mode      = 1; $text_display = $valu
+e; }
    if ( $option =~ /P/ ) { $print_mode     = 1; $print_display = $val
+ue; }
    if ( $option =~ /o/ ) { $output_file    = 1; $output_filename = $v
+alue; }

    if ( $option =~ /h/ ) {
        Usage();
    }
}

Getopt::Mixed::cleanup();

my @files;

if ( $add_dir == 1 ) {
    if($add_dir_name=~/,/) {
        my @ads=split(',',$add_dir_name);
    foreach my $dir (@ads)
    {
        push(@files,GetFileList($dir));
    }
    } else {
        push(@files,GetFileList($add_dir_name));
    }
}

if ( $radd_dir == 1 ) {
    if($radd_dir_name=~/,/) {
        my @ads=split(',',$radd_dir_name);
    foreach my $dir (@ads)
    {
        push(@files,GetFileListRecursive($dir));
    }
    } else {
        push(@files,GetFileListRecursive($radd_dir_name));
    }
}

push( @files, @ARGV );

if ( ( $output_file == 1 ) && ( -e $output_filename ) ) {
    if ( $overwrite_mode == 0 ) {
        print "File $output_filename already exists.\n";
        print "Replace [y/n] ? ";
        my $retval = <STDIN>;
        if ( $retval =~ /y/ ) {
            open( FILE, ">$output_filename" ) or die "Error writing fi
+le.";
            print FILE "";
            close FILE;
        }
        else {
            exit;
        }
    }
    else {
        open( FILE, ">$output_filename" ) or die "Error writing file."
+;
        print FILE "";
        close FILE;
    }
}

if ( $#files >= 0 ) {
    MakeArchiveScript(@files);
}
else {
    Usage();
}

# ===================
# SUPPORT SUBROUTINES
# ===================

# Usage()
#
# Displays application usage.
#
sub Usage {
    print "\nSIP - Sip Isn't Par\n";
    print "Version: $VERSION\n";
    print "Author:  Dan Hetrick\n";
    print "License: GPL\n";
    print "Combines any number of files into a single Perl script that
+\n";
    print "extracts its contents on execution.\n\n";
    print "Usage: $0 [ OPTIONS ] file file ...\n\n";
    print "Options:\n\n";
    print "-v,--version              Print version and exit\n";
    print "-h,--help                 Print this text\n";
    print
      "-r,--run <file/cmd>       Execute a script/command after extrac
+tion\n";
    print
      "-R,--pre <file/cmd>       Execute a script/command before extra
+ction\n";
    print "-n,--nobanner             Do not print banner in output scr
+ipt\n";
    print "-N,--name <text>          Changes the package name in the b
+anner\n";
    print "-s,--silent               Output script executes silently\n
+";
    print
      "-p,--text <text>          Print text at beginning of output scr
+ipt\n";
    print "-P,--print <filename>     Prints the contents of a text fil
+e at\n";
    print "                          at beginning of output script\n";
    print "-m,--md5                  Verify file integrity\n";
    print "                          Output script will require Digest
+::MD5\n";
    print "-f,--force                Force extraction of damaged files
+\n";
    print "-t,--temp                 Extract all files to temp directo
+ry\n";
    print
      "-l,--location <dir>       Extract all files to a specific direc
+tory\n";
    print "-d,--dir <path>           Add all files in directory to scr
+ipt\n";
    print
"-D,--recursive <path>     Add all files in directory (recursive) to s
+cript\n";
    print
"                          Directory structure is recreated on extract
+ion\n";
    print "-o,--output <filename>    Write output to file\n";
    print
"-w,--overwrite            Automatically overwrite existing files with
+ output\n";
    print "-b,--noshebang            Do NOT add shebang to output scri
+pt\n";
    print "-B,--shebang <text>       Use another shebang instead of "
      . '#!/usr/bin/perl' . "\n\n";
    print "Multiple directories can be passed to SIP with the -d and -
+D tags.\n";
    print "Seperate each directory with a comma, like '/home/use,/usr,
+...'.\n";
    print "\n";
    exit;
}

# MakeArchiveScript(@list_of_files)
#
# Takes a list of files, builds the
# script stub, calls MakePerlArchive(),
# and returns a Perl script
#
sub MakeArchiveScript {
    my (@file_list) = @_;
    my @stub        = <DATA>;
    my $filecount   = $#file_list + 1;
    my $retval      = "";
    my $border      = '*' x length($package_name);
    $banner = 'print "\n' . $border . '\n";';
    $banner .= 'print "' . $package_name . '\n";';
    $banner .= 'print "' . $border . '\n\n";';
    $banner .= 'print "Created with !APPNAME !VERSION\n\n";';
    $banner .= 'print "Files: !FILECOUNT\n\n";';
    my $stubs = join( '', @stub );
    my @stb = split( "$stub_delimiter", $stubs );

    if ( $shebang_option == 1 ) {
        if ( $alt_shebang_option == 1 ) {
            $retval .= $alt_shebang . "\n";
        }
        else {
            $retval .= '#!/usr/bin/perl' . "\n";
        }
    }
    if ( $verify_mode == 1 ) {
        $retval .= $stb[0];
    }
    else {
        $retval .= $stb[1];
    }
    if ( $print_banner == 1 ) {
        if ( $silent_mode == 1 ) {
            $retval =~ s/!BANNER//g;
        }
        else {
            $retval =~ s/!BANNER/$banner/g;
        }
    }
    else {
        $retval =~ s/!BANNER//g;
    }
    if ( $radd_dir == 1 ) { $retval =~ s/!FILEPATH/use File::Path;/g; 
+}
    else { $retval =~ s/!FILEPATH//g; }
    $retval =~ s/!APPNAME/$APPNAME/g;
    $retval =~ s/!VERSION/$VERSION/g;
    $retval =~ s/!FILECOUNT/$filecount/g;
    if ( $temp_mode == 1 ) { $retval .= 'chdir "$ENV{TMP}";'; }
    if ( $location_mode == 1 ) {
        $retval .= 'chdir "' . $location_dir . '";';
    }

    if ( $text_mode == 1 ) {
        $retval .= 'print "' . $text_display . '\n";';
    }
    if ( $print_mode == 1 ) {
        if ( -e "$print_display" ) {
            open( FILE, "<$print_display" )
              or die "Error opening $print_display.";
            my @pd = <FILE>;
            close FILE;
            foreach my $ln (@pd) {
                chomp $ln;
                $retval .= 'print "' . $ln . '\n";';
            }
        }
        else {
            print "Input file doesn't exist.\n";
            exit;
        }
    }
    WriteOutput($retval);
    MakePerlArchive(@file_list);
}

# MakePerlArchive(@file_list)
#
# Takes an array of
# files as an argument, and returns
# a Perl script that will extract
# those files into the current
# directory
#
sub MakePerlArchive {
    my (@archive_list) = @_;
    my $packsubs       = "";
    my $retval         = "";
    my $hash           = "";
    if ( $pre_mode == 1 ) {
        if ( $silent_mode == 0 ) {
            $retval .= 'print `' . $pre_file . '`;';
        }
        else {
            $retval .= 'my $retval=`' . $pre_file . '`;';
        }

    }
    if ( $radd_dir == 1 ) {
        my $rs = join( ',', @DirTree );
        $rs =~ s/,/','/g;
        $rs = "'$rs'";
        $retval .= 'mkpath([' . $rs . '],0,0777);';
    }
    WriteOutput($retval);
    $retval = "";
    my $ofCount = 0;
    foreach my $file (@archive_list) {
        my $original_filename = $file;
        if ( $verify_mode == 1 ) { $hash = HashFile($original_filename
+); }
        my $outputfilename = basename($file);
        if ( $radd_dir == 1 ) {
            $outputfilename = $oFileList[$ofCount];
        }
    if(length($outputfilename)==0) { next; }
        my $subname = random_string(10);
        $retval .= '$file=' . "'" . $outputfilename . "';";
        if ( $verify_mode == 1 ) { $retval .= '$hash="' . $hash . '";'
+ }
        $retval .= '$packed_data=' . $subname . '();' . "\n";
        $retval .= 'open(FILE,">$file") || die "Error writing file - $
+!\n";';
        $retval .= 'binmode FILE;';
        $retval .= 'print FILE $packed_data;';
        $retval .= 'close FILE;';
        WriteOutput($retval);
        $retval = "";

        if ( $verify_mode == 1 ) {
            $retval .= 'if(VerifyFile($hash,$file)==0) { ';
            if ( $silent_mode == 0 ) {
                $retval .= 'print "$file is damaged.\n";';
            }
            if ( $force_mode == 0 ) {
                if ( $silent_mode == 0 ) {
                    $retval .= ' print "$file not extracted.\n"; ';
                }
                $retval .= ' unlink $file; } else {';
            }
            else {
                if ( $silent_mode == 0 ) {
                    $retval .= ' print "$file extracted anyway.\n"; ';
                }
                $retval .= ' } else {';
            }
            if ( $silent_mode == 0 ) {
                $retval .= ' print "Extracted $file\n";';
            }
            $retval .= ' } ' . "\n";
        }
        else {
            if ( $silent_mode == 0 ) {
                $retval .= 'print "Extracted $file\n";';
            }
        }
        WriteOutput($retval);
        $retval = "";
        WriteOutput( PackBinaryFile( $original_filename, $subname ) );
        $ofCount++;
    }
    if ( $silent_mode == 0 ) {
        $retval .= 'print "\n";';
    }
    if ( $run_mode == 1 ) {
        $retval .= 'exec "' . $run_file . '";';
    }
    WriteOutput($retval);
}

# PackBinaryFile($filename,$subroutine_name)
#
# Loads a file, packs it, and makes a Perl
# subroutine to unpack it.
#
# Found on comp.lang.perl.misc in a post by
# Jonathan Stowe (gellyfish@gellyfish.com)
#
sub PackBinaryFile {
    my $file    = shift || die "$0: No file specified\n";
    my $subname = shift || die "$0: No subname specified\n";
    open( FILE, $file ) || die "Couldnt open $file - $!\n";
    binmode FILE;
    my $imgdata = do { local $/; <FILE> };
    my $uustring = pack "u", $imgdata;
    return <<EOSUB;
sub $subname
{
  return unpack "u", <<'EOIMG';
$uustring
EOIMG
}
EOSUB
}

# PackData($data)
#
# Takes a Perl script, and packs it into
# a single eval() statement
#
sub PackData {
    my $data = shift || die "$0: No data specified\n";
    my $uustring = pack "u", $data;
    return <<EOSUB;
eval unpack "u", <<'EOIMG';
$uustring
EOIMG
EOSUB
}

# random_string($length)
#
# Creates a "random" string
# of the specified length
#
sub random_string {
    my $length = shift || 2;
    my @chars = ( 'a' .. 'z', 'A' .. 'Z' );
    join( '', map { $chars[ rand() * @chars ] } ( 1 .. $length ) );
}

# HashFile($file)
#
# Opens a file, reads it in,
# and returns a MD5 hash
# of the file.
#
sub HashFile {
    my ($filename) = @_;
    open( FILE, $filename ) || die "Couldnt open $filename - $!\n";
    binmode FILE;
    my $fdata = do { local $/; <FILE> };
    close FILE;
    my $md5 = Digest::MD5->new;
    $md5->add($fdata);
    return $md5->hexdigest;

}

# GetFileList($directory)
#
# Returns an array containing all
# the files in a directory, non-
# recursively.
#
sub GetFileList {
    my ($directory_name) = @_;
    my @file_list = ();
    opendir( TDIR, "$directory_name" )
      or die "Error opening directory $directory_name.";
    my @tdir = grep { -f "$directory_name/$_" } readdir(TDIR);
    closedir(TDIR);
    foreach my $ent (@tdir) {
        push( @file_list, "$directory_name/$ent" );
    }
    return @file_list;
}

# foundafile($filename)
#
# Helper sub for GetFileListRecursive()
#
sub foundafile {
    my $filename = $_;
    my $fullpath = $File::Find::name;

    if ( -e $filename ) {
        if ( -f $filename ) {
            push( @rFilelist, $fullpath );
            my $opath = $fullpath;
            $opath =~ s/$basedir/./g;
            push( @oFileList, $opath );
        }

    }
}

# GetFileListRecursive($directory)
#
# Returns an array containing all
# the files in a directory,
# recursively.
#
sub GetFileListRecursive {
    my ($directory_name) = @_;
    $basedir = $directory_name;
    find( \&foundafile, "$directory_name" );
    my @ofl;
    foreach my $fn (@oFileList) {
        if ( $fn ne '.' ) { push( @DirTree, dirname($fn) ) }
    }
    my @cleaned    = ();
    my %duplicates = ();
    @cleaned = grep { !$duplicates{$_}++ } @DirTree;
    @DirTree = @cleaned;
    return @rFilelist;
}

# WriteOutput($stuff_to_write)
#
# Writes output to either STDOUT or to file
#
sub WriteOutput {
    my ($data) = @_;
    if ($output_file) {
        open( FILE, ">>$output_filename" ) or die "Error writing file.
+";
        print FILE $data;
        close FILE;
    }
    else {
        print "$data";
    }
}

# =================
# POD DOCUMENTATION
# =================

=head1 NAME

SIP (Sip Is not Par) v0.45

=head1 DESCRIPTION

SIP is an archiving tool.  It can combine any number of files into a s
+ingle Perl script the extracts the files upon execution.

=head1 USAGE

C<$ perl sip.pl [ OPTIONS] file file ...>

Options:

B<-v,--version>

Print version and exit

B<-h,--help>

Print this text

B<-r,--run <file/cmd>>

Execute a script/command after extraction

B<-R,--pre <file/cmd>>

Execute a script/command before extraction

B<-n,--nobanner>

Do not print banner in output script

B<-N,--name <text>>

Changes the displayed name in the banner

B<-s,--silent>

Output script executes silently

B<-p,--text <text>>

Print text at beginning of output script

B<-P,--print <filename>>

Prints the contents of a text file at beginning of output script

B<-m,--md5>

Verify file integrity.  Output script will require Digest::MD5

B<-f,--force>

Force extraction of damaged files

B<-d,--dir <path>>

Add all files in directory to script. To add multiple directories, sep
+erate them by comma.

B<-D,--recursive <path>>

Add all files in directory (recursive) to script.   Directory structur
+e is recreated on extraction. To add multiple directories, seperate t
+hem by comma.

B<-t,--temp>

Extract all files to temp directory

B<-l,--location <dir>>

Extract all files to a specific directory

B<-o,--output <filename>>

Write output to file

B<-w,--overwrite>

Automatically overwrite existing files with output

B<-b,--noshebang>

Do NOT add shebang to output script

B<-B,--shebang <text>>

Use another shebang instead of #!/usr/bin/perl

=cut

__DATA__
use strict;
use Digest::MD5;
!FILEPATH
my $file;
my $packed_data;
my $hash;
sub VerifyFile { my($ohash,$filename)=@_; if($ohash==HashFile($filenam
+e)) { return 1; } return 0; }
sub HashFile { my($filename)=@_; open( FILE, $filename ) || die "Could
+nt open $filename - $!\n"; binmode FILE; my $fdata = do { local $/; <
+FILE> }; close FILE; my $md5 = Digest::MD5->new; $md5->add($fdata); r
+eturn $md5->hexdigest; }
!BANNER
%%BREAK%%
use strict;
!FILEPATH
my $file;
my $packed_data;
!BANNER

Back to Code Catacombs