File Coverage

blib/lib/Compress/SelfExtracting.pm

Criterion	Covered	Total	%
statement	368	401	91.7
branch	72	104	69.2
condition	16	17	94.1
subroutine	35	40	87.5
pod	3	4	75.0
total	494	566	87.2

package Compress::SelfExtracting;
use Digest::MD5 'md5_hex';
require Exporter;

use vars qw/@ISA @EXPORT @EXPORT_OK $VERSION/;

@EXPORT_OK = qw/compress decompress/;
@EXPORT = qw/zscript zfile/;
@ISA = qw/Exporter/;
$VERSION = 0.04;

my %O;
BEGIN {
    %O = (standalone => 1,
	  type => 'LZW',
	  op => 'eval',
	  uu => 1);
};

sub compress
{
    my $data = shift;
    my %o = @_;
    @O{keys %o} = values %o;
    my $cdata = &{"Compress::SelfExtracting::$O{type}::compress"}($data, \%O);
    if ($O{uu}) {
	$cdata = pack 'u', $cdata;
    }
    if ($O{standalone}) {
	my $sa = &{"Compress::SelfExtracting::$O{type}::standalone"}(\%O);
	return $sa.$cdata;
    } else {
	return "use Compress::SelfExtracting::Filter "
		.join(', ', map { "$_ => '$O{$_}'" }
		  grep!/decompress|file|data/,keys %O).";\n"
		.md5_hex($data)."\n$cdata\n";
    }
}

sub decompress
{
    my $data = shift;
    my %o = @_;
    @O{keys %o} = values %o;
    if ($data =~ /^([0-9a-f]+)\n(.*)/s) {
	if ($O{uu}) {
	    $data = unpack 'u', $2;
	} else {
	    chomp($data = $2);
	}
	$data = &{"Compress::SelfExtracting::$O{type}::decompress"}($data, \%O);
	my $cksum = md5_hex($data);
	unless ($cksum eq $1) {
	    open BAD, ">BAD";
	    print BAD $data;
	    close BAD;
	    die "Bad checksum\n";
	}
    } else {
	die "$0 doesn't look compressed\n";
    }
    $data;
}

sub zscript
{
    local $/ = undef;
    my $data = ;
    print compress $data, @_;
}

sub zfile
{
    local $/ = undef;
    my $data = ;
    print compress $data, @_, op => 'print';
}

############################################################
package Compress::SelfExtracting::LZ77;

sub import { }

sub compress
{
    my $str = shift;
    die "Sorry, code too long\n" if length($str) >= 1<<16;
    my @rep;
    my $la = 0;
    while ($la < length $str) {
	my $n = 1;
	my ($tmp, $p);
	$p = 0;
	while ($la + $n < length $str
	       && $n < 255
	       && ($tmp = index(substr($str, 0, $la),
				substr($str, $la, $n),
				$p)) >= 0) {
	    $p = $tmp;
	    $n++;
	}
	--$n;
	my $c = substr($str, $la + $n, 1);
	push @rep, [$p, $n, ord $c];
	$la += $n + 1;
    }
    join('', map { pack 'SCC', @$_ } @rep);
}

sub decompress
{
    my $str = shift;
    my $ret = '';
    while (length $str) {
	my ($s, $l, $c) = unpack 'SCC', $str;
	$ret .= substr($ret, $s, $l).chr$c;
	$str=substr($str,4);
    }
    $ret;
}

sub standalone
{
    my $O = shift;
    my $ret = <<'EOC';
BEGIN{open 0;$_=join'',<0>;s/^.*?}\n//s;#UUDEC#s/(...)(.)/
($o,$l)=unpack SC,$1;$r.=substr($r,$o,$l).$2/egs;#OP#$r;exit}
EOC
    if ($O->{uu}) {
	$ret =~ s/#UUDEC#/\$_=unpack'u',\$_;/;
    } else {
	$ret =~ s/#UUDEC#//;
    }
    $ret =~ s/#OP#/$O->{op}/;
    $ret;
}

############################################################
package Compress::SelfExtracting::LZSS;

sub import { }

sub compress
{
    my $str = shift;
    die "Sorry, code too long\n" if length($str) >= 1<<16;
    my @rep;
    my $la = 0;
    while ($la < length $str) {
	my $n = 1;
	my ($tmp, $p);
	$p = 0;
	while ($la + $n < length $str
	       && $n < 255
	       && ($tmp = index(substr($str, 0, $la),
				substr($str, $la, $n),
				$p)) >= 0) {
	    $p = $tmp;
	    $n++;
	}
	--$n;
	if ($n < 2) {
	    push @rep, "\0".substr($str, $la, 1);
	    ++$la;
	} else {
	    push @rep, pack 'CS', $n, $p;
	    $la += $n;
	}
    }
    join('', @rep);
}

sub decompress
{
    my $str = shift;
    my $ret = '';
    my $o = 0;
    while ($o < length $str) {
	my $n = unpack 'C', substr($str, $o);
	if ($n == 0) {
	    $ret .= substr($str, $o + 1, 1);
	    $o += 2;
	} else {
	    my $p = unpack 'S', substr($str, $o + 1);
	    $ret .= substr($ret, $p, $n);
	    $o += 3;
	}
    }
    $ret;
}

sub standalone
{
    my $ret = <<'END';
BEGIN{open 0;$_=join'',<0>;s/^.*?}\n//s;#UUDEC#($r.=($n=ord substr$_,
$o++)?substr$r,(unpack S,substr$_,$o++),$n:substr$_,$o,1),$o++
while$o
END
    my $O = shift;
    if ($O->{uu}) {
	$ret =~ s/#UUDEC#/\$_=unpack'u',\$_;/
    } else {
	$ret =~ s/#UUDEC#//;
    }
    $ret =~ s/#OP#/$O->{op}/;
    $ret;
}

############################################################
package Compress::SelfExtracting::LZW;

my (%LZ, %UNLZ, %SA);

sub import
{
    %LZ = (12 => sub {
		 my $v = '';
		 for my $i (0..$#_) {
		     vec($v, 3*$i, 4) = $_[$i]/256;
		     vec($v, 3*$i+1, 4) = ($_[$i]/16)%16;
		     vec($v, 3*$i+2, 4) = $_[$i]%16;
		 }
		 $v;
	     },
	     16 => sub { pack 'S*', @_ });
    %UNLZ = (12 => sub {
		   my $code = shift;
		   my @code;
		   my $len = length($code);
		   my $reallen = 2*$len/3;
		   print STDERR "len = $len, reallen = $reallen\n";
		   foreach (0..$reallen - 1) {
		       push @code, (vec($code, 3*$_, 4)<<8)
			         | (vec($code, 3*$_+1, 4)<<4)
				 | (vec($code, 3*$_+2, 4));
		   }
		   @code;
	       },
	       16 => sub { unpack 'S*', shift; });
    # Now the self-extracting glop:
    my $ANY_16 = <<'EOC';
BEGIN{open 0;$/=$!;%d=map{($_,chr)}0..($n=255);($s=join'',<0>)
=~s/^.*?}\n//s;#OP# join'',map{($C,$P)=@d{$_,$p};$p=$_;if
(!defined$P){$d{$p}}elsif(defined$C){$d{++$n}=$P.substr$C,0,
1;$C}else{$d{++$n}=$P.substr$P,0,1}}unpack'S*',#UUDEC#;exit}
EOC
    (my $u16 = $ANY_16) =~ s/#UUDEC#/unpack'u',\$s/;
    (my $n16 = $ANY_16) =~ s/#UUDEC#/\$s/;
    my $ANY_12 = <<'EOC';
BEGIN{open 0;$/=$!;%d=map{($_,chr)}0..($n=255);($s=join'',<0>)
=~s/^.*?}\n//s;#UUDEC##OP# join'',map{($C,$P)=@d{$_,$p};$p=$_;if
(!defined$P){$C}elsif(defined$C){$d{++$n}=$P.substr$C,0,1;$C}else{
$d{++$n}=$P.substr$P,0,1}}map{vec($s,3*$_,4)<<8|vec($s,3*$_+1,4)<<4
|vec$s,3*$_+2,4}0..length($s)*2/3-1;exit}
EOC
    (my $u12 = $ANY_12) =~ s/#UUDEC#/\$s=unpack'u',\$s;/;
    (my $n12 = $ANY_12) =~ s/#UUDEC#//;
    %SA = ('12u0' => $n12, '12u1' => $u12, '16u0' => $n16, '16u1' => $u16);
}

sub compress
{
    my ($str, $O) = @_;
    my $p = ''; my %d = map{(chr $_, $_)} 0..255;
    my @o = ();
    my $ncw = 256;
    for (split '', $str) {
	if (exists $d{$p.$_}) {
	    $p .= $_;
	} else {
	    push @o, $d{$p};
	    $d{$p.$_} = $ncw++;
	    $p = $_;
	}
    }
    push @o, $d{$p};
    if ($O->{bits} != 16 && $ncw < 1<<12) {
	$O->{bits} = 12;
	return $LZ{12}->(@o);
    } elsif ($ncw < 1<<16) {
	$O->{bits} = 16;
	return $LZ{16}->(@o);
    } else {
	die "Sorry, code-word overflow";
    }
}

sub decompress
{
    my %d = (map{($_, chr $_)} 0..255);
    my $ncw = 256;
    my $ret = '';
    my ($str, $O) = @_;
    my ($p, @code) = $UNLZ{$O->{bits}}->($str);
    $ret .= $d{$p};
    for (@code) {
	if (exists $d{$_}) {
	    $ret .= $d{$_};
	    $d{$ncw++} = $d{$p}.substr($d{$_}, 0, 1);
	} else {
	    my $dp = $d{$p};
	    warn unless $_ == $ncw++;
	    $ret .= ($d{$_} = $dp.substr($dp, 0, 1));
	}
	$p = $_;
    }
    $ret;
}

sub standalone
{
    my $O = shift;
    my $ret = $SA{"$O->{bits}u$O->{uu}"};
    $ret =~ s/#OP#/$O->{op}/;
    $ret;
}

############################################################
package Compress::SelfExtracting::Huffman;

# Compute bit-codes from tree.
sub tree2str
{
    my ($str, $x) = @_;
    if (!defined $x->[2]) {
	$rep{$x->[1]} = $str;
    } else {
	tree2str($str.'0', $x->[1]);
	tree2str($str.'1', $x->[2]);
    }
}

sub compress
{
    my %p = ();
    my $s = shift;
    my @chars;
    if (ref $s eq 'ARRAY') {
	@chars = @$s;
    } else {
	@chars = split '', $s;
    }
    for (@chars) {
	$p{$_}++;
    }
    my @elts = sort { $a->[0] <=> $b->[0] }
	map { [ $p{$_}, $_, undef ] } keys %p;
    while (@elts > 1) {
	my ($x, $y) = splice @elts, 0, 2;
	my $z = [ $x->[0] + $y->[0], $x, $y ];
	foreach my $i (0..$#elts) {
	    if ($elts[$i]->[0] >= $z->[0]) {
		splice @elts, $i, 0, $z;
		undef $z;
		last;
	    }
	}
	push @elts, $z if $z;
    }
    local %rep = ();		# gets filled in by tree2str.
    tree2str '', pop @elts;
    if ($::DEBUG) {
	foreach (sort keys %rep) {
	    print STDERR "$_ <- $rep{$_}\n";
	}
    }
    my $data = '';
    for (@chars) {
	$data .= $rep{$_};
    }
    my $nbits = length($data);
    my $tree = pack 'CL', scalar keys %rep, $nbits;
    print STDERR "len = ", scalar keys %rep, "nbits = $nbits\n" if $::DEBUG;
    while (my ($k, $v) = each %rep) {
	die "Sorry, Huffman code too long ($v)\n" if length $v >= 32;
	$tree .= pack('Cb32', ord($k), '0'x(31 - length $v).'1'.$v);
    }
    $data = pack 'b*', $data.('0'x((8 - $nbits%8) % 8));
    print STDERR length($data), " bytes of data\n" if $::DEBUG;
    $tree.$data;
}

sub decompress
{
    my $str = shift;
    my ($len, $nbits) = unpack 'CL', $str;
    $str = substr($str, 5);
    print STDERR "len = $len, nbits = $nbits\n" if $::DEBUG;
    my %rep;
    for (0..$len - 1) {
	my ($c, $x) = unpack 'Cb32', substr($str, 5*$_, 5);
	$x =~ s/^0*1//;
	die "Duplicate: $x -> $c" if exists $rep{$x};
	$rep{$x} = chr $c;
    }
    if ($::DEBUG) {
	foreach (sort keys %rep) {
	    print STDERR "$_ <- $rep{$_}\n";
	}
    }
    $str = substr($str, 5*$len);
    print STDERR length $str, " bytes of data\n" if $::DEBUG;
    my $data = unpack "b$nbits", $str;
    my $ret = '';
    my $n;
    while (length $data > 0) {
	$n = 1;
	while (!exists($rep{substr($data, 0, $n)})) {
	    $n++;
	    die $n if $n > length $data;
	}
	$ret .= $rep{substr($data, 0, $n)};
	$data = substr($data, $n);
    }
    $ret;
}

sub standalone
{

    my $ret = <<'EOC';
BEGIN{open 0;$/=$!;($s=join'',<0>)=~s/^.*?}\n//s;#UUDEC#($l,$L)=
unpack'CL',$s;$s=substr$s,5;for(1..$l){($c,$x)=unpack'Cb32',$s;
$x=~s/^0*1//;$r{$x}=chr$c;$s=substr$s,5}$_=unpack"b$L",$s;while
(length){$n=1;1while!exists$r{substr$_,0,$n++};$r.=$r{substr$_,
0,--$n};$_=substr$_,$n}#OP#$r;exit}
EOC
    my $O = shift;
    if ($O->{uu}) {
	$ret =~ s/#UUDEC#/\$s=unpack'u',\$s;/;
    } else {
	$ret =~ s/#UUDEC#//;
    }
    $ret =~ s/#OP#/$O->{op}/;
    $ret;
}

############################################################
package Compress::SelfExtracting::BWT;
# Burrows-Wheeler Transform block-sorting compression (i.e. bzip).
#
# This implementation is a straightforward translation of this Dr
# Dobbs' piece: http://www.ddj.com/documents/s=957/ddj9609f/.  Also
# see
# http://gatekeeper.dec.com/pub/DEC/SRC/research-reports/SRC-124.ps.gz
# for the original, which IMO better describes the block-sorting.
#

import Compress::SelfExtracting::Huffman;

sub import { }

##############################
# BWT block-sorting

sub BLKSIZE() { 16*1024 }	# unused, so this sucks for big files.
sub QSORT_SIZE() { 5 }		# when to use qsort instead of counting sort.
sub _counting_sort
{
    my ($p, $o) = @_;
    if ($::DEBUG) {
	++$calls;
	if ($o > $maxdepth) {
	    $maxdepth = $o;
	    print STDERR "$o\r";
	}
    }
    my @a;
    foreach (@$p) {
	push @{$a[ord substr($s, $_+$o, 1)]}, $_;
    }
    my @ret;
    foreach (@a) {
	next unless ref $_;
	if (@$_ == 1) {
	    push @ret, $_->[0];
	} elsif (@$_ < QSORT_SIZE) {
	    my $tmp = $o+1;
	    push @ret, sort { substr($s, $a+$tmp).substr($s, 0, $a+$o) cmp
				  substr($s, $b+$tmp).substr($s, 0, $b+$o) }
		@$_;
	} else {
	    push @ret, _counting_sort($_, $o+1);
	}
    }
    @ret;
}

sub counting_sort
{
    local $s = shift;
    local $^W = 0;
    my $l = length $s;
    $s .= $s;
    local $maxdepth = 0;
    local $calls = 0;
    my @ret = _counting_sort([0..$l-1], 0);
    print STDERR "Counting sort max depth $maxdepth, calls = $calls\n"
	if $::DEBUG;
    @ret;
}

sub BWT
{
    my $str = shift;
    my $slow;
    if (length $str > BLKSIZE) {
	$slow = 1;
	warn "BWT will be very slow for ", length $str, " bytes\n";
    }
    my $d = 0;
    my ($pi, @L);
    my @posns = counting_sort($str);
    # This is quite a bit slower than counting sort.
#     my @posns = sort { substr($str, $a).substr($str, 0, $a-1) cmp
# 			   substr($str, $b).substr($str, 0, $b-1) }
# 	(0 .. length($str) - 1);
    my $i;
    foreach $i (0..$#posns) {
	if ($posns[$i] == 0) {
	    $pi = $i;
	}
	push @L, ord(substr($str, $posns[$i] - 1, 1));
    }
    ($pi, \@L);
}

sub unBWT
{
    my ($pi, $L) = @_;
    my (@P, @C);
    my @ret;
    print STDERR "length = ".@$L."\n" if $::DEBUG;
    for (0..$#{$L}) {
	my $c = $L->[$_];
	$P[$_] = $C[$c] || 0;
	$C[$c]++;
    }
    my $sum = 0;
    {
	no warnings;
	for (@C) {
	    $sum += $_;
	    $_ = $sum - $_;
	}
    }
    for (reverse 0..$#{$L}) {
	my $c = $L->[$pi];
	$ret[$_] = $c;
	$pi = $P[$pi] + $C[$c];
    }
    die unless @ret == @$L;
    return \@ret;
}

##############################
# Move-to-front coder

sub MTF
{
    my $L = shift;
    my @ret;
    my @c = 0..255;
    foreach (@$L) {
	for my $i (0..$#c) {
	    if ($c[$i] == $_) {
		push @ret, $i;
		splice @c, $i, 1;
		unshift @c, $_;
		last;
	    }
	}
    }
    \@ret;
}

sub unMTF
{
    my $L = shift;
    my @ret;
    my @c = 0..255;
    foreach (@$L) {
	my $x = $c[$_];
	push @ret, $x;
	splice @c, $_, 1;
	unshift @c, $x;
    }
    \@ret;
}

##############################
# Run-length coder

sub RLE
{
    my @ret;
    my $l = shift;
    my $c = $l->[0];
    my $n = 1;
    foreach (@{$l}[1..$#{$l}]) {
	if ($c != $_) {
	    push @ret, $c, $n;
	    $n = 1;
	    $c = $_;
	} else {
	    if (++$n > 255) {
		push @ret, $c, 255;
		$n = 1;
	    }
	}
    }
    push @ret, $c, $n;
    if ($::DEBUG) {
	my $i = 0;
	while ($i < @ret) {
	    print STDERR "$ret[$i], $ret[$i+1]\n";
	    $i += 2;
	}
    }
    \@ret;
}

sub unRLE
{
    my @l = @{shift @_};
    my @ret;
    die unless @l % 2 == 0;
    my ($c, $n);
    while (@l) {
	$c = shift @l;
	$n = shift @l;
	print STDERR "$c, $n\n" if $::DEBUG;
	push @ret, $c for 1..$n;
    }
    \@ret;
}

##############################
# Main compression routines

sub compress
{
    my ($str, $O) = @_;
    print STDERR "BWT..." if $::DEBUG;
    my ($pi, $L) = BWT($str);
    print STDERR "\nMTF..." if $::DEBUG;
    $L = MTF($L);
    print STDERR "\nRLE..." if $::DEBUG;
    $L = RLE($L);
    print STDERR "\nHuffman..." if $::DEBUG;
    $L = Compress::SelfExtracting::Huffman::compress(pack('L', $pi)
					     .join('', map { chr } @$L),
					     $O);
    print STDERR "done\n" if $::DEBUG;
    return $L;
}

sub decompress
{
    my $str = shift;
    # Huffman decode to a string:
    $str = Compress::SelfExtracting::Huffman::decompress($str);
    my $pi = unpack 'L', $str;
    $str = [map {ord} split '', substr($str, 4)];
    $str = unRLE($str);
    $str = unMTF($str);
    $str = unBWT($pi, $str);
    join '', map { chr } @$str;
}

# Oh, yeah.
sub standalone
{
    my $ret = <<'EOC';
BEGIN{open$^W=0;$/=$!;($s=join'',<0>)=~s/^.*?}\n//s;#UUDEC#($l,$L)=
unpack'CL',$s;$s=substr$s,5;for(1..$l){($c,$x)=unpack'Cb32',$s;$x=~
s/^0*1//;$r{$x}=chr$c;$s=substr$s,5}$_=unpack"b$L",$s;while(length){
$n=1;1while!exists$r{substr$_,0,$n++};$r.=$r{substr$_,0,--$n};$_=
substr$_,$n}$P=unpack'L',$r;@l=map{ord}split'',substr$r,4;while(@l){
push@R,(shift@l)x shift@l}@c=0..255;for(@R){push@M,$x=$c[$_];splice
@c,$_,1;unshift@c,$x}for(0..$#M){$c=$M[$_];$P[$_]=$C[$c]++}for(@C){
$s+=$_;$_=$s-$_}for(reverse 0..$#M){$c=$M[$P];$r[$_]=$c;$P=$P[$P]+
$C[$c]}#OP# join'',map{chr}@r;exit}
EOC
    my $O = shift;
    if ($O->{uu}) {
	$ret =~ s/#UUDEC#/\$s=unpack'u',\$s;/;
    } else {
	$ret =~ s/#UUDEC#//;
    }
    $ret =~ s/#OP#/$O->{op}/;
    $ret;
}

package Compress::SelfExtracting;
import Compress::SelfExtracting::LZW;

1;
__END__