File Coverage

blib/lib/PDF/Builder/Resource/XObject/Image/PNM.pm

Criterion	Covered	Total	%
statement	145	341	42.5
branch	48	156	30.7
condition	8	45	17.7
subroutine	12	12	100.0
pod	1	5	20.0
total	214	559	38.2

package PDF::Builder::Resource::XObject::Image::PNM;

# For spec details, see man pages pam(5), pbm(5), pgm(5), pnm(5),  ppm(5)

use base 'PDF::Builder::Resource::XObject::Image';

use strict;
use warnings;

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

use IO::File;
use PDF::Builder::Util;
use PDF::Builder::Basic::PDF::Utils;
use Scalar::Util qw(weaken);

# massively rewritten recently, so assuming nothing in PDF::API2 rewrite (2021)
# should make any functional difference

=head1 NAME

PDF::Builder::Resource::XObject::Image::PNM - support routines for PNM (Portable aNy Map) image library. Inherits from L

=head2 METHODS

=over

=item $res = PDF::Builder::Resource::XObject::Image::PNM->new($pdf, $file, %opts)

Options:

=over

=item 'name' => 'string'

This is the name you can give for the PNM image object. The default is Nxnnnn.

=item 'compress' => 1

This is the compression you can give for the PNM image object. Any value will
cause the use of I compression, otherwise (C not given),
I is used.

=back

=back

Returns an image in the PDF. PNM types 1 (ASCII/plain bi-level/PBM),
2 (ASCII/plain grayscale/PGM), 3 (ASCII/plain RGB/PPM),
4 (binary/raw bi-level/PBM), 5 (binary/raw grayscale/PGM), and
6 (binary/raw RGB/PPM) are supported.

For bi-level, only values 0/1 (white/black) are supported. For grayscale, the
maximum sample (full white) may be anything from 1 to 65535, with 0 being full
black. If the maximum sample value is 255 or smaller, one byte of raw binary
data per pixel, otherwise two bytes. For RGB, each sample (full-on of that
color) may be anything from 1 to 65535 (the same maximum for all three colors),
with 0 being full black. If the maximum sample value is 255 or smaller, three
bytes of raw binary data per pixel, otherwise six bytes.

=cut

# -------------------------------------------------------------------
sub new {
    my ($class, $pdf, $file, %opts) = @_;
    # copy dashed option names to preferred undashed names
    if (defined $opts{'-name'} && !defined $opts{'name'}) { $opts{'name'} = delete($opts{'-name'}); }
    if (defined $opts{'-compress'} && !defined $opts{'compress'}) { $opts{'compress'} = delete($opts{'-compress'}); }

    my ($name, $compress);
    if (exists $opts{'name'}) { $name = $opts{'name'}; }
    if (exists $opts{'compress'}) { $compress = $opts{'compress'}; }

    my $self;

    $class = ref($class) if ref($class);

    $self = $class->SUPER::new($pdf, $name || 'Nx'.pdfkey());
    $pdf->new_obj($self) unless $self->is_obj($pdf);

    $self->{' apipdf'} = $pdf;
    weaken $self->{' apipdf'};

    $self->read_pnm($pdf, $file);

    if (defined $compress) {
	$self->filters('FlateDecode');
    } else {
	$self->filters('ASCIIHexDecode');
    }

    return $self;
}

# -------------------------------------------------------------------
# READPPMHEADER
# taken from Image::PBMLib
# Copyright by Benjamin Elijah Griffin (28 Feb 2003)
# extensively modified by Phil M Perry, copyright 2020
#
sub readppmheader {
    # renamed to _read_header() in PDF::API2
    my ($gr, $buffer) = @_; # already-opened input file's filehandle
    my %info;
    $info{'error'} = undef;
    my ($width, $height, $max, $comment, $content);

    # extension: allow whitespace BEFORE the magic number (usually none)
    # read Px magic number
    ($buffer, $comment) = eat_whitespace($gr, $buffer, 0);
    ($buffer, $content) = read_content($gr, $buffer);

    if (length($content) != 2) {
        $info{'error'} = 'Read error or EOF';
        return (\%info, $buffer);
    }

    if ($content =~ /^P([1-6])/) {
        $info{'type'} = $1;
        if ($info{'type'} > 3) {
            $info{'raw'} = 1;  # P4-6 is raw (binary)
        } else {
            $info{'raw'} = 0;  # P1-3 is plain (ASCII)
        }
    } else {
        $info{'error'} = 'Unrecognized magic number, not 1..6';
        return (\%info, $buffer);
    }

    if ($info{'type'} == 1 or $info{'type'} == 4) {
        $max = 1;
        $info{'bgp'} = 'b';
    } elsif ($info{'type'} == 2 or $info{'type'} == 5) {
        # need to read and validate 'max'
        $info{'bgp'} = 'g';
    } else {  # 3 or 6
        # need to read and validate 'max'
        $info{'bgp'} = 'p';
    }

    # expect width as unsigned integer > 0
    ($buffer, $comment) = eat_whitespace($gr, $buffer, 0);
    ($buffer, $content) = read_content($gr, $buffer);
    if (length($content) == 0) {
        $info{'error'} = 'Read error or EOF on width';
        return (\%info, $buffer);
    }
    if ($content =~ m/(^\d+)$/) {
	$width = $1;
    } else {
        $info{'error'} = 'Invalid width value '.$1;
        return (\%info, $buffer);
    }
    if ($width < 1) {
        $info{'error'} = 'Invalid width value '.$width;
        return (\%info, $buffer);
    }

    # expect height as unsigned integer > 0
    ($buffer, $comment) = eat_whitespace($gr, $buffer, 0);
    ($buffer, $content) = read_content($gr, $buffer);
    if (length($content) == 0) {
        $info{'error'} = 'Read error or EOF on height';
        return (\%info, $buffer);
    }
    if ($content =~ m/(^\d+)$/) {
	$height = $1;
    } else {
        $info{'error'} = 'Invalid height value '.$1;
        return (\%info, $buffer);
    }
    if ($height < 1) {
        $info{'error'} = 'Invalid height value '.$height;
        return (\%info, $buffer);
    }

    # expect max sample value as unsigned integer > 0 & < 65536
    # IF grayscale or pixmap (RGB). already set to 1 for bi-level
    if ($info{'bgp'} =~ m/^[gp]$/) {
        ($buffer, $comment) = eat_whitespace($gr, $buffer, 0);
        ($buffer, $content) = read_content($gr, $buffer);
        if (length($content) == 0) {
            $info{'error'} = 'Read error or EOF on max';
            return (\%info, $buffer);
        }
        if ($content =~ m/(^\d+)$/) {
	    $max = $1;
        } else {
            $info{'error'} = 'Invalid max value '.$1;
            return (\%info, $buffer);
        }
        if ($max < 1 || $max > 65535) {
            $info{'error'} = 'Invalid max value '.$max;
            return (\%info, $buffer);
        }
    }

    $info{'width'}  = $width;
    $info{'height'} = $height;
    $info{'max'}    = $max;

    # for binary (raw) files, a single whitespace character should be seen.
    # for ASCII (plain) files, extend to allow arbitrary whitespace
    if ($info{'raw'}) {
	# The buffer should have a single ws char in it already, left over from
	# the previous content read. We don't want to read anything beyond that
	# in case a byte value happens to be a valid whitespace character! If
	# the file format is botched and there is additional whitespace, it
	# will unfortunately be read as binary data.
	if ($buffer =~ m/^\s/) {
	    $buffer = substr($buffer, 1); # discard first character
	} else {
	    $info{'error'} = 'Expected single whitespace before raster data';
            return (\%info, $buffer);
	}
    } else {
	# As an extension, for plain (ASCII) format we allow arbitrary
	# whitespace (including comments) after the max value and before the
	# raster data, not just one whitespace.
        ($buffer, $comment) = eat_whitespace($gr, $buffer, 0);
    }

    return (\%info, $buffer);
} # end of readppmheader()

# -------------------------------------------------------------------
# eat and discard whitespace stream, but return any comment(s) found
# within the header, cannot have an EOF during whitespace read
sub eat_whitespace {
    my ($gr, $buffer, $qflag) = @_;
    # qflag = 0 if OK to read more from file (don't expect an EOF)
    #       = 1 eating ws at end of image, might hit EOF here

    my ($count, $buf, @comment);
    # first see if enough material is already in the buffer. if not, read some
    my $in_comment = 0; # not currently processing a comment, just ws.
    while (1) {
	# is buffer empty? if so, read some content
	if (length($buffer) == 0) {
	    $count = read($gr, $buffer, 50); # chunk of up to 50 bytes (could be 0)
	    if ($count == 0 && (!$qflag || $in_comment)) {
		# EOF or read error, is bad thing here
		print STDERR "EOF or read error reading whitespace.\n";
		return ($buffer, '');
	    }
	}
	# if buffer is still empty (qflag == 1), will exit cleanly

	if (!$in_comment) { $buffer =~ s/^\s+//; }
	# a bunch of whitespace may have been discarded. if buffer now starts
	# with a #, it is a comment to be read to EOL. otherwise we're done.
	if (length($buffer) > 0) {
	    # buffer still has stuff in it (starts with non-ws)
	    if ($buffer =~ m/^#/) {
		$in_comment = 1;
		# at start of comment. discard up through \n
		# (\n might not yet be in buffer!)
		# special case: #\n
		if      ($buffer =~ s/^#\n//) {
                    # special empty case
                    $in_comment = 0;
		} elsif ($buffer =~ s/^#\s*([^\n]*)\n//) {
		    push @comment, $1; # has been removed from buffer
		    $in_comment = 0;
                } else {
		    # haven't gotten to end of comment (\n) yet
		    $count = read($gr, $buf, 50);
		    if ($count == 0) {
			# EOF or read error, is bad thing here
		        print STDERR "EOF or read error reading whitespace in pixel data\n";
		        return ($buffer, '');
		    }
                    $buffer .= $buf;
		    next;
                }
	    } else {
	        # non-whitespace, not #. content to be left in buffer
		$in_comment = 0;
		last;
	    }
	} else {
	    # empty buffer, need to read some more
	    if ($qflag && !$in_comment) { last; }
	    next;
	}
    } # while(1) until run out of whitespace

    my $comments = '';
    if (scalar(@comment) > 0) { $comments = join("\n", @comment); }
    return ($buffer, $comments);
} # end of eat_whitespace()

# -------------------------------------------------------------------
# eat a non-whitespace stream, returning the content up until whitespace
# should not see an EOF during this (at least one ws after this stream)
sub read_content {
    my ($gr, $buffer) = @_;

    my ($count, $content);
    $content = '';
    # first see if enough material is already in the buffer. if not, read some
    while (1) {
	# is buffer empty? if so, read some content
	if (length($buffer) == 0) {
	    $count = read($gr, $buffer, 50); # chunk of up to 50 bytes (could be 0)
	    if ($count == 0) {
		# EOF or read error, is bad thing here
		print STDERR "EOF or read error reading content in pixel data\n";
		return ($buffer, '');
	    }
	}

	# should always be non-ws content here
	$buffer =~ s/^([^\s]+)//;
	$content .= $1;  # has been removed from buffer (now possibly empty)
	# if buffer now empty (didn't see ws char), need to read more
	if (length($buffer) == 0) { next; }
	last;  # non-empty buffer means it starts with a ws char

	# this function is used for header fields and non-raw pixel data, so
	# we don't expect to have an EOF immediately after a data item (must
	# be a \n after it at the last data item).

    } # while(1) until run out of non-whitespace

    return ($buffer, $content);
} # end of read_content()

# -------------------------------------------------------------------
sub read_pnm {
    my $self = shift;
    my $pdf = shift;
    my $file = shift;

    my ($rc, $buf, $buf2, $s, $pix, $max);
    # $s is a scale factor for sample not full 8 or 16 bits.
    # it should scale the input to 0..255 or 0..65535, so final value
    # will be a full 8 or 16 bits per channel (bpc)
    my ($w,$h, $bpc, $cs, $img, @img) = (0,0, '', '', '');
    my ($info, $buffer, $content, $comment, $sample, $gr);
    my $inf;
    if (ref($file)) {
        $inf = $file;
    } else {
        open $inf, "<", $file or die "$!: $file";
    }
    binmode($inf,':raw');
    $inf->seek(0, 0);
    $buffer = ''; # initialize
    ($info, $buffer) = readppmheader($inf, $buffer);
    # info (hashref) fields:
    #   error     undef or an error description
    #   type      magic number 1-6
    #   raw       0 if plain/ASCII, 1 if raw/binary
    #   bgp       b=bi-level (1,4) g=grayscale (2,5), p=pixmap/RGB (3,6)
    #   width     width (row length/horizontal) in pixels
    #   height    height (row count/vertical) in pixels
    #   max       sample max value 1 for bi-level, 1-65535 for grayscale/RGB
    #   comments  comment line(s), if any (else '')
    if (defined $info->{'error'}) {
	print STDERR "Error reported during PNM file header read:\n".($info->{'error'}).".\n";
	return $self;
    }

    $w   = $info->{'width'};
    $h   = $info->{'height'};
    $max = $info->{'max'};

    my $bytes_per_sample = 1;
    if ($max > 255) { $bytes_per_sample = 2; }

    # ------------------------------
    if      ($info->{'type'} == 1) {
	# plain (ASCII) PBM bi-level, each pixel 0..1, ws between is optional

        $bpc = 1;  # one bit per channel/sample/pixel
	# pack 8 pixels (possibly with don't-care at end of row) to a byte
	my ($row, $col, $bits); # need to handle rows separately for d/c bits
	my $qflag;
	$content = '';
        for ($row = 0; $row < $h; $row++) {
	    $bits = '';
            for ($col = 0; $col < $w; $col++) {
	        # could be a single 0 or 1, or a whole bunch lumped together
		# in one or more groups
		# buffer has 0 or more entries. handle just one in this loop,
		# reading in new buffer if necessary
		if (length($content) == 0) {
                    $qflag = 0;
		    if ($row == $h-1 && $col == $w-1) { $qflag = 1; }
		    ($buffer, $comment) = eat_whitespace($inf, $buffer, $qflag);
		    ($buffer, $content) = read_content($inf, $buffer);
		    if (length($content) == 0) {
			print STDERR "Unexpected EOF or read error reading pixel data.\n";
			return $self;
		    }
		}
		$sample = substr($content, 0, 1);
		$content = substr($content, 1);
		if ($sample ne '0' && $sample ne '1') {
		    print STDERR "Invalid bit value '$sample' in pixel data.\n";
		    return $self;
		}
		$bits .= $sample;
		if (length($bits) == 8) {
		    $self->{' stream'} .= pack('B8', $bits);
		    $bits = '';
		}

            } # end of cols in row. partial $bits to finish?
	    if ($bits ne '') {
	        while (length($bits) < 8) {
	            $bits .= '0'; # don't care, but must be 0 or 1
		}
		$self->{' stream'} .= pack('B8', $bits);
	    }
        } # end of rows

        $cs = 'DeviceGray';  # at 1 bit per pixel
        $self->{'Decode'} = PDFArray(PDFNum(1), PDFNum(0));

    # ------------------------------
    } elsif ($info->{'type'} == 2) {
	# plain (ASCII) PGM grayscale, each pixel 0..max (1 or 2 bytes)

	# get scale factor $s to fully fill 8 or 16 bit sample (channel)
        if      ($max == 255 || $max == 65535) {
            $s = 0;  # flag: no scaling
        } elsif ($max > 255) {
            $s = 65535/$max;
        } else {
            $s = 255/$max;
        }
        $bpc = 8 * $bytes_per_sample;
	my $format = 'C';
	if ($bytes_per_sample == 2) { $format = 'S>'; }
	my $sample;

        for ($pix=($w*$h); $pix>0; $pix--) {
            ($buffer, $content) = read_content($inf, $buffer);
	    if (length($content) == 0) {
	        print STDERR "Unexpected EOF or read error reading pixel data.\n";
	        return $self;
	    }
            ($buffer, $comment) = eat_whitespace($inf, $buffer, $pix==1);

	    if ($content =~ m/^\d+$/) {
		if ($content > $max) {
		    print STDERR "Pixel data entry '$content' higher than $max. Value changed to $max.\n";
		    $content = $max;
		}
	    } else {
		print STDERR "Invalid pixel data entry '$content'.\n";
		return $self;
	    }
	    $sample = $content;

            if ($s > 0) {
                # scaling needed
	        $sample = int($sample*$s + 0.5); # must not exceed 255/65535
            }
            $self->{' stream'} .= pack($format, $sample);
	} # loop through all pixels
        $cs = 'DeviceGray';

    # ------------------------------
    } elsif ($info->{'type'} == 3) {
	# plain (ASCII) PPM rgb, each pixel 0..max for R, G, B (1 or 2 bytes)

	# get scale factor $s to fully fill 8 or 16 bit sample (channel)
        if      ($max == 255 || $max == 65535) {
            $s = 0;  # flag: no scaling
        } elsif ($max > 255) {
            $s = 65535/$max;
        } else {
            $s = 255/$max;
        }
        $bpc = 8 * $bytes_per_sample;
	my $format = 'C';
	if ($bytes_per_sample == 2) { $format = 'S>'; }
	my ($sample, $rgb);

        for ($pix=($w*$h); $pix>0; $pix--) {
	    for ($rgb = 0; $rgb < 3; $rgb++) { # R, G, and B values
                ($buffer, $comment) = eat_whitespace($inf, $buffer, $pix==1);
                ($buffer, $content) = read_content($inf, $buffer);
	        if (length($content) == 0) {
	            print STDERR "Unexpected EOF or read error reading pixel data.\n";
	            return $self;
	        }

	        if ($content =~ m/^\d+$/) {
		    if ($content > $max) {
			# remember, $pix counts DOWN from w x h
		        print STDERR "Pixel $pix data entry '$content' higher than $max. Value changed to $max.\n";
		        $content = $max;
		    }
	        } else {
	  	    print STDERR "Invalid pixel data entry '$content'.\n";
	  	    return $self;
	        }
		$sample = $content;

                if ($s > 0) {
                    # scaling needed
	            $sample = int($sample*$s + 0.5); # must not exceed 255/65535
                }
                $self->{' stream'} .= pack($format, $sample);
	    } # R G B loop
	} # loop through all pixels
        $cs = 'DeviceRGB';

    # ------------------------------
    } elsif ($info->{'type'} == 4) {
	# raw (binary) PBM bi-level, each pixel 0..1, row packed 8 pixel/byte
        $bpc = 1;  # one bit per channel/sample/pixel
	# round up for don't care bits at end of row
        my $bytes = int(($w+7)/8) * $h;
	$bytes -= length($buffer);  # some already read from file!
        $rc = read($inf, $buf2, $bytes);
	if ($rc != $bytes) {
	    print STDERR "Unexpected EOF or read error while reading PNM binary pixel data.\n";
	    return $self;
	}
	$self->{' stream'} = $buffer.$buf2;
        $cs = 'DeviceGray';  # at 1 bit per pixel
        $self->{'Decode'} = PDFArray(PDFNum(1), PDFNum(0));

    # ------------------------------
    } elsif ($info->{'type'} == 5) {
	# raw (binary) PGM grayscale, each pixel 0..max (1 or 2 bytes)

	# get scale factor $s to fully fill 8 or 16 bit sample (channel)
        if      ($max == 255 || $max == 65535) {
            $s = 0;  # flag: no scaling
        } elsif ($max > 255) {
            $s = 65535/$max;
        } else {
            $s = 255/$max;
        }
        $bpc = 8 * $bytes_per_sample;
	my $format = 'C';
	if ($bytes_per_sample == 2) { $format = 'S>'; }
	my ($buf, $sample);

        my $bytes = $w * $h * $bytes_per_sample;
	$bytes -= length($buffer);  # some already read from file!
        $rc = read($inf, $buf, $bytes);
	if ($rc != $bytes) {
	    print STDERR "Unexpected EOF or read error reading pixel data.\n";
	    return $self;
	}
	$buf = $buffer . $buf;
        if ($s > 0) {
            # scaling needed
            for ($pix=($w*$h); $pix>0; $pix--) {
		$buf2 = substr($buf, 0, $bytes_per_sample);
		$buf  = substr($buf, $bytes_per_sample);
		$sample = unpack($format, $buf2);
	        $sample = int($sample*$s + 0.5); # must not exceed 255/65535
                $self->{' stream'} .= pack($format, $sample);
            }
        } else {
	    # no scaling needed
	    $self->{' stream'} = $buf;
        }
        $cs = 'DeviceGray';

    # ------------------------------
    } elsif ($info->{'type'} == 6) {
	# raw (binary) PPM rgb, each pixel 0..max for R, G, B (3 or 6 bytes)

	# get scale factor $s to fully fill 8 or 16 bit sample (channel)
        if      ($max == 255 || $max == 65535) {
            $s = 0;  # flag: no scaling
        } elsif ($max > 255) {
            $s = 65535/$max;
        } else {
            $s = 255/$max;
        }
        $bpc = 8 * $bytes_per_sample;
	my $format = 'C';
	if ($bytes_per_sample == 2) { $format = 'S>'; }
	my ($buf, $sample);

        my $bytes = $w * $h * $bytes_per_sample * 3;
	$bytes -= length($buffer);  # some already read from file!
        $rc = read($inf, $buf, $bytes);
	if ($rc != $bytes) {
	    print STDERR "Unexpected EOF or read error reading pixel data.\n";
	    return $self;
	}
	$buf = $buffer . $buf;
        if ($s > 0) {
            # scaling needed
            for ($pix=($w*$h); $pix>0; $pix--) {
		# Red
		$buf2 = substr($buf, 0, $bytes_per_sample);
		$sample = unpack($format, $buf2);
	        $sample = int($sample*$s + 0.5); # must not exceed 255/65535
                $self->{' stream'} .= pack($format, $sample);
		# Green
		$buf2 = substr($buf, $bytes_per_sample, $bytes_per_sample);
		$sample = unpack($format, $buf2);
	        $sample = int($sample*$s + 0.5); # must not exceed 255/65535
                $self->{' stream'} .= pack($format, $sample);
		# Blue
		$buf2 = substr($buf, 2*$bytes_per_sample, $bytes_per_sample);
		$sample = unpack($format, $buf2);
	        $sample = int($sample*$s + 0.5); # must not exceed 255/65535
                $self->{' stream'} .= pack($format, $sample);

		$buf  = substr($buf, $bytes_per_sample*3);
            }
        } else {
	    # no scaling needed
	    $self->{' stream'} = $buf;
        }
        $cs = 'DeviceRGB';
    }
    close($inf);

    $self->width($w);
    $self->height($h);

    $self->bits_per_component($bpc);

    $self->filters('FlateDecode');

    $self->colorspace($cs);

    return $self;
} # end of read_pnm()

1;