File Coverage

blib/lib/Image/PNG/Write/BW.pm

Criterion	Covered	Total	%
statement	77	77	100.0
branch	26	52	50.0
condition			n/a
subroutine	12	12	100.0
pod	4	4	100.0
total	119	145	82.0

package Image::PNG::Write::BW;

use v5.10;
use strict;
use warnings FATAL => 'all';

use Digest::CRC;
use Compress::Raw::Zlib;

use base 'Exporter';

our @EXPORT_OK = qw(
  make_png_string
  make_png_bitstream_array
  make_png_bitstream_packed
  make_png_bitstream_raw
);
our %EXPORT_TAGS = ( all => \@EXPORT_OK );

# ABSTRACT: Create minimal black-and-white PNG files.
our $VERSION = '0.01';


sub make_png_string($) {
    my ( $data ) = @_;

    die "cannot make 0-height png" if @$data == 0;

    my $deflate = Compress::Raw::Zlib::Deflate->new( -AppendOutput => 1 ) or die "failed to create Deflate module";
    my $out;

    my $width = undef;

    foreach my $line ( @$data ) {
      my $lineCp = $line; # We actually need a copy;
      if ( ! defined $width ) {
        $width = length( $lineCp );
        die "cannot make 0-width png" if $width == 0;
      }
      die "all lines must have same width" if $width != length( $lineCp );

      $lineCp =~ s/\S/0/g;
      $lineCp =~ s/\s/1/g;

      $deflate->deflate( pack("xB*",$lineCp) , $out ) == Z_OK or die "failed to deflate";
    }
    $deflate->flush( $out, Z_FINISH ) == Z_OK or die "failed to finish";

    return _make_png_raw_idat( $out, $width, scalar( @$data ) );
}



sub make_png_bitstream_array($$) {
    my ( $data, $width ) = @_;

    die "cannot make 0-height png" if @$data == 0;
    die "cannot make 0-width png" if $width <= 0;

    my $width_bytes = int( ( $width + 7 ) / 8 );

    my $deflate = Compress::Raw::Zlib::Deflate->new( -AppendOutput => 1 ) or die "failed to create Deflate module";
    my $out;

    my $cBuf = "\0" . "\0" x $width_bytes;

    for ( my $i = 0; $i < @$data; ++$i ) {
        die "data has wrong number of bytes on row $i" unless $width_bytes == length( $data->[$i] );

        substr( $cBuf, 1, $width_bytes ) = $data->[$i];
        $deflate->deflate( $cBuf, $out ) == Z_OK or die "failed to deflate";
    }

    $deflate->flush( $out, Z_FINISH ) == Z_OK or die "failed to finish";

    return _make_png_raw_idat( $out, $width, scalar( @$data ) );
}


sub make_png_bitstream_packed($$$) {
    my ( $data, $width, $height ) = ( \$_[0], $_[1], $_[2] );

    die "cannot make 0-height png" if $height <= 0;
    die "cannot make 0-width png"  if $width <= 0;

    my $width_bytes = int( ( $width + 7 ) / 8 );
    die "data has wrong number of bytes" unless $width_bytes*$height == length($$data);

    my $deflate = Compress::Raw::Zlib::Deflate->new( -AppendOutput => 1 ) or die "failed to create Deflate module";
    my $out;

    my $cBuf = "\0" . "\0" x $width_bytes;

    for ( my $i = 0; $i < $height; ++$i ) {
        substr( $cBuf, 1, $width_bytes ) = substr( $$data, $width_bytes * $i, $width_bytes );
        $deflate->deflate( $cBuf, $out ) == Z_OK or die "failed to deflate";
    }

    $deflate->flush( $out, Z_FINISH ) == Z_OK or die "failed to finish";

    return _make_png_raw_idat( $out, $width, $height );
}


sub make_png_bitstream_raw($$$) {
    my ( $data, $width, $height ) = ( \$_[0], $_[1], $_[2] );

    die "cannot make 0-height png" if $height <= 0;
    die "cannot make 0-width png"  if $width <= 0;

    my $width_bytes = int( ( $width + 7 ) / 8 ) + 1;
    die "data has wrong number of bytes" unless $width_bytes*$height == length($$data);

    my $deflate = Compress::Raw::Zlib::Deflate->new( -AppendOutput => 1 ) or die "failed to create Deflate module";
    my $out;

    if ( length($$data) ) {
        $deflate->deflate( $$data, $out ) == Z_OK or die "failed to deflate";
    }
    $deflate->flush( $out, Z_FINISH ) == Z_OK or die "failed to finish";

    return _make_png_raw_idat( $out, $width, $height );
}


# Internal method to make a PNG file from all parts ( including raw IDAT content )

my $PNG_SIGNATURE = pack("C8",137,80,78,71,13,10,26,10);
my $PNG_IEND      = _make_png_chunk( "IEND", "" );
sub _make_png_raw_idat($$$) {
    my ( $data, $width, $height ) = ( \$_[0], $_[1], $_[2] );

    return join("", $PNG_SIGNATURE,
        _make_png_chunk( "IHDR", pack("NNCCCCC",$width,$height,1,0,0,0,0) ),
        _make_png_chunk( "IDAT", $$data ),
        $PNG_IEND);
}

# Internal method to make a PNG chunk

sub _make_png_chunk {
    my ($type,$data) = ( $_[0], \$_[1] );

    my $ctx = Digest::CRC->new(type => "crc32");
    $ctx->add( $type );
    $ctx->add( $$data );

    return join("", pack("N",length($$data)), $type, $$data, pack("N",$ctx->digest) );
}


1; # End of Image::PNG::Write::BW

__END__