File Coverage

blib/lib/PDLA/IO/Pnm.pm
Criterion Covered Total %
statement 133 158 84.1
branch 85 128 66.4
condition 29 54 53.7
subroutine 13 17 76.4
pod 1 7 14.2
total 261 364 71.7


line stmt bran cond sub pod time code
1              
2             #
3             # GENERATED WITH PDLA::PP! Don't modify!
4             #
5             package PDLA::IO::Pnm;
6              
7             @EXPORT_OK = qw( rpnm wpnm PDLA::PP pnminraw PDLA::PP pnminascii PDLA::PP pnmout );
8             %EXPORT_TAGS = (Func=>[@EXPORT_OK]);
9              
10 14     14   609 use PDLA::Core;
  14         34  
  14         96  
11 14     14   105 use PDLA::Exporter;
  14         33  
  14         80  
12 14     14   75 use DynaLoader;
  14         36  
  14         1033  
13              
14              
15              
16            
17             @ISA = ( 'PDLA::Exporter','DynaLoader' );
18             push @PDLA::Core::PP, __PACKAGE__;
19             bootstrap PDLA::IO::Pnm ;
20              
21              
22              
23              
24             =head1 NAME
25              
26             PDLA::IO::Pnm -- pnm format I/O for PDLA
27              
28             =head1 SYNOPSIS
29              
30             use PDLA::IO::Pnm;
31             $im = wpnm $pdl, $file, $format[, $raw];
32             rpnm $stack->slice(':,:,:,(0)'),"PDLA.ppm";
33              
34             =head1 DESCRIPTION
35              
36             pnm I/O for PDLA.
37              
38             =cut
39              
40 14     14   104 use PDLA::Core qw/howbig convert/;
  14         51  
  14         66  
41 14     14   96 use PDLA::Types;
  14         58  
  14         1673  
42 14     14   104 use PDLA::Basic; # for max/min
  14         45  
  14         83  
43 14     14   1309 use PDLA::IO::Misc;
  14         34  
  14         114  
44 14     14   111 use Carp;
  14         32  
  14         842  
45 14     14   9929 use File::Temp qw( tempfile );
  14         150750  
  14         28595  
46              
47             # return the upper limit of data values an integer PDLA data type
48             # can hold
49             sub dmax {
50 36     36 0 64 my $type = shift;
51 36         112 my $sz = 8*howbig($type);
52 36 50 33     182 $sz-- if ($type == $PDLA_S || $type == $PDLA_L); # signed types
53 36         131 return ((1 << $sz)-1);
54             }
55              
56             # output any errors that have accumulated
57             sub show_err {
58 0     0 0 0 my ($file,$showflag) = @_;
59 0         0 my $err;
60 0 0       0 $showflag = 1 unless defined $showflag;
61 0 0       0 if (-s "$file") {
62 0 0       0 open(INPUT,$file) or barf "Can't open error file";
63 0 0       0 if ($showerr) {
64 0         0 while () {
65 0         0 print STDERR "converter: $_";
66             }} else {
67 0         0 $err = join('',);
68             }
69             }
70 0         0 close INPUT;
71 0         0 unlink $file;
72 0 0       0 return $err unless $showflag;
73             }
74              
75             # barf after showing any accumulated errors
76             sub rbarf {
77 0     0 0 0 my $err = show_err(shift, 0);
78 0 0       0 $err = '' unless defined $err;
79 0         0 barf @_,"converter error: $err";
80             }
81              
82             # carp after showing any accumulated errors
83             sub rcarp {
84 0     0 0 0 show_err(shift);
85 0         0 carp @_;
86             }
87              
88              
89              
90              
91              
92              
93             =head1 FUNCTIONS
94              
95              
96              
97             =cut
98              
99              
100              
101              
102              
103              
104             =head2 pnminraw
105              
106             =for sig
107              
108             Signature: (type(); byte+ [o] im(m,n); int ms => m; int ns => n;
109             int isbin; char* fd)
110              
111              
112              
113             =for ref
114              
115             Read in a raw pnm file.
116              
117             read a raw pnm file. The C argument is only there to
118             determine the type of the operation when creating C or trigger
119             the appropriate type conversion (maybe we want a byte+ here so that
120             C follows I the type of C).
121              
122              
123              
124             =for bad
125              
126             pnminraw does not process bad values.
127             It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles.
128              
129              
130             =cut
131              
132              
133              
134              
135              
136              
137             *pnminraw = \&PDLA::pnminraw;
138              
139              
140              
141              
142              
143             =head2 pnminascii
144              
145             =for sig
146              
147             Signature: (type(); byte+ [o] im(m,n); int ms => m; int ns => n;
148             int format; char* fd)
149              
150              
151             =for ref
152              
153             Read in an ascii pnm file.
154              
155              
156              
157             =for bad
158              
159             pnminascii does not process bad values.
160             It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles.
161              
162              
163             =cut
164              
165              
166              
167              
168              
169              
170             *pnminascii = \&PDLA::pnminascii;
171              
172              
173              
174              
175              
176             =head2 pnmout
177              
178             =for sig
179              
180             Signature: (a(m); int israw; int isbin; char *fd)
181              
182              
183             =for ref
184              
185             Write a line of pnm data.
186              
187             This function is implemented this way so that threading works
188             naturally.
189              
190              
191              
192             =for bad
193              
194             pnmout does not process bad values.
195             It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles.
196              
197              
198             =cut
199              
200              
201              
202              
203              
204              
205             *pnmout = \&PDLA::pnmout;
206              
207              
208              
209             ;
210              
211             =head2 rpnm
212              
213             =for ref
214              
215             Read a pnm (portable bitmap/pixmap, pbm/ppm) file into a piddle.
216              
217             =for usage
218              
219             Usage: $im = rpnm $file;
220              
221             Reads a file in pnm format (ascii or raw) into a pdl (magic numbers P1-P6).
222             Based on the input format it returns pdls with arrays of size (width,height)
223             if binary or grey value data (pbm and pgm) or (3,width,height) if rgb
224             data (ppm). This also means for a palette image that the distinction between
225             an image and its lookup table is lost which can be a problem in cases (but can
226             hardly be avoided when using netpbm/pbmplus). Datatype is dependent
227             on the maximum grey/color-component value (for raw and binary formats
228             always PDLA_B). rpnm tries to read chopped files by zero padding the
229             missing data (well it currently doesn't, it barfs; I'll probably fix it
230             when it becomes a problem for me ;). You can also read directly into an
231             existing pdl that has to have the right size(!). This can come in handy
232             when you want to read a sequence of images into a datacube.
233              
234             For details about the formats see appropriate manpages that come with the
235             netpbm/pbmplus packages.
236              
237             =for example
238              
239             $stack = zeroes(byte,3,500,300,4);
240             rpnm $stack->slice(':,:,:,(0)'),"PDLA.ppm";
241              
242             reads an rgb image (that had better be of size (500,300)) into the
243             first plane of a 3D RGB datacube (=4D pdl datacube). You can also do
244             inplace transpose/inversion that way.
245              
246             =cut
247              
248 26     26 1 437 sub rpnm {PDLA->rpnm(@_)}
249             sub PDLA::rpnm {
250 26 50 33 26 0 138 barf 'Usage: $im = rpnm($file) or $im = $pdl->rpnm($file)'
251             if $#_<0 || $#_>2;
252 26         73 my ($pdl,$file,$maybe) = @_;
253              
254              
255 26 100       63 if (ref($file)) { # $file is really a pdl in this case
256 10         21 $pdl = $file;
257 10         18 $file = $maybe;
258             } else {
259 16         105 $pdl = $pdl->initialize;
260             }
261              
262 26         93 my ($errfh, $efile) = tempfile();
263             # catch STDERR
264 26         8519 open(SAVEERR, ">&STDERR");
265 26 50       1111 open(STDERR, ">$efile") || barf "Can't redirect stderr";
266 26         992 my $succeed = open(PNM, $file);
267             # redirection now in effect for child
268             # close(STDERR);
269 26         607 open(STDERR, ">&PDLA::IO::Pnm::SAVEERR");
270 26 50       89 rbarf $efile,"Can't open pnm file '$file'" unless $succeed;
271 26         62 binmode PNM;
272              
273 26         311 read(PNM,(my $magic),2);
274 26 50       202 rbarf $efile, "Oops, this is not a PNM file" unless $magic =~ /P[1-6]/;
275 26 50       78 print "reading pnm file with magic $magic\n" if $PDLA::debug>1;
276              
277 26         65 my ($isrgb,$israw,$params) = (0,0,3);
278 26 100       114 $israw = 1 if $magic =~ /P[4-6]/;
279 26 100       77 $isrgb = 1 if $magic =~ /P[3,6]/;
280 26 100       75 if ($magic =~ /P[1,4]/) { # PBM data
281 7         13 $params = 2;
282 7         17 $dims[2] = 1; }
283              
284             # get the header information
285 26         68 my ($line, $pgot, @dims) = ("",0,0,0,0);
286 26   66     198 while (($pgot<$params) && ($line=)) {
287 71         137 $line =~ s/#.*$//;
288 71 100       276 next if $line =~ /^\s*$/; # just white space
289 45   66     172 while ($line !~ /^\s*$/ && $pgot < $params) {
290 71 50       261 if ($line =~ /\s*(\S+)(.*)$/) {
291 71         184 $dims[$pgot++] = $1; $line = $2; }
  71         318  
292             else {
293 0         0 rbarf $efile, "no valid header info in pnm";}
294             }
295             }
296              
297 26         55 my $type = $PDLA_B;
298 26         40 do {
299 26         38 TYPES: { my $pdlt;
  26         32  
300 26         82 foreach $pdlt ($PDLA_B,$PDLA_US,$PDLA_L){
301 36 100       97 if ($dims[2] <= dmax($pdlt))
302 26         40 { $type = $pdlt;
303 26         69 last TYPES;
304             }
305             }
306 0         0 rbarf $efile, "rraw: data from ascii pnm file out of range";
307             }
308             };
309              
310             # the file ended prematurely
311 26 50       69 rbarf $efile, "no valid header info in pnm" if $pgot < $params;
312 26 50 33     117 rbarf $efile,
313             "Dimensions must be > 0" if ($dims[0] <= 0) || ($dims[1] <= 0);
314              
315 26         79 my @Dims = @dims[0,1];
316 26 100       54 $Dims[0] *= 3 if $isrgb;
317 26 100 33     283 if ($pdl->getndims==1 && $pdl->getdim(0)==0 && $isrgb) { #input pdl is null
      66        
318 2         12 local $PDLA::debug = 0; # shut up
319 2         14 $pdl = $pdl->zeroes(PDLA::Type->new($type),3,@dims[0,1]);
320             }
321 26 100       73 my $npdl = $isrgb ? $pdl->clump(2) : $pdl;
322 26 100       57 if ($israw) {
323 18         58 pnminraw (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1],
324             $magic eq "P4", 'PDLA::IO::Pnm::PNM');
325             } else {
326 8 50       39 my $form = $1 if $magic =~ /P([1-3])/;
327 8         25 pnminascii (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1],
328             $form, 'PDLA::IO::Pnm::PNM');
329             }
330 26 50       331 print("loaded pnm file, $dims[0]x$dims[1], gmax: $dims[2]",
    50          
    100          
331             $isrgb ? ", RGB data":"", $israw ? ", raw" : " ASCII"," data\n")
332             if $PDLA::debug;
333 26         758 unlink($efile);
334              
335             # need to byte swap for little endian platforms
336 26 50       175 unless ( isbigendian() ) {
337 26 100       83 if ($israw ) {
338 18 100 66     924 $pdl->bswap2 if $type==$PDLA_US or $pdl->type == ushort;
339 18 50       81 $pdl->bswap4 if $type==$PDLA_L; # not likely, but supported anyway
340             }
341             }
342 26         754 return $pdl;
343             }
344              
345              
346             =head2 wpnm
347              
348             =for ref
349              
350             Write a pnm (portable bitmap/pixmap, pbm/ppm) file into a file.
351              
352             =for usage
353              
354             Usage: $im = wpnm $pdl, $file, $format[, $raw];
355              
356             Writes data in a pdl into pnm format (ascii or raw) (magic numbers P1-P6).
357             The $format is required (normally produced by B) and routine just
358             checks if data is compatible with that format. All conversions should
359             already have been done. If possible, usage of B is preferred. Currently
360             RAW format is chosen if compliant with range of input data. Explicit control
361             of ASCII/RAW is possible through the optional $raw argument. If RAW is
362             set to zero it will enforce ASCII mode. Enforcing RAW is
363             somewhat meaningless as the routine will always try to write RAW
364             format if the data range allows (but maybe it should reduce to a RAW
365             supported type when RAW == 'RAW'?). For details about the formats
366             consult appropriate manpages that come with the netpbm/pbmplus
367             packages.
368              
369             =cut
370              
371             *wpnm = \&PDLA::wpnm;
372             sub PDLA::wpnm {
373 24 50   24 0 1228 barf ('Usage: wpnm($pdl,$filename,$format[,$raw]) ' .
374             'or $pdl->wpnm($filename,$format[,$raw])') if $#_ < 2;
375 24         83 my ($pdl,$file,$type,$raw) = @_;
376 24         58 my ($israw,$max,$isrgb,$magic) = (0,255,0,"");
377              
378             # need to copy input arg since bswap[24] work inplace
379             # might be better if the bswap calls detected if run in
380             # void context
381 24         108 my $swap_inplace = $pdl->is_inplace;
382              
383 24 50       140 barf "wpnm: unknown format '$type'" if $type !~ /P[P,G,B]M/;
384              
385             # check the data
386 24         83 my @Dims = $pdl->dims;
387 24 50 33     87 barf "wpnm: expecting 3D (3,w,h) input"
      66        
388             if ($type =~ /PPM/) && (($#Dims != 2) || ($Dims[0] != 3));
389 24 50 66     168 barf "wpnm: expecting 2D (w,h) input"
390             if ($type =~ /P[G,B]M/) && ($#Dims != 1);
391 24 50 33     153 barf "wpnm: user should convert float and double data to appropriate type"
392             if ($pdl->get_datatype == $PDLA_F) || ($pdl->get_datatype == $PDLA_D);
393 24 50 66     184 barf "wpnm: expecting prescaled data"
      33        
394             if (($pdl->get_datatype != $PDLA_B) || ($pdl->get_datatype != $PDLA_US)) &&
395             ($pdl->min < 0);
396              
397             # check for raw format
398 24 50 66     162 $israw = 1 if (($pdl->get_datatype == $PDLA_B) || ($pdl->get_datatype == $PDLA_US) || ($type =~ /PBM/));
      33        
399 24 100 100     92 $israw = 0 if (defined($raw) && !$raw);
400              
401              
402 24 100       98 $magic = $israw ? "P4" : "P1" if $type =~ /PBM/;
    100          
403 24 100       96 $magic = $israw ? "P5" : "P2" if $type =~ /PGM/;
    100          
404 24 50       62 $magic = $israw ? "P6" : "P3" if $type =~ /PPM/;
    100          
405 24 100       86 $isrgb = 1 if $magic =~ /P[3,6]/;
406              
407             # catch STDERR and sigpipe
408 24         93 my ($errfh, $efile) = tempfile();
409 0     0   0 local $SIG{"PIPE"} = sub { show_err($efile);
410 24         8684 die "Bad write to pipe $? $!"; };
  0         0  
411              
412 24 100       177 my $pref = ($file !~ /^\s*[|>]/) ? ">" : ""; # test for plain file name
413 24         499 open(SAVEERR, ">&STDERR");
414 24 50       1174 open(STDERR, ">$efile") || barf "Can't redirect stderr";
415 24         1341 my $succeed = open(PNM, $pref . $file);
416             # close(STDERR);
417 24         604 open(STDERR, ">&PDLA::IO::Pnm::SAVEERR");
418 24 50       90 rbarf $efile, "Can't open pnm file" unless $succeed;
419 24         70 binmode PNM;
420              
421 24         108 $max =$pdl->max;
422 24 50       194 print "writing ". ($israw ? "raw" : "ascii") .
    100          
423             "format with magic $magic\n" if $PDLA::debug;
424             # write header
425 24         245 print PNM "$magic\n";
426 24         165 print PNM "$Dims[-2] $Dims[-1]\n";
427 24 100       95 if ($type !~ /PBM/) { # fix maxval for raw output formats
428 17         34 my $outmax = 0;
429              
430 17 100       63 if ($max < 256) {
    50          
431 9         28 $outmax = "255";
432             } elsif ($max < 65536) {
433 8         20 $outmax = "65535";
434             } else {
435 0         0 $outmax = $max;
436             };
437              
438 17 50       73 print PNM "$outmax\n" unless $type =~ /PBM/;
439             };
440              
441             # if rgb clump first two dims together
442 24 100       137 my $out = ($isrgb ? $pdl->slice(':,:,-1:0')->clump(2)
443             : $pdl->slice(':,-1:0'));
444              
445             # handle byte swap issues for little endian platforms
446 24 50       113 unless ( isbigendian() ) {
447 24 100       66 if ($israw ) {
448             # make copy if needed
449 16 50       77 $out = $out->copy unless $swap_inplace;
450 16 100 66     115 if ( (255 < $max) and ($max < 65536)) {
    50          
451 6         811 $out->bswap2;
452             } elsif ($max >= 65536) {
453 0         0 $out->bswap4;
454             }
455             }
456             }
457 24         739 pnmout($out,$israw,$type eq "PBM",'PDLA::IO::Pnm::PNM');
458              
459             # check if our child returned an error (in case of a pipe)
460 24 50       861 if (!(close PNM)) {
461 0         0 my $err = show_err($efile,0);
462 0         0 barf "wpnm: pbmconverter error: $err";
463             }
464 24         1921 unlink($efile);
465             }
466              
467              
468              
469             ;# Exit with OK status
470              
471             1;
472              
473             =head1 BUGS
474              
475             The stderr of the converters is redirected to a file. The filename is
476             currently generated in a probably non-portable way. A method that avoids
477             a file (and is portable) would be preferred.
478              
479             C currently relies on the fact that the header is separated
480             from the image data by a newline. This is not required by the p[bgp]m
481             formats (in fact any whitespace is allowed) but most of the pnm
482             writers seem to comply with that. Truncated files are currently
483             treated ungracefully (C just barfs).
484              
485             =head1 AUTHOR
486              
487             Copyright (C) 1996,1997 Christian Soeller
488             All rights reserved. There is no warranty. You are allowed
489             to redistribute this software / documentation under certain
490             conditions. For details, see the file COPYING in the PDLA
491             distribution. If this file is separated from the PDLA distribution,
492             the copyright notice should be included in the file.
493              
494              
495             =cut
496              
497              
498             ############################## END PM CODE ################################
499              
500              
501              
502              
503             # Exit with OK status
504              
505             1;
506              
507