File Coverage

blib/lib/PDF/Builder/Basic/PDF/Filter/FlateDecode.pm

Criterion	Covered	Total	%
statement	25	80	31.2
branch	2	38	5.2
condition	0	12	0.0
subroutine	7	10	70.0
pod	3	3	100.0
total	37	143	25.8

package PDF::Builder::Basic::PDF::Filter::FlateDecode;

use base 'PDF::Builder::Basic::PDF::Filter';

use strict;
use warnings;

our $VERSION = '3.024'; # VERSION
our $LAST_UPDATE = '3.016'; # manually update whenever code is changed

use POSIX qw(ceil floor);

our $havezlib;

=head1 NAME

PDF::Builder::Basic::PDF::Filter::FlateDecode - compress and uncompress stream filters for Flate

=cut

BEGIN {
    eval { require Compress::Zlib };
    $havezlib = !$@;
}

sub new {
    return unless $havezlib;
    my ($class, $decode_parms) = @_;

    my ($self) = {
        DecodeParms => $decode_parms,
    };

    $self->{'outfilt'} = Compress::Zlib::deflateInit(
        -Level   => 9,
        -Bufsize => 32768,
    );
    $self->{'infilt'} = Compress::Zlib::inflateInit();
    return bless $self, $class;
}

sub outfilt {
    my ($self, $str, $is_end) = @_;

    my $result = $self->{'outfilt'}->deflate($str);
    $result .= $self->{'outfilt'}->flush() if $is_end;
    return $result;
}

sub infilt {
    my ($self, $dat, $last) = @_;

    my ($result, $status) = $self->{'infilt'}->inflate("$dat");

    if ($self->{'DecodeParms'} and $self->{'DecodeParms'}->{'Predictor'}) {
        my $predictor = $self->{'DecodeParms'}->{'Predictor'}->val();
        if ($predictor == 2) {
            die "The TIFF predictor logic has not been implemented";
        } elsif ($predictor >= 10 and $predictor <= 15) {
            $result = $self->_depredict_png($result);
        } else {
            die "Invalid predictor: $predictor";
        }
    }

    return $result;
}

sub _depredict_png {
    my ($self, $stream) = @_;
    my $param  = $self->{'DecodeParms'};

    my $prev = '';
    $stream = $self->{'_depredict_next'} . $stream if defined $self->{'_depredict_next'};
    $prev   = $self->{'_depredict_prev'}           if defined $self->{'_depredict_prev'};

    my $alpha   = $param->{'Alpha'}           ? $param->{'Alpha'}->val(): 0;
    my $bpc     = $param->{'BitsPerComponent'}? $param->{'BitsPerComponent'}->val(): 8;
    my $colors  = $param->{'Colors'}          ? $param->{'Colors'}->val(): 1;
    my $columns = $param->{'Columns'}         ? $param->{'Columns'}->val(): 1;
    my $height  = $param->{'Height'}          ? $param->{'Height'}->val(): 0;

    my $comp     = $colors + $alpha;
    my $bpp      = ceil($bpc * $comp / 8);
    my $scanline = 1 + ceil($bpp * $columns);

    my $clearstream = '';
    my $lastrow = ($height || int(length($stream) / $scanline)) - 1;
    foreach my $n (0 .. $lastrow) {
        my $line = substr($stream, $n * $scanline, $scanline);
        my $filter = vec($line, 0, 8);
        my $clear = '';
        $line = substr($line, 1);
        if      ($filter == 0) {
            $clear = $line;
        } elsif ($filter == 1) {
            foreach my $x (0 .. length($line) - 1) {
                vec($clear, $x, 8) = (vec($line, $x, 8) + vec($clear, $x - $bpp, 8)) % 256;
            }
        } elsif ($filter == 2) {
            foreach my $x (0 .. length($line) - 1) {
                vec($clear, $x, 8) = (vec($line, $x, 8) + vec($prev, $x, 8)) % 256;
            }
        } elsif ($filter == 3) {
            foreach my $x (0 .. length($line) - 1) {
                vec($clear, $x, 8) = (vec($line, $x, 8) + floor((vec($clear, $x - $bpp, 8) + vec($prev, $x, 8)) / 2)) % 256;
            }
        } elsif ($filter == 4) {
            foreach my $x (0 .. length($line) - 1) {
                vec($clear, $x, 8) = (vec($line, $x, 8) + _paeth_predictor(vec($clear, $x - $bpp, 8), vec($prev, $x, 8), vec($prev, $x - $bpp, 8))) % 256;
            }
        } else {
            die "Unexpected depredictor algorithm $filter requested on line $n (valid options are 0-4)";
        }
        $prev = $clear;
        foreach my $x (0 .. ($columns * $comp) - 1) {
            vec($clearstream, ($n * $columns * $comp) + $x, $bpc) = vec($clear, $x, $bpc);
        }
    }
    $self->{'_depredict_next'} = substr($stream, ($lastrow + 1) * $scanline);
    $self->{'_depredict_prev'} = $prev;

    return $clearstream;
}

sub _paeth_predictor {
    my ($a, $b, $c) = @_;

    my $p = $a + $b - $c;
    my $pa = abs($p - $a);
    my $pb = abs($p - $b);
    my $pc = abs($p - $c);
    if      ($pa <= $pb && $pa <= $pc) {
        return $a;
    } elsif ($pb <= $pc) {
        return $b;
    } else {
        return $c;
    }
}

1;