File Coverage

blib/lib/PDF/API2/Resource/XObject/Image/PNM.pm
Criterion Covered Total %
statement 83 173 47.9
branch 26 88 29.5
condition 5 18 27.7
subroutine 10 10 100.0
pod 1 2 50.0
total 125 291 42.9


line stmt bran cond sub pod time code
1             package PDF::API2::Resource::XObject::Image::PNM;
2              
3             # For spec details, see man pages pam(5), pbm(5), pgm(5), pnm(5),
4             # ppm(5), which were pasted into the __END__ of this file in an
5             # earlier revision.
6              
7 2     2   1011 use base 'PDF::API2::Resource::XObject::Image';
  2         6  
  2         554  
8              
9 2     2   13 use strict;
  2         4  
  2         77  
10              
11             our $VERSION = '2.044'; # VERSION
12              
13 2     2   11 use Carp;
  2         4  
  2         107  
14 2     2   14 use IO::File;
  2         4  
  2         305  
15 2     2   13 use PDF::API2::Util;
  2         5  
  2         316  
16 2     2   17 use PDF::API2::Basic::PDF::Utils;
  2         4  
  2         172  
17 2     2   13 use Scalar::Util qw(weaken);
  2         4  
  2         3454  
18              
19             sub new {
20 3     3 1 9 my ($class, $pdf, $file, %opts) = @_;
21 3         5 my $self;
22              
23 3 50       9 $class = ref($class) if ref($class);
24              
25 3         9 $self = $class->SUPER::new($pdf, 'Nx' . pdfkey());
26 3 50       9 $pdf->new_obj($self) unless $self->is_obj($pdf);
27              
28 3         10 $self->read_pnm($pdf, $file);
29              
30 2 100       6 if ($opts{'-compress'}) {
31 1         3 $self->filters('FlateDecode');
32             }
33             else {
34 1         21 $self->filters('ASCIIHexDecode');
35             }
36              
37 2         7 return $self;
38             }
39              
40             # Originally from Image::PBMLib by Elijah Griffin (28 Feb 2003)
41             sub _read_header {
42 2     2   5 my $fh = shift();
43 2         8 my $in;
44             my $no_comments;
45 2         0 my %info;
46 2         0 my $rc;
47 2         5 $info{'error'} = undef;
48              
49 2         64 $rc = read($fh, $in, 3);
50              
51 2 50 33     14 if (!defined($rc) or $rc != 3) {
52 0         0 $info{'error'} = 'Read error or EOF';
53 0         0 return \%info;
54             }
55              
56 2 50       12 unless ($in =~ /^P([123456])\s/) {
57 0         0 $info{'error'} = 'Wrong magic number';
58 0         0 return \%info;
59             }
60              
61 2         11 $info{'type'} = $1;
62 2 50       5 if ($info{'type'} > 3) {
63 2         5 $info{'raw'} = 1;
64             }
65             else {
66 0         0 $info{'raw'} = 0;
67             }
68              
69 2 50 33     14 if ($info{'type'} == 1 or $info{'type'} == 4) {
    50 33        
70 0         0 $info{'max'} = 1;
71 0         0 $info{'bgp'} = 'b';
72             }
73             elsif ($info{'type'} == 2 or $info{'type'} == 5) {
74 0         0 $info{'bgp'} = 'g';
75             }
76             else {
77 2         4 $info{'bgp'} = 'p';
78             }
79              
80 2         3 while (1) {
81 16         31 $rc = read($fh, $in, 1, length($in));
82 16 50 33     46 if (!defined($rc) or $rc != 1) {
83 0         0 $info{'error'} = 'Read error or EOF';
84 0         0 return \%info;
85             }
86              
87 16         25 $no_comments = $in;
88 16         26 $info{'comments'} = '';
89 16         35 while ($no_comments =~ /#.*\n/) {
90 0         0 $no_comments =~ s/#(.*\n)/ /;
91 0         0 $info{'comments'} .= $1;
92             }
93              
94 16 50       29 if ($info{'bgp'} eq 'b') {
95 0 0       0 if ($no_comments =~ /^P\d\s+(\d+)\s+(\d+)\s/) {
96 0         0 $info{'width'} = $1;
97 0         0 $info{'height'} = $2;
98 0         0 last;
99             }
100             }
101             else {
102 16 100       41 if ($no_comments =~ /^P\d\s+(\d+)\s+(\d+)\s+(\d+)\s/) {
103 2         8 $info{'width'} = $1;
104 2         6 $info{'height'} = $2;
105 2         7 $info{'max'} = $3;
106 2         4 last;
107             }
108             }
109             } # while reading header
110              
111 2         4 $info{'fullheader'} = $in;
112              
113 2         6 return \%info;
114             }
115              
116             sub read_pnm {
117 3     3 0 6 my ($self, $pdf, $file) = @_;
118              
119 3         22 my ($buf, $t, $scale, $line);
120 3         0 my $bpc;
121 3         0 my $cs;
122              
123 3         0 my $fh;
124 3 100       9 if (ref($file)) {
125 1         3 $fh = $file;
126             }
127             else {
128 2 100       100 open $fh, '<', $file or die "$!: $file";
129             }
130 2         15 binmode($fh, ':raw');
131 2         18 $fh->seek(0, 0);
132              
133 2         30 my $info = _read_header($fh);
134 2 50       17 if ($info->{'type'} == 1) { # ASCII PBM
    50          
    50          
    50          
    50          
    50          
135 0         0 $bpc = 1;
136 0         0 $cs = 'DeviceGray';
137 0         0 $self->{'Decode'} = PDFArray(PDFNum(1), PDFNum(0));
138              
139             # Read the remainder of the file
140 0         0 local $/ = undef;
141 0         0 my $plain = <$fh>;
142              
143             # Discard everything other than ASCII 1 and 0
144 0         0 $plain =~ s/[^01]+//g;
145              
146             # Check length
147 0         0 my $size = $info->{'width'} * $info->{'height'};
148 0 0       0 croak "Incomplete ASCII PBM" if length($plain) < $size;
149              
150             # Discard any additional bits
151 0 0       0 $plain = substr($plain, 0, $size) if length($plain) > $size;
152              
153             # Pad with zeroes
154 0         0 $plain .= '0' x (8 - (length($plain) % 8));
155              
156             # Convert to binary
157 0         0 $self->{' stream'} = pack('B*', $plain);
158             }
159             elsif ($info->{'type'} == 2) { # ASCII PGM
160 0         0 $cs = 'DeviceGray';
161              
162             # Read the remainder of the file
163 0         0 local $/ = undef;
164 0         0 my $plain = <$fh>;
165              
166             # Discard everything other than digits and whitespace
167 0         0 $plain =~ s/[^\d\s]+//gs;
168 0         0 $plain =~ s/^\s+//;
169              
170             # Convert to an array of integers
171 0         0 my @raster = split m/\s+/, $plain;
172              
173             # Check length
174 0         0 my $size = $info->{'width'} * $info->{'height'};
175 0 0       0 croak "Incomplete ASCII PGM" if scalar(@raster) < $size;
176              
177             # Discard any additional integers
178 0 0       0 splice @raster, $size if scalar(@raster) > $size;
179              
180             # Scale
181 0         0 $scale = 1;
182 0 0       0 if ($info->{'max'} <= 255) {
183 0         0 $bpc = 8;
184 0 0       0 $scale = 255 / $info->{'max'} unless $info->{'max'} == 255;
185             }
186             else {
187 0         0 $bpc = 16;
188 0 0       0 $scale = 65535 / $info->{'max'} unless $info->{'max'} == 65535;
189             }
190 0         0 @raster = map { $_ * $scale } @raster;
  0         0  
191              
192             # Convert to bytes
193 0 0       0 if ($bpc == 8) {
194 0         0 $self->{' stream'} = pack('C*', @raster);
195             }
196             else {
197 0         0 $self->{' stream'} = pack('S*', @raster);
198             }
199             }
200             elsif ($info->{'type'} == 3) { # ASCII PPM
201 0         0 $cs = 'DeviceRGB';
202              
203             # Read the remainder of the file
204 0         0 local $/ = undef;
205 0         0 my $plain = <$fh>;
206              
207             # Discard everything other than digits and whitespace
208 0         0 $plain =~ s/[^\d\s]+//gs;
209 0         0 $plain =~ s/^\s+//;
210              
211             # Convert to an array of integers
212 0         0 my @raster = split m/\s+/, $plain;
213              
214             # Check length
215 0         0 my $size = $info->{'width'} * $info->{'height'};
216 0 0       0 croak "Incomplete ASCII PGM" if scalar(@raster) < $size * 3;
217              
218             # Discard any additional integers
219 0 0       0 splice @raster, $size if scalar(@raster) > $size * 3;
220              
221             # Scale
222 0         0 $scale = 1;
223 0 0       0 if ($info->{'max'} <= 255) {
224 0         0 $bpc = 8;
225 0 0       0 $scale = 255 / $info->{'max'} unless $info->{'max'} == 255;
226             }
227             else {
228 0         0 $bpc = 16;
229 0 0       0 $scale = 65535 / $info->{'max'} unless $info->{'max'} == 65535;
230             }
231 0         0 @raster = map { $_ * $scale } @raster;
  0         0  
232              
233             # Convert to bytes
234 0 0       0 if ($bpc == 8) {
235 0         0 $self->{' stream'} = pack('C*', @raster);
236             }
237             else {
238 0         0 $self->{' stream'} = pack('S*', @raster);
239             }
240             }
241             elsif ($info->{'type'} == 4) { # Raw PBM
242 0         0 $cs = 'DeviceGray';
243 0         0 $bpc = 1;
244 0         0 $self->{'Decode'} = PDFArray(PDFNum(1), PDFNum(0));
245 0         0 read($fh, $self->{' stream'}, ($info->{'width'} * $info->{'height'} / 8));
246             }
247             elsif ($info->{'type'} == 5) { # Raw PGM
248 0         0 $cs = 'DeviceGray';
249 0 0       0 $bpc = $info->{'max'} <= 255 ? 8 : 16;
250              
251 0 0 0     0 if ($info->{'max'} == 255 or $info->{'max'} == 65535) {
252 0         0 $scale = 1;
253             }
254             else {
255 0 0       0 $scale = ($bpc == 8 ? 255 : 65535) / $info->{'max'};
256             }
257              
258 0         0 my $size = $info->{'width'} * $info->{'height'};
259 0 0       0 if ($scale == 1) {
260 0         0 read($fh, $self->{' stream'}, $size * ($bpc / 8));
261             }
262             else {
263 0         0 for (1 .. $size) {
264 0         0 read($fh, $buf, $bpc / 8);
265 0 0       0 if ($bpc == 8) {
266 0         0 $self->{' stream'} .= pack('C', (unpack('C', $buf) * $scale));
267             }
268             else {
269 0         0 $self->{' stream'} .= pack('S', (unpack('S', $buf) * $scale));
270             }
271             }
272             }
273             }
274             elsif ($info->{'type'} == 6) { # Raw PPM
275 2         4 $cs = 'DeviceRGB';
276 2 50       7 $bpc = $info->{'max'} <= 255 ? 8 : 16;
277              
278 2 50 33     6 if ($info->{'max'} == 255 or $info->{'max'} == 65535) {
279 2         4 $scale = 1;
280             }
281             else {
282 0 0       0 $scale = ($bpc == 8 ? 255 : 65535) / $info->{'max'};
283             }
284              
285 2         5 my $size = $info->{'width'} * $info->{'height'};
286 2 50       4 if ($scale == 1) {
287 2         19 read($fh, $self->{' stream'}, $size * ($bpc / 8) * 3);
288             }
289             else {
290 0         0 for (1 .. ($size * 3)) {
291 0         0 read($fh, $buf, $bpc / 8);
292 0 0       0 if ($bpc == 8) {
293 0         0 $self->{' stream'} .= pack('C', (unpack('C', $buf) * $scale));
294             }
295             else {
296 0         0 $self->{' stream'} .= pack('S', (unpack('S', $buf) * $scale));
297             }
298             }
299             }
300             }
301 2         25 close $fh;
302              
303 2         17 $self->width($info->{'width'});
304 2         9 $self->height($info->{'height'});
305              
306 2         10 $self->bits_per_component($bpc);
307              
308 2         8 $self->colorspace($cs);
309              
310 2         10 return $self;
311             }
312              
313             1;