File Coverage

blib/lib/Data/ParseBinary/Graphics/PNG.pm

Criterion	Covered	Total	%
statement	15	20	75.0
branch	0	2	0.0
condition	1	2	50.0
subroutine	5	6	83.3
pod	0	2	0.0
total	21	32	65.6

package Data::ParseBinary::Graphics::PNG;
use strict;
use warnings;
use Data::ParseBinary;
use Data::ParseBinary qw{GreedyRange};

# Portable Network Graphics (PNG) file format
# Official spec: http://www.w3.org/TR/PNG
#
# Original code contributed by Robin Munn (rmunn at pobox dot com)
# (although the code has been extensively reorganized to meet Construct's
# coding conventions)


#===============================================================================
# utils
#===============================================================================
sub Coord {
    my ($name, $field) = @_;
    $field ||= \&UBInt8;
    return Struct($name,
        &$field("x"),
        &$field("y"),
    );
}

my $compression_method = Enum(UBInt8("compression_method"),
    deflate => 0,
    _default_ => $DefaultPass
);


#===============================================================================
# 11.2.3: PLTE - Palette
#===============================================================================
my $plte_info = Struct("plte_info",
    Value("num_entries", sub { $_->ctx(1)->{length} / 3}),
    Array(sub { $_->ctx->{num_entries} },
        Struct("palette_entries",
            UBInt8("red"),
            UBInt8("green"),
            UBInt8("blue"),
        ),
    ),
);

#===============================================================================
# 11.2.4: IDAT - Image data
#===============================================================================
#my $idat_info = OnDemand(
#    Field("idat_info", sub { $_->ctx->{length} }),
#);
my $idat_info = Field("idat_info", sub { $_->ctx->{length} });

#===============================================================================
# 11.3.2.1: tRNS - Transparency
#===============================================================================
my $trns_info = Switch("trns_info", sub { $_->ctx(1)->{image_header}->{color_type} },
    {
        "greyscale" => Struct("data",
            UBInt16("grey_sample")
        ),
        "truecolor" => Struct("data",
            UBInt16("red_sample"),
            UBInt16("blue_sample"),
            UBInt16("green_sample"),
        ),
        "indexed" => Array(sub { $_->ctx->{length} },
            UBInt8("alpha"),
        ),
    }
);

#===============================================================================
# 11.3.3.1: cHRM - Primary chromacities and white point
#===============================================================================
my $chrm_info = Struct("chrm_info",
    Coord("white_point", \&UBInt32),
    Coord("red", \&UBInt32),
    Coord("green", \&UBInt32),
    Coord("blue", \&UBInt32),
);

#===============================================================================
# 11.3.3.2: gAMA - Image gamma
#===============================================================================
my $gama_info = Struct("gama_info",
    UBInt32("gamma"),
);

#===============================================================================
# 11.3.3.3: iCCP - Embedded ICC profile
#===============================================================================
my $iccp_info = Struct("iccp_info",
    CString("name"),
    $compression_method,
    Field("compressed_profile",
        sub { $_->ctx(1)->{length} - (length( $_->ctx->{name}) + 2) }
    ),
);

#===============================================================================
# 11.3.3.4: sBIT - Significant bits
#===============================================================================
my $sbit_info = Switch("sbit_info", sub { $_->ctx(1)->{image_header}->{color_type} },
    {
        "greyscale" => Struct("data",
            UBInt8("significant_grey_bits"),
        ),
        "truecolor" => Struct("data",
            UBInt8("significant_red_bits"),
            UBInt8("significant_green_bits"),
            UBInt8("significant_blue_bits"),
        ),
        "indexed" => Struct("data",
            UBInt8("significant_red_bits"),
            UBInt8("significant_green_bits"),
            UBInt8("significant_blue_bits"),
        ),
        "greywithalpha" => Struct("data",
            UBInt8("significant_grey_bits"),
            UBInt8("significant_alpha_bits"),
        ),
        "truewithalpha" => Struct("data",
            UBInt8("significant_red_bits"),
            UBInt8("significant_green_bits"),
            UBInt8("significant_blue_bits"),
            UBInt8("significant_alpha_bits"),
        ),
    }
);

#===============================================================================
# 11.3.3.5: sRGB - Standard RPG color space
#===============================================================================
my $srgb_info = Struct("srgb_info",
    Enum(UBInt8("rendering_intent"),
        perceptual => 0,
        relative_colorimetric => 1,
        saturation => 2,
        absolute_colorimetric => 3,
        _default_ => $DefaultPass,
    ),
);

#===============================================================================
# 11.3.4.3: tEXt - Textual data
#===============================================================================
my $text_info = Struct("text_info",
    CString("keyword"),
    Field("text", sub { $_->ctx(1)->{length} - (length($_->ctx->{keyword}) + 1) }),
);

#===============================================================================
# 11.3.4.4: zTXt - Compressed textual data
#===============================================================================
my $ztxt_info = Struct("ztxt_info",
    CString("keyword"),
    $compression_method,
#    OnDemand(
        Field("compressed_text",
            # As with iCCP, length is chunk length, minus length of
            # keyword, minus two: one byte for the null terminator,
            # and one byte for the compression method.
            sub { $_->ctx(1)->{length} - (length($_->ctx->{keyword}) + 2) },
        ),
#    ),
);

#===============================================================================
# 11.3.4.5: iTXt - International textual data
#===============================================================================
my $itxt_info = Struct("itxt_info",
    CString("keyword"),
    UBInt8("compression_flag"),
    $compression_method,
    CString("language_tag"),
    CString("translated_keyword"),
 #   OnDemand(
        Field("text",
            sub { $_->ctx(1)->{length} - (length($_->ctx->{keyword}) + length($_->ctx->{language_tag}) + length($_->ctx->{translated_keyword}) + 5) },
        ),
#    ),
);

#===============================================================================
# 11.3.5.1: bKGD - Background color
#===============================================================================
my $bkgd_info = Switch("bkgd_info", sub { $_->ctx(1)->{image_header}->{color_type} },
    {
        "greyscale" => Struct("data",
            UBInt16("background_greyscale_value"),
            Alias("grey", "background_greyscale_value"),
        ),
        "greywithalpha" => Struct("data",
            UBInt16("background_greyscale_value"),
            Alias("grey", "background_greyscale_value"),
        ),
        "truecolor" => Struct("data",
            UBInt16("background_red_value"),
            UBInt16("background_green_value"),
            UBInt16("background_blue_value"),
            Alias("red", "background_red_value"),
            Alias("green", "background_green_value"),
            Alias("blue", "background_blue_value"),
        ),
        "truewithalpha" => Struct("data",
            UBInt16("background_red_value"),
            UBInt16("background_green_value"),
            UBInt16("background_blue_value"),
            Alias("red", "background_red_value"),
            Alias("green", "background_green_value"),
            Alias("blue", "background_blue_value"),
        ),
        "indexed" => Struct("data",
            UBInt16("background_palette_index"),
            Alias("index", "background_palette_index"),
        ),
    }
);

#===============================================================================
# 11.3.5.2: hIST - Image histogram
#===============================================================================
my $hist_info = Array(sub { $_->ctx(1)->{length} / 2 },
    UBInt16("frequency"),
);

#===============================================================================
# 11.3.5.3: pHYs - Physical pixel dimensions
#===============================================================================
my $phys_info = Struct("phys_info",
    UBInt32("pixels_per_unit_x"),
    UBInt32("pixels_per_unit_y"),
    Enum(UBInt8("unit"),
        unknown => 0,
        meter => 1,
        _default_ => $DefaultPass,
    ),
);

#===============================================================================
# 11.3.5.4: sPLT - Suggested palette
#===============================================================================
sub splt_info_data_length {
    my $entry_size;
    if ($_->ctx->{sample_depth} == 8) {
        $entry_size = 6;
    } else {
        $entry_size = 10;
    }
    return ($_->ctx(1)->{length} - length($_->ctx->{name}) - 2) / $entry_size;
}

my $splt_info = Struct("data",
    CString("name"),
    UBInt8("sample_depth"),
    Array(\&splt_info_data_length,
        IfThenElse("table", sub { $_->ctx->{sample_depth} == 8 },
            # Sample depth 8
            Struct("table",
                UBInt8("red"),
                UBInt8("green"),
                UBInt8("blue"),
                UBInt8("alpha"),
                UBInt16("frequency"),
            ),
            # Sample depth 16
            Struct("table",
                UBInt16("red"),
                UBInt16("green"),
                UBInt16("blue"),
                UBInt16("alpha"),
                UBInt16("frequency"),
            ),
        ),
    ),
);

#===============================================================================
# 11.3.6.1: tIME - Image last-modification time
#===============================================================================
my $time_info = Struct("data",
    UBInt16("year"),
    UBInt8("month"),
    UBInt8("day"),
    UBInt8("hour"),
    UBInt8("minute"),
    UBInt8("second"),
);

#===============================================================================
# chunks
#===============================================================================
my $default_chunk_info =
#    OnDemand(HexDumpAdapter(
        Field(undef, sub {$_->ctx->{length} }
#    ))
);

my $chunk = Struct("chunk",
    UBInt32("length"),
    String("type", 4),
    Switch("data", sub { $_->ctx->{type} },
        {
            "PLTE" => $plte_info,
            "IEND" => $DefaultPass,
            "IDAT" => $idat_info,
            "tRNS" => $trns_info,
            "cHRM" => $chrm_info,
            "gAMA" => $gama_info,
            "iCCP" => $iccp_info,
            "sBIT" => $sbit_info,
            "sRGB" => $srgb_info,
            "tEXt" => $text_info,
            "zTXt" => $ztxt_info,
            "iTXt" => $itxt_info,
            "bKGD" => $bkgd_info,
            "hIST" => $hist_info,
            "pHYs" => $phys_info,
            "sPLT" => $splt_info,
            "tIME" => $time_info,
        },
        default => $default_chunk_info,
    ),
    UBInt32("crc"),
);

my $image_header_chunk = Struct("image_header",
    UBInt32("length"),
    Const(String("type", 4), "IHDR"),
    UBInt32("width"),
    UBInt32("height"),
    UBInt8("bit_depth"),
    Enum(UBInt8("color_type"),
        greyscale => 0,
        truecolor => 2,
        indexed => 3,
        greywithalpha => 4,
        truewithalpha => 6,
        _default_ => $DefaultPass,
    ),
    $compression_method,
    Enum(UBInt8("filter_method"),
        # "adaptive filtering with five basic filter types"
        adaptive5 => 0,
        _default_ => $DefaultPass,
    ),
    Enum(UBInt8("interlace_method"),
        none => 0,
        adam7 => 1,
        _default_ => $DefaultPass,
    ),
    UBInt32("crc"),
);


#===============================================================================
# the complete PNG file
#===============================================================================
our $png_parser = Struct("png",
    Magic("\x89PNG\r\n\x1a\n"),
    $image_header_chunk,
    GreedyRange($chunk),
);

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw($png_parser);

1;

__END__