File Coverage

blib/lib/Image/ExifTool/BZZ.pm

Criterion	Covered	Total	%
statement	188	204	92.1
branch	41	62	66.1
condition	8	20	40.0
subroutine	15	15	100.0
pod	0	8	0.0
total	252	309	81.5

#------------------------------------------------------------------------------
# File:         BZZ.pm
#
# Description:  Utility to decode BZZ compressed data
#
# Revisions:    09/22/2008 - P. Harvey Created
#
# References:   1) http://djvu.sourceforge.net/
#               2) http://www.djvu.org/
#
# Notes:        This code based on ZPCodec and BSByteStream of DjVuLibre 3.5.21
#               (see NOTES documentation below for license/copyright details)
#------------------------------------------------------------------------------

package Image::ExifTool::BZZ;

use strict;
use integer;    # IMPORTANT!!  use integer arithmetic throughout
require Exporter;
use vars qw($VERSION @ISA @EXPORT_OK);

$VERSION = '1.00';
@ISA = qw(Exporter);
@EXPORT_OK = qw(Decode);

# constants
sub FREQMAX { 4 }
sub CTXIDS  { 3 }
sub MAXBLOCK { 4096 }

# This table has been designed for the ZPCoder
# by running the following command in file 'zptable.sn':
# (fast-crude (steady-mat 0.0035  0.0002) 260)))
my @default_ztable_p = (
    0x8000, 0x8000, 0x8000, 0x6bbd, 0x6bbd, 0x5d45, 0x5d45, 0x51b9, 0x51b9, 0x4813,
    0x4813, 0x3fd5, 0x3fd5, 0x38b1, 0x38b1, 0x3275, 0x3275, 0x2cfd, 0x2cfd, 0x2825,
    0x2825, 0x23ab, 0x23ab, 0x1f87, 0x1f87, 0x1bbb, 0x1bbb, 0x1845, 0x1845, 0x1523,
    0x1523, 0x1253, 0x1253, 0x0fcf, 0x0fcf, 0x0d95, 0x0d95, 0x0b9d, 0x0b9d, 0x09e3,
    0x09e3, 0x0861, 0x0861, 0x0711, 0x0711, 0x05f1, 0x05f1, 0x04f9, 0x04f9, 0x0425,
    0x0425, 0x0371, 0x0371, 0x02d9, 0x02d9, 0x0259, 0x0259, 0x01ed, 0x01ed, 0x0193,
    0x0193, 0x0149, 0x0149, 0x010b, 0x010b, 0x00d5, 0x00d5, 0x00a5, 0x00a5, 0x007b,
    0x007b, 0x0057, 0x0057, 0x003b, 0x003b, 0x0023, 0x0023, 0x0013, 0x0013, 0x0007,
    0x0007, 0x0001, 0x0001, 0x5695, 0x24ee, 0x8000, 0x0d30, 0x481a, 0x0481, 0x3579,
    0x017a, 0x24ef, 0x007b, 0x1978, 0x0028, 0x10ca, 0x000d, 0x0b5d, 0x0034, 0x078a,
    0x00a0, 0x050f, 0x0117, 0x0358, 0x01ea, 0x0234, 0x0144, 0x0173, 0x0234, 0x00f5,
    0x0353, 0x00a1, 0x05c5, 0x011a, 0x03cf, 0x01aa, 0x0285, 0x0286, 0x01ab, 0x03d3,
    0x011a, 0x05c5, 0x00ba, 0x08ad, 0x007a, 0x0ccc, 0x01eb, 0x1302, 0x02e6, 0x1b81,
    0x045e, 0x24ef, 0x0690, 0x2865, 0x09de, 0x3987, 0x0dc8, 0x2c99, 0x10ca, 0x3b5f,
    0x0b5d, 0x5695, 0x078a, 0x8000, 0x050f, 0x24ee, 0x0358, 0x0d30, 0x0234, 0x0481,
    0x0173, 0x017a, 0x00f5, 0x007b, 0x00a1, 0x0028, 0x011a, 0x000d, 0x01aa, 0x0034,
    0x0286, 0x00a0, 0x03d3, 0x0117, 0x05c5, 0x01ea, 0x08ad, 0x0144, 0x0ccc, 0x0234,
    0x1302, 0x0353, 0x1b81, 0x05c5, 0x24ef, 0x03cf, 0x2b74, 0x0285, 0x201d, 0x01ab,
    0x1715, 0x011a, 0x0fb7, 0x00ba, 0x0a67, 0x01eb, 0x06e7, 0x02e6, 0x0496, 0x045e,
    0x030d, 0x0690, 0x0206, 0x09de, 0x0155, 0x0dc8, 0x00e1, 0x2b74, 0x0094, 0x201d,
    0x0188, 0x1715, 0x0252, 0x0fb7, 0x0383, 0x0a67, 0x0547, 0x06e7, 0x07e2, 0x0496,
    0x0bc0, 0x030d, 0x1178, 0x0206, 0x19da, 0x0155, 0x24ef, 0x00e1, 0x320e, 0x0094,
    0x432a, 0x0188, 0x447d, 0x0252, 0x5ece, 0x0383, 0x8000, 0x0547, 0x481a, 0x07e2,
    0x3579, 0x0bc0, 0x24ef, 0x1178, 0x1978, 0x19da, 0x2865, 0x24ef, 0x3987, 0x320e,
    0x2c99, 0x432a, 0x3b5f, 0x447d, 0x5695, 0x5ece, 0x8000, 0x8000, 0x5695, 0x481a,
    0x481a, 0, 0, 0, 0, 0
);
my @default_ztable_m = (
    0x0000, 0x0000, 0x0000, 0x10a5, 0x10a5, 0x1f28, 0x1f28, 0x2bd3, 0x2bd3, 0x36e3,
    0x36e3, 0x408c, 0x408c, 0x48fd, 0x48fd, 0x505d, 0x505d, 0x56d0, 0x56d0, 0x5c71,
    0x5c71, 0x615b, 0x615b, 0x65a5, 0x65a5, 0x6962, 0x6962, 0x6ca2, 0x6ca2, 0x6f74,
    0x6f74, 0x71e6, 0x71e6, 0x7404, 0x7404, 0x75d6, 0x75d6, 0x7768, 0x7768, 0x78c2,
    0x78c2, 0x79ea, 0x79ea, 0x7ae7, 0x7ae7, 0x7bbe, 0x7bbe, 0x7c75, 0x7c75, 0x7d0f,
    0x7d0f, 0x7d91, 0x7d91, 0x7dfe, 0x7dfe, 0x7e5a, 0x7e5a, 0x7ea6, 0x7ea6, 0x7ee6,
    0x7ee6, 0x7f1a, 0x7f1a, 0x7f45, 0x7f45, 0x7f6b, 0x7f6b, 0x7f8d, 0x7f8d, 0x7faa,
    0x7faa, 0x7fc3, 0x7fc3, 0x7fd7, 0x7fd7, 0x7fe7, 0x7fe7, 0x7ff2, 0x7ff2, 0x7ffa,
    0x7ffa, 0x7fff, 0x7fff, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
);
my @default_ztable_up = (
     84,   3,   4,   5,   6,   7,   8,   9,  10,  11,  12,  13,  14,  15,  16,  17,
     18,  19,  20,  21,  22,  23,  24,  25,  26,  27,  28,  29,  30,  31,  32,  33,
     34,  35,  36,  37,  38,  39,  40,  41,  42,  43,  44,  45,  46,  47,  48,  49,
     50,  51,  52,  53,  54,  55,  56,  57,  58,  59,  60,  61,  62,  63,  64,  65,
     66,  67,  68,  69,  70,  71,  72,  73,  74,  75,  76,  77,  78,  79,  80,  81,
     82,  81,  82,   9,  86,   5,  88,  89,  90,  91,  92,  93,  94,  95,  96,  97,
     82,  99,  76, 101,  70, 103,  66, 105, 106, 107,  66, 109,  60, 111,  56,  69,
    114,  65, 116,  61, 118,  57, 120,  53, 122,  49, 124,  43,  72,  39,  60,  33,
     56,  29,  52,  23,  48,  23,  42, 137,  38,  21, 140,  15, 142,   9, 144, 141,
    146, 147, 148, 149, 150, 151, 152, 153, 154, 155,  70, 157,  66,  81,  62,  75,
     58,  69,  54,  65,  50, 167,  44,  65,  40,  59,  34,  55,  30, 175,  24, 177,
    178, 179, 180, 181, 182, 183, 184,  69, 186,  59, 188,  55, 190,  51, 192,  47,
    194,  41, 196,  37, 198, 199,  72, 201,  62, 203,  58, 205,  54, 207,  50, 209,
     46, 211,  40, 213,  36, 215,  30, 217,  26, 219,  20,  71,  14,  61,  14,  57,
      8,  53, 228,  49, 230,  45, 232,  39, 234,  35, 138,  29,  24,  25, 240,  19,
     22,  13,  16,  13,  10,   7, 244, 249,  10,  89, 230, 0, 0, 0, 0, 0
);
my @default_ztable_dn = (
    145,   4,   3,   1,   2,   3,   4,   5,   6,   7,   8,   9,  10,  11,  12,  13,
     14,  15,  16,  17,  18,  19,  20,  21,  22,  23,  24,  25,  26,  27,  28,  29,
     30,  31,  32,  33,  34,  35,  36,  37,  38,  39,  40,  41,  42,  43,  44,  45,
     46,  47,  48,  49,  50,  51,  52,  53,  54,  55,  56,  57,  58,  59,  60,  61,
     62,  63,  64,  65,  66,  67,  68,  69,  70,  71,  72,  73,  74,  75,  76,  77,
     78,  79,  80,  85, 226,   6, 176, 143, 138, 141, 112, 135, 104, 133, 100, 129,
     98, 127,  72, 125, 102, 123,  60, 121, 110, 119, 108, 117,  54, 115,  48, 113,
    134,  59, 132,  55, 130,  51, 128,  47, 126,  41,  62,  37,  66,  31,  54,  25,
     50, 131,  46,  17,  40,  15, 136,   7,  32, 139, 172,   9, 170,  85, 168, 248,
    166, 247, 164, 197, 162,  95, 160, 173, 158, 165, 156, 161,  60, 159,  56,  71,
     52, 163,  48,  59,  42, 171,  38, 169,  32,  53,  26,  47, 174, 193,  18, 191,
    222, 189, 218, 187, 216, 185, 214,  61, 212,  53, 210,  49, 208,  45, 206,  39,
    204, 195, 202,  31, 200, 243,  64, 239,  56, 237,  52, 235,  48, 233,  44, 231,
     38, 229,  34, 227,  28, 225,  22, 223,  16, 221, 220,  63,   8,  55, 224,  51,
      2,  47,  87,  43, 246,  37, 244,  33, 238,  27, 236,  21,  16,  15,   8, 241,
    242,   7,  10, 245,   2,   1,  83, 250,   2, 143, 246, 0, 0, 0, 0, 0
);

#------------------------------------------------------------------------------
# New - create new BZZ object
# Inputs: 0) reference to BZZ object or BZZ class name
# Returns: blessed BZZ object ref
sub new
{
    local $_;
    my $that = shift;
    my $class = ref($that) || $that || 'Image::ExifTool::BZZ';
    return bless {}, $class;
}

#------------------------------------------------------------------------------
# Initialize BZZ object
# Inputs: 0) BZZ object ref, 1) data ref, 2) true for DjVu compatibility
sub Init($$)
{
    my ($self, $dataPt, $djvucompat) = @_;
    # Create machine independent ffz table
    my $ffzt = $$self{ffzt} = [ ];
    my ($i, $j);
    for ($i=0; $i<256; $i++) {
        $$ffzt[$i] = 0;
        for ($j=$i; $j&0x80; $j<<=1) {
            $$ffzt[$i] += 1;
        }
    }
    # Initialize table
    $$self{p} = [ @default_ztable_p ];
    $$self{'m'} = [ @default_ztable_m ];
    $$self{up} = [ @default_ztable_up ];
    $$self{dn} = [ @default_ztable_dn ];
    # Patch table (and lose DjVu compatibility)
    unless ($djvucompat) {
        my ($p, $m, $dn) = ($$self{p}, $$self{'m'}, $$self{dn});
        for ($j=0; $j<256; $j++) {
            my $a = (0x10000 - $$p[$j]) & 0xffff;
            while ($a >= 0x8000) { $a = ($a<<1) & 0xffff }
            if ($$m[$j]>0 && $a+$$p[$j]>=0x8000 && $a>=$$m[$j]) {
                $$dn[$j] = $default_ztable_dn[$default_ztable_dn[$j]];
            }
        }
    }
    $$self{ctx} = [ (0) x 300 ];
    $$self{DataPt} = $dataPt;
    $$self{Pos} = 0;
    $$self{DataLen} = length $$dataPt;
    $$self{a} = 0;
    $$self{buffer} = 0;
    $$self{fence} = 0;
    $$self{blocksize} = 0;
    # Read first 16 bits of code
    if (length($$dataPt) >= 2) {
        $$self{code} = unpack('n', $$dataPt);
        $$self{Pos} += 2;
    } elsif (length($$dataPt) >= 1) {
        $$self{code} = (unpack('C', $$dataPt) << 8) | 0xff;
        $$self{Pos}++;
    } else {
        $$self{code} = 0xffff;
    }
    $$self{byte} = $$self{code} & 0xff;
    # Preload buffer
    $$self{delay} = 25;
    $$self{scount} = 0;
    # Compute initial fence
    $$self{fence} = $$self{code} >= 0x8000 ? 0x7fff : $$self{code};
}

#------------------------------------------------------------------------------
# Decode data block
# Inputs: 0) optional BZZ object ref, 1) optional data ref
# Returns: decoded data or undefined on error
# Notes: If called without a data ref, an input BZZ object ref must be given and
#        the BZZ object must have been initialized by a previous call to Init()
sub Decode($;$)
{
    # Decode input stream
    local $_;
    my $self;
    if (ref $_[0] and UNIVERSAL::isa($_[0],'Image::ExifTool::BZZ')) {
        $self = shift;
    } else {
        $self = new Image::ExifTool::BZZ;
    }
    my $dataPt = shift;
    if ($dataPt) {
        $self->Init($dataPt, 1);
    } else {
        $dataPt = $$self{DataPt} or return undef;
    }
    # Decode block size
    my $n = 1;
    my $m = (1 << 24);
    while ($n < $m) {
        my $b = $self->decode_sub(0x8000 + ($$self{a}>>1));
        $n = ($n<<1) | $b;
    }
    $$self{size} = $n - $m;

    return '' unless $$self{size};
    return undef if $$self{size} > MAXBLOCK()*1024;
    # Allocate
    if ($$self{blocksize} < $$self{size}) {
        $$self{blocksize} = $$self{size};
    }
    # Decode Estimation Speed
    my $fshift = 0;
    if ($self->decode_sub(0x8000 + ($$self{a}>>1))) {
        $fshift += 1;
        $fshift += 1 if $self->decode_sub(0x8000 + ($$self{a}>>1));
    }
    # Prepare Quasi MTF
    my @mtf = (0..255);
    my @freq = (0) x FREQMAX();
    my $fadd = 4;
    # Decode
    my $mtfno = 3;
    my $markerpos = -1;
    my $cx = $$self{ctx};
    my ($i, @dat);
byte: for ($i=0; $i<$$self{size}; $i++) {
        # dummy loop avoids use of "goto" statement
dummy:  for (;;) {
            my $ctxid = CTXIDS() - 1;
            $ctxid = $mtfno if $ctxid > $mtfno;
            my $cp = 0;
            my ($imtf, $bits);
            for ($imtf=0; $imtf<2; ++$imtf) {
                if ($self->decoder($$cx[$cp+$ctxid])) {
                    $mtfno = $imtf;
                    $dat[$i] = $mtf[$mtfno];
                    # (a "goto" here could give a segfault due to a Perl bug)
                    last dummy; # do rotation
                }
                $cp += CTXIDS();
            }
            for ($bits=1; $bits<8; ++$bits, $imtf<<=1) {
                if ($self->decoder($$cx[$cp])) {
                    my $n = 1;
                    my $m = (1 << $bits);
                    while ($n < $m) {
                        my $b = $self->decoder($$cx[$cp+$n]);
                        $n = ($n<<1) | $b;
                    }
                    $mtfno = $imtf + $n - $m;
                    $dat[$i] = $mtf[$mtfno];
                    last dummy; # do rotation
                }
                $cp += $imtf;
            }
            $mtfno=256;
            $dat[$i] = 0;
            $markerpos=$i;
            next byte;  # no rotation necessary
        }
        # Rotate mtf according to empirical frequencies (new!)
        # Adjust frequencies for overflow
        $fadd = $fadd + ($fadd >> $fshift);
        if ($fadd > 0x10000000)  {
            $fadd >>= 24;
            $_ >>= 24 foreach @freq;
        }
        # Relocate new char according to new freq
        my $fc = $fadd;
        $fc += $freq[$mtfno] if $mtfno < FREQMAX();
        my $k;
        for ($k=$mtfno; $k>=FREQMAX(); $k--) {
            $mtf[$k] = $mtf[$k-1];
        }
        for (; $k>0 && $fc>=$freq[$k-1]; $k--) {
            $mtf[$k] = $mtf[$k-1];
            $freq[$k] = $freq[$k-1];
        }
        $mtf[$k] = $dat[$i];
        $freq[$k] = $fc;
        # when "goto" was used, Perl 5.8.6 could segfault here
        # unless "next" was explicitly stated
    }
#
# Reconstruct the string
#
    return undef if $markerpos<1 || $markerpos>=$$self{size};
    # Allocate pointers
    # Prepare count buffer
    my @count = (0) x 256;
    my @posn;
    # Fill count buffer
    no integer;
    for ($i=0; $i<$markerpos; $i++) {
        my $c = $dat[$i];
        $posn[$i] = ($c<<24) | ($count[$c]++ & 0xffffff);
    }
    $posn[$i++] = 0; # (initialize marker entry just to be safe)
    for ( ; $i<$$self{size}; $i++) {
        my $c = $dat[$i];
        $posn[$i] = ($c<<24) | ($count[$c]++ & 0xffffff);
    }
    use integer;
    # Compute sorted char positions
    my $last = 1;
    for ($i=0; $i<256; $i++) {
        my $tmp = $count[$i];
        $count[$i] = $last;
        $last += $tmp;
    }
    # Undo the sort transform
    $i = 0;
    $last = $$self{size}-1;
    while ($last > 0) {
        my $n = $posn[$i];
        no integer;
        my $c = $n >> 24;
        use integer;
        $dat[--$last] = $c;
        $i = $count[$c] + ($n & 0xffffff);
    }
    # Final check and return decoded data
    return undef if $i != $markerpos;
    pop @dat;   # (last byte isn't real)
    return pack 'C*', @dat;
}

#------------------------------------------------------------------------------
# Inputs: 0) BZZ object ref, 1) ctx
# Returns: decoded bit
sub decoder($$)
{
    my ($self, $ctx) = @_;
    my $z = $$self{a} + $self->{p}[$ctx];
    if ($z <= $$self{fence}) {
        $$self{a} = $z;
        return ($ctx & 1);
    }
    # must pass $_[1] so subroutine can modify value (darned C++ pass-by-reference!)
    return $self->decode_sub($z, $_[1]);
}

#------------------------------------------------------------------------------
# Inputs: 0) BZZ object ref, 1) z, 2) ctx (or undef)
# Returns: decoded bit
sub decode_sub($$;$)
{
    my ($self, $z, $ctx) = @_;

    # ensure that we have at least 16 bits of encoded data available
    if ($$self{scount} < 16) {
        # preload byte by byte until we have at least 24 bits
        while ($$self{scount} <= 24) {
            if ($$self{Pos} < $$self{DataLen}) {
                $$self{byte} = ord(substr(${$$self{DataPt}}, $$self{Pos}, 1));
                ++$$self{Pos};
            } else {
                $$self{byte} = 0xff;
                if (--$$self{delay} < 1) {
                    # setting size to zero forces error return from Decode()
                    $$self{size} = 0;
                    return 0;
                }
            }
            $$self{buffer} = ($$self{buffer}<<8) | $$self{byte};
            $$self{scount} += 8;
        }
    }
    # Save bit
    my $a = $$self{a};
    my ($bit, $code);
    if (defined $ctx) {
        $bit = ($ctx & 1);
        # Avoid interval reversion
        my $d = 0x6000 + (($z+$a)>>2);
        $z = $d if $z > $d;
    } else {
        $bit = 0;
    }
    # Test MPS/LPS
    if ($z > ($code = $$self{code})) {
        $bit ^= 1;
        # LPS branch
        $z = 0x10000 - $z;
        $a += $z;
        $code += $z;
        # LPS adaptation
        $_[2] = $self->{dn}[$ctx] if defined $ctx;
        # LPS renormalization
        my $sft = $a>=0xff00 ? $self->{ffzt}[$a&0xff] + 8 : $self->{ffzt}[($a>>8)&0xff];
        $$self{scount} -= $sft;
        $$self{a} = ($a<<$sft) & 0xffff;
        $code = (($code<<$sft) & 0xffff) | (($$self{buffer}>>$$self{scount}) & ((1<<$sft)-1));
    } else {
        # MPS adaptation
        $_[2] = $self->{up}[$ctx] if defined $ctx and $a >= $self->{'m'}[$ctx];
        # MPS renormalization
        $$self{scount} -= 1;
        $$self{a} = ($z<<1) & 0xffff;
        $code = (($code<<1) & 0xffff) | (($$self{buffer}>>$$self{scount}) & 1);
    }
    # Adjust fence and save new code
    $$self{fence} = $code >= 0x8000 ? 0x7fff : $code;
    $$self{code} = $code;
    return $bit;
}

1;  # end

__END__