1# REPLACE FOLLOWING BY
2#
3# use PDL::PP qw/PDL::Experiment PDL::Experiment Experiment/;
4#
5# when using not in this package.
6
7pp_add_exported('',"rpnm wpnm");
8
9pp_addpm({At=>Top},<<'EOD');
10=head1 NAME
11
12PDL::IO::Pnm -- pnm format I/O for PDL
13
14=head1 SYNOPSIS
15
16  use PDL::IO::Pnm;
17  $im = wpnm $pdl, $file, $format[, $raw];
18  rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm";
19
20=head1 DESCRIPTION
21
22pnm I/O for PDL.
23
24=cut
25
26use PDL::Core qw/howbig convert/;
27use PDL::Types;
28use PDL::Basic;  # for max/min
29use PDL::IO::Misc;
30use Carp;
31use File::Temp qw( tempfile );
32
33# return the upper limit of data values an integer PDL data type
34# can hold
35sub dmax {
36    my $type = shift;
37    my $sz = 8*howbig($type);
38    $sz-- if ($type == $PDL_S || $type == $PDL_L);  # signed types
39    return ((1 << $sz)-1);
40}
41
42# output any errors that have accumulated
43sub show_err {
44  my ($file,$showflag) = @_;
45  my $err;
46  $showflag = 1 unless defined $showflag;
47  if (-s "$file") {
48    open(INPUT,$file) or barf "Can't open error file";
49    if ($showerr) {
50      while (<INPUT>) {
51       print STDERR "converter: $_";
52      }} else {
53       $err = join('',<INPUT>);
54    }
55  }
56  close INPUT;
57  unlink $file;
58  return $err unless $showflag;
59}
60
61# barf after showing any accumulated errors
62sub rbarf {
63  my $err = show_err(shift, 0);
64  $err = '' unless defined $err;
65  barf @_,"converter error: $err";
66}
67
68# carp after showing any accumulated errors
69sub rcarp {
70  show_err(shift);
71  carp @_;
72}
73EOD
74
75pp_addpm({At=>Bot},<<'EOD'); # the rest of FUNCTIONS section
76=head2 rpnm
77
78=for ref
79
80Read a pnm (portable bitmap/pixmap, pbm/ppm) file into a piddle.
81
82=for usage
83
84  Usage:  $im = rpnm $file;
85
86Reads a file in pnm format (ascii or raw) into a pdl (magic numbers P1-P6).
87Based on the input format it returns pdls with arrays of size (width,height)
88if binary or grey value data (pbm and pgm) or (3,width,height) if rgb
89data (ppm). This also means for a palette image that the distinction between
90an image and its lookup table is lost which can be a problem in cases (but can
91hardly be avoided when using netpbm/pbmplus).  Datatype is dependent
92on the maximum grey/color-component value (for raw and binary formats
93always PDL_B). rpnm tries to read chopped files by zero padding the
94missing data (well it currently doesn't, it barfs; I'll probably fix it
95when it becomes a problem for me ;). You can also read directly into an
96existing pdl that has to have the right size(!). This can come in handy
97when you want to read a sequence of images into a datacube.
98
99For details about the formats see appropriate manpages that come with the
100netpbm/pbmplus packages.
101
102=for example
103
104  $stack = zeroes(byte,3,500,300,4);
105  rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm";
106
107reads an rgb image (that had better be of size (500,300)) into the
108first plane of a 3D RGB datacube (=4D pdl datacube). You can also do
109inplace transpose/inversion that way.
110
111=cut
112
113sub rpnm {PDL->rpnm(@_)}
114sub PDL::rpnm {
115    barf 'Usage: $im = rpnm($file) or $im = $pdl->rpnm($file)'
116       if $#_<0 || $#_>2;
117    my ($pdl,$file,$maybe) = @_;
118
119
120    if (ref($file)) { # $file is really a pdl in this case
121	$pdl = $file;
122	$file = $maybe;
123    } else {
124        $pdl = $pdl->initialize;
125    }
126
127    my ($errfh, $efile) = tempfile();
128    # catch STDERR
129    open(SAVEERR, ">&STDERR");
130    open(STDERR, ">$efile") || barf "Can't redirect stderr";
131    my $succeed = open(PNM, $file);
132    # redirection now in effect for child
133    # close(STDERR);
134    open(STDERR, ">&PDL::IO::Pnm::SAVEERR");
135    rbarf $efile,"Can't open pnm file '$file'" unless $succeed;
136    binmode PNM;
137
138    read(PNM,(my $magic),2);
139    rbarf $efile, "Oops, this is not a PNM file" unless $magic =~ /P[1-6]/;
140    print "reading pnm file with magic $magic\n" if $PDL::debug>1;
141
142    my ($isrgb,$israw,$params) = (0,0,3);
143    $israw = 1 if $magic =~ /P[4-6]/;
144    $isrgb = 1 if $magic =~ /P[3,6]/;
145    if ($magic =~ /P[1,4]/) {  # PBM data
146	$params = 2;
147	$dims[2] = 1; }
148
149    # get the header information
150    my ($line, $pgot, @dims) = ("",0,0,0,0);
151    while (($pgot<$params) && ($line=<PNM>)) {
152       $line =~ s/#.*$//;
153	next if $line =~ /^\s*$/;    # just white space
154	while ($line !~ /^\s*$/ && $pgot < $params) {
155	    if ($line =~ /\s*(\S+)(.*)$/) {
156		$dims[$pgot++] = $1; $line = $2; }
157	    else {
158		rbarf $efile, "no valid header info in pnm";}
159	}
160    }
161
162    my $type = $PDL_B;
163    do {
164TYPES:	{  my $pdlt;
165	   foreach $pdlt ($PDL_B,$PDL_US,$PDL_L){
166	     if ($dims[2] <= dmax($pdlt))
167	       { $type = $pdlt;
168	         last TYPES;
169	       }
170	   }
171	   rbarf $efile, "rraw: data from ascii pnm file out of range";
172        }
173    };
174
175    # the file ended prematurely
176    rbarf $efile, "no valid header info in pnm" if $pgot < $params;
177    rbarf $efile,
178        "Dimensions must be > 0" if ($dims[0] <= 0) || ($dims[1] <= 0);
179
180    my @Dims = @dims[0,1];
181    $Dims[0] *= 3 if $isrgb;
182    if ($pdl->getndims==1 && $pdl->getdim(0)==0 && $isrgb) { #input pdl is null
183	local $PDL::debug = 0; # shut up
184	$pdl = $pdl->zeroes(PDL::Type->new($type),3,@dims[0,1]);
185    }
186    my $npdl = $isrgb ? $pdl->clump(2) : $pdl;
187    if ($israw) {
188       pnminraw (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1],
189	 $magic eq "P4", 'PDL::IO::Pnm::PNM');
190    } else {
191       my $form = $1 if $magic =~ /P([1-3])/;
192       pnminascii (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1],
193	$form, 'PDL::IO::Pnm::PNM');
194    }
195    print("loaded pnm file, $dims[0]x$dims[1], gmax: $dims[2]",
196	   $isrgb ? ", RGB data":"", $israw ? ", raw" : " ASCII"," data\n")
197	if $PDL::debug;
198    unlink($efile);
199
200    # need to byte swap for little endian platforms
201    unless ( isbigendian() ) {
202       if ($israw ) {
203          $pdl->bswap2 if $type==$PDL_US or $pdl->type == ushort;
204          $pdl->bswap4 if $type==$PDL_L;  # not likely, but supported anyway
205       }
206    }
207    return $pdl;
208}
209
210
211=head2 wpnm
212
213=for ref
214
215Write a pnm (portable bitmap/pixmap, pbm/ppm) file into a file.
216
217=for usage
218
219  Usage:  $im = wpnm $pdl, $file, $format[, $raw];
220
221Writes data in a pdl into pnm format (ascii or raw) (magic numbers P1-P6).
222The $format is required (normally produced by B<wpic>) and routine just
223checks if data is compatible with that format. All conversions should
224already have been done. If possible, usage of B<wpic> is preferred. Currently
225RAW format is chosen if compliant with range of input data. Explicit control
226of ASCII/RAW is possible through the optional $raw argument. If RAW is
227set to zero it will enforce ASCII mode. Enforcing RAW is
228somewhat meaningless as the routine will always try to write RAW
229format if the data range allows (but maybe it should reduce to a RAW
230supported type when RAW == 'RAW'?). For details about the formats
231consult appropriate manpages that come with the netpbm/pbmplus
232packages.
233
234=cut
235
236*wpnm = \&PDL::wpnm;
237sub PDL::wpnm {
238    barf ('Usage: wpnm($pdl,$filename,$format[,$raw]) ' .
239	   'or $pdl->wpnm($filename,$format[,$raw])') if $#_ < 2;
240    my ($pdl,$file,$type,$raw) = @_;
241    my ($israw,$max,$isrgb,$magic) = (0,255,0,"");
242
243    # need to copy input arg since bswap[24] work inplace
244    # might be better if the bswap calls detected if run in
245    # void context
246    my $swap_inplace = $pdl->is_inplace;
247
248    barf "wpnm: unknown format '$type'" if $type !~ /P[P,G,B]M/;
249
250    # check the data
251    my @Dims = $pdl->dims;
252    barf "wpnm: expecting 3D (3,w,h) input"
253	if ($type =~ /PPM/) && (($#Dims != 2) || ($Dims[0] != 3));
254    barf "wpnm: expecting 2D (w,h) input"
255	if ($type =~ /P[G,B]M/) && ($#Dims != 1);
256    barf "wpnm: user should convert float and double data to appropriate type"
257	if ($pdl->get_datatype == $PDL_F) || ($pdl->get_datatype == $PDL_D);
258    barf "wpnm: expecting prescaled data"
259	if (($pdl->get_datatype != $PDL_B) || ($pdl->get_datatype != $PDL_US)) &&
260	    ($pdl->min < 0);
261
262    # check for raw format
263    $israw = 1 if (($pdl->get_datatype == $PDL_B) || ($pdl->get_datatype == $PDL_US) || ($type =~ /PBM/));
264    $israw = 0 if (defined($raw) && !$raw);
265
266
267    $magic = $israw ? "P4" : "P1" if $type =~ /PBM/;
268    $magic = $israw ? "P5" : "P2" if $type =~ /PGM/;
269    $magic = $israw ? "P6" : "P3" if $type =~ /PPM/;
270    $isrgb = 1 if $magic =~ /P[3,6]/;
271
272    # catch STDERR and sigpipe
273    my ($errfh, $efile) = tempfile();
274    local $SIG{"PIPE"} = sub { show_err($efile);
275			       die "Bad write to pipe $? $!"; };
276
277    my $pref = ($file !~ /^\s*[|>]/) ? ">" : "";  # test for plain file name
278    open(SAVEERR, ">&STDERR");
279    open(STDERR, ">$efile") || barf "Can't redirect stderr";
280    my $succeed = open(PNM, $pref . $file);
281    # close(STDERR);
282    open(STDERR, ">&PDL::IO::Pnm::SAVEERR");
283    rbarf $efile, "Can't open pnm file" unless $succeed;
284    binmode PNM;
285
286    $max =$pdl->max;
287    print "writing ". ($israw ? "raw" : "ascii") .
288      "format with magic $magic\n" if $PDL::debug;
289    # write header
290    print PNM "$magic\n";
291    print PNM "$Dims[-2] $Dims[-1]\n";
292    if ($type !~ /PBM/) {	# fix maxval for raw output formats
293       my $outmax = 0;
294
295       if ($max < 256) {
296          $outmax =   "255";
297       } elsif ($max < 65536) {
298          $outmax = "65535";
299       } else {
300          $outmax = $max;
301       };
302
303       print PNM "$outmax\n" unless $type =~ /PBM/;
304    };
305
306    # if rgb clump first two dims together
307    my $out = ($isrgb ? $pdl->slice(':,:,-1:0')->clump(2)
308		 : $pdl->slice(':,-1:0'));
309
310    # handle byte swap issues for little endian platforms
311    unless ( isbigendian() ) {
312       if ($israw ) {
313          # make copy if needed
314          $out = $out->copy unless $swap_inplace;
315          if ( (255 < $max) and ($max < 65536)) {
316             $out->bswap2;
317          } elsif ($max >= 65536) {
318             $out->bswap4;
319          }
320       }
321    }
322    pnmout($out,$israw,$type eq "PBM",'PDL::IO::Pnm::PNM');
323
324    # check if our child returned an error (in case of a pipe)
325    if (!(close PNM)) {
326      my $err = show_err($efile,0);
327      barf "wpnm: pbmconverter error: $err";
328    }
329    unlink($efile);
330}
331
332
333
334;# Exit with OK status
335
3361;
337
338=head1 BUGS
339
340The stderr of the converters is redirected to a file. The filename is
341currently generated in a probably non-portable way. A method that avoids
342a file (and is portable) would be preferred.
343
344C<rpnm> currently relies on the fact that the header is separated
345from the image data by a newline. This is not required by the p[bgp]m
346formats (in fact any whitespace is allowed) but most of the pnm
347writers seem to comply with that. Truncated files are currently
348treated ungracefully (C<rpnm> just barfs).
349
350=head1 AUTHOR
351
352Copyright (C) 1996,1997 Christian Soeller <c.soeller@auckland.ac.nz>
353All rights reserved. There is no warranty. You are allowed
354to redistribute this software / documentation under certain
355conditions. For details, see the file COPYING in the PDL
356distribution. If this file is separated from the PDL distribution,
357the copyright notice should be included in the file.
358
359
360=cut
361
362
363############################## END PM CODE ################################
364EOD
365
366
367pp_def('pnminraw',
368	Pars => 'type(); byte+ [o] im(m,n)',
369	OtherPars => 'int ms => m; int ns => n;
370			int isbin; char* fd',
371	GenericTypes => [B,U,L],
372	Code => 'int ms, ns, i,j,k,bit,llen;
373		 PerlIO *fp;
374		 IO *io;
375		 PDL_Byte *buf, *bp;
376		 $GENERIC() *gbp;
377
378		 io = GvIO(gv_fetchpv($COMP(fd),FALSE,SVt_PVIO));
379		 if (!io || !(fp = IoIFP(io)))
380			barf("Can\'t figure out FP");
381		 ms = $SIZE(m); ns = $SIZE(n);
382		 llen = ($COMP(isbin) ? ((ms+7) / 8) : (ms * sizeof($GENERIC())));
383		 /* allocate a buffer of length llen */
384		 if ((buf = (PDL_Byte*) malloc(llen*sizeof(PDL_Byte)))
385		      == NULL)
386			barf("Error getting mem for line buffer");
387		 threadloop %{  /* with top to bottom inversion */
388			for (i=ns-1; i>= 0; i--) {
389			   if (PerlIO_read(fp,buf,llen) != llen)
390				barf("Error reading pnm file");
391			   if ($COMP(isbin))  /* unpack buffer */
392				for (j=0,bp=buf,bit=0; j<ms; j++, bit++) {
393					bit &= 7;
394					if (!bit) k= *bp++;
395					/* here we do the inversion */
396					$im(n=>i,m=>j) = (k&0x80) ? 0 : 1;
397					k = k << 1;
398      				}
399			   else {
400				gbp = ($GENERIC()*)buf;
401				loop(m) %{
402					$im(n=>i,m=>m) = *(gbp++);
403				%}
404			   }
405			}
406		 %}', Doc => '
407
408=for ref
409
410Read in a raw pnm file.
411
412read a raw pnm file. The C<type> argument is only there to
413determine the type of the operation when creating C<im> or trigger
414the appropriate type conversion (maybe we want a byte+ here so that
415C<im> follows I<strictly> the type of C<type>).
416
417=cut
418
419
420'
421
422);
423
424pp_addhdr(<<'EOH');
425#define SWALLOWLINE(fp) while ((s = PerlIO_getc(fp)) != '\n' && s != EOF)
426#define PBM 1
427#define PGM 2
428#define PPM 3
429
430int getint(PerlIO *fp, PDL_Long *ip);
431
432/* process one input line from an ascii pnm file
433 * and store data into a pdl data component
434 * returns number of elements read
435 * returns -1 if garbage was encountered
436 */
437
438/* get the next number from the input string
439 * return values:  len : number of characters read
440 *                 0 : end of string or skip rest of string because comment
441 *                -1 : found garbage
442 */
443#define    TRAILING_WHITESPACE_CHECK(s) \
444   if (s!=' ' && s!='\t' && s!='\r' && s!='\n' && s!=',')  return -1
445int getint(PerlIO *fp, PDL_Long *ip)
446{
447  PDL_Long i = 0;
448  int nread = 0;
449  int s = PerlIO_getc(fp);
450
451  if (s == EOF) return 0;
452  while (1) {
453    if (s == EOF)
454      return 0;   /* signal end of line */
455    if (s == '#')
456      SWALLOWLINE(fp);
457    if (s >='0' && s <='9') break;
458    if (s!=' ' && s!='\t' && s!='\r' && s!='\n' && s!=',')
459      return -1;  /* garbage */
460    s = PerlIO_getc(fp); /* else skip whitespace */
461  }
462  /* parse number */
463  while (1) {
464    i = (i*10) + (s - '0');
465    nread++;
466    if ((s = PerlIO_getc(fp)) == EOF) break; /* we could loose that */
467    if (s<'0' || s>'9') break;
468  }
469  *ip = i;
470  TRAILING_WHITESPACE_CHECK(s);
471  return nread;
472}
473
474EOH
475
476pp_def( 'pnminascii',
477	Pars => 'type(); byte+ [o] im(m,n)',
478	OtherPars => 'int ms => m; int ns => n;
479			int format; char* fd',
480	GenericTypes => [B,U,S,L],
481	Code => q?
482		 int ms, ns, s, i;
483		 PerlIO *fp;
484		 IO *io;
485
486		 io = GvIO(gv_fetchpv($COMP(fd),FALSE,SVt_PVIO));
487		 if (!io || !(fp = IoIFP(io)))
488			barf("Can\'t figure out FP");
489		 ms = $SIZE(m); ns = $SIZE(n);
490
491		 switch ($COMP(format)) {
492		 case PBM:
493		   threadloop %{  /* with top to bottom inversion */
494			for (i=ns-1; i>= 0; i--) {
495			loop(m) %{
496			    while ((s = PerlIO_getc(fp)) != EOF) {
497			      switch (s) {
498			       case '#': /* comment, skip rest of line */
499				SWALLOWLINE(fp);
500				break;
501			       case '0':
502			       case '1':
503				/* invert on the fly */
504				$im(n=>i,m=>m) = 1 - (s - '0');
505				goto $TBUSL(B,U,S,L)next;
506				break;
507			       case ' ':
508			       case '\t':
509			       case '\r':
510			       case '\n':
511			       case ',':
512				/* skip whitespace */
513				break;
514			       default:	/* garbage */
515				barf("found garbage, aborting"); /* for now */
516				break;
517			      }
518			    }
519			  $TBUSL(B,U,S,L)next: ;
520			%}
521			}
522		  %}
523		  break;
524		case PGM:
525		case PPM:
526		   threadloop %{  /* with top to bottom inversion */
527			PDL_Long j;
528			for (i=ns-1; i>= 0; i--) {
529			  loop(m) %{
530			    if (getint(fp,&j) <= 0)
531		  		barf("found garbage, aborting"); /* for now */
532			    $im(n=>i,m=>m) = j;
533			  %}
534			}
535		   %}
536		   break;
537		default:
538		   barf("unknown PNM format");
539		   break;
540		} /* end switch */
541		?, Doc => '
542=for ref
543
544Read in an ascii pnm file.
545
546=cut
547
548
549'
550);
551
552
553# write a line of data supporting threading !
554pp_def(	'pnmout',
555	Pars => 'a(m);',
556	'NoPthread' => 1, # Pthreading doesn't make sense for an IO function
557	OtherPars => "int israw; int isbin; char *fd",
558	GenericTypes => [B,U,S,L],
559	Code => 'PerlIO *fp;
560		 IO *io;
561
562		 io = GvIO(gv_fetchpv($COMP(fd),FALSE,SVt_PVIO));
563		 if (!io || !(fp = IoIFP(io)))
564			barf("Can\'t figure out FP");
565
566		 if ($COMP(israw)) {
567		    if ($COMP(isbin)) {
568		    	threadloop %{
569			  int k=0, bit=0;
570			  loop(m) %{
571			    k = (k << 1) | ($a() < 1);
572			    bit++;
573	  			if (bit==8) {
574				  PerlIO_putc(fp,k);
575				  bit = k = 0;
576			        }
577		 	  %}
578			  if (bit) {
579			    k = k << (8-bit);
580			    PerlIO_putc(fp,k);
581			  }
582		       %}
583		    } else {
584		      int len = $SIZE(m) * sizeof($GENERIC());
585		      threadloop %{
586		 	if (PerlIO_write(fp,$P(a),len) != len)
587				barf("Error writing pnm file");
588		      %}
589		    }
590		 } else {
591		    int len=0;
592		    threadloop %{
593			loop(m) %{
594				PerlIO_printf(fp,"%3d ",$COMP(isbin) ?
595					($a() < 1) :$a());
596				len +=4;
597				if (len>58) { PerlIO_printf(fp,"\n"); len=0; }
598		 	%}
599                 	if (len<=58)
600                     		PerlIO_printf(fp,"\n");
601		    %}
602		}
603', Doc => '
604=for ref
605
606Write a line of pnm data.
607
608This function is implemented this way so that threading works
609naturally.
610
611=cut
612
613
614');
615
616pp_done();
617