1use PDL::LiteF;
2use PDL::IO::Pic;
3use PDL::ImageRGB;
4use PDL::Dbg;
5use File::Temp qw(tempdir);
6use File::Spec;
7
8use strict;
9use warnings;
10
11# we need tests with index shuffling once vaffines are fixed
12use Test::More;
13
14sub tapprox {
15	my($pa,$pb,$mdiff) = @_;
16	all approx($pa, $pb,$mdiff || 0.01);
17}
18
19sub rpic_unlink {
20  my $file = shift;
21  my $pdl = PDL->rpic($file);
22  unlink $file;
23  return $pdl;
24}
25
26sub rgb { $_[0]->getndims == 3 && $_[0]->getdim(0) == 3 }
27
28$PDL::debug = 1;
29my $iform = 'PNMRAW'; # change to PNMASCII to use ASCII PNM intermediate
30                      # output format
31
32#              [FORMAT, extension, ushort-divisor,
33#               only RGB/no RGB/any (1/-1/0), mxdiff]
34#  no test of PCX format because seems to be severely brain damaged
35my %formats = ('PNM'  => ['pnm',1,0,0.01],
36	       'GIF'  => ['gif',256,0,1.01],
37	       'TIFF' => ['tif',1,0,0.01],
38#	       'RAST' => ['rast',256,0,1.01],
39#	       'SGI'  => ['rgb',1,0,0.01],
40	      );
41
42# only test PNM format
43# netpbm has too many bugs on various platforms
44my @allowed = ();
45for ('PNM') { push @allowed, $_
46	if PDL->rpiccan($_) && defined $formats{$_} }
47
48my $ntests = 3 * @allowed;  # -1 due to TIFF converter
49$ntests-- if grep /^TIFF$/, @allowed;
50if ($ntests < 1) {
51  plan skip_all => 'No tests';
52}
53
54plan tests => $ntests;
55note "Testable formats on this platform:\n  ".join(',',@allowed)."\n";
56
57my $im1 = pdl([[0,65535,0], [256,256,256], [65535,256,65535]])->ushort;
58my $im2 = byte $im1/256;
59
60# make the resulting file at least 12 byte long
61# otherwise we run into a problem when reading the magic (Fix!)
62# FIXME
63my $im3 = PDL::byte [[0,0,255,255,12,13],[1,4,5,6,11,124],
64	     [100,0,0,0,10,10],[2,1,0,1,0,14],[2,1,0,1,0,14],
65	     [2,1,0,1,0,14]];
66
67if ($PDL::debug) {
68  note $im1;
69  $im1->px;
70  note $im2;
71  $im2->px;
72  note $im3>0;
73  $im3->px;
74}
75
76# for some reason the pnmtotiff converter coredumps when trying
77# to do the conversion for the ushort data, haven't yet tried to
78# figure out why
79my $usherr = 0;
80my $tmpdir = tempdir( CLEANUP => 1 );
81sub tmpfile { File::Spec->catfile($tmpdir, $_[0]); }
82foreach my $format (sort @allowed) {
83    note " ** testing $format format **\n";
84    my $form = $formats{$format};
85
86    my $tushort = tmpfile("tushort.$form->[0]");
87    my $tbyte = tmpfile("tbyte.$form->[0]");
88    my $tbin = tmpfile("tbin.$form->[0]");
89    eval {
90        $im1->wpic($tushort,{IFORM => "$iform"})
91    } unless $format eq 'TIFF';
92    SKIP: {
93        my $additional = '';
94        if ($format ne 'TIFF' && $@ =~ /maxval is too large/) {
95            $additional = ' (recompile pbmplus with PGM_BIGGRAYS!)';
96        }
97        skip "Error: '$@'$additional", 2 if $@;
98        $im2->wpic($tbyte,{IFORM => "$iform"});
99        $im3->wpic($tbin,{COLOR => 'bw', IFORM => "$iform"});
100        my $in1 = rpic_unlink($tushort) unless
101            $usherr || $format eq 'TIFF';
102        my $in2 = rpic_unlink($tbyte);
103        my $in3 = rpic_unlink($tbin);
104
105        if ($format ne 'TIFF') {
106          my $scale = ($form->[2] || rgb($in1) ? $im1->dummy(0,3) : $im1);
107          my $comp = $scale / PDL::ushort($form->[1]);
108          ok($usherr || tapprox($comp,$in1,$form->[3]));
109        }
110        {
111        my $comp = ($form->[2] || rgb($in2) ? $im2->dummy(0,3) : $im2);
112        ok(tapprox($comp,$in2));
113        }
114        {
115        my $comp = ($form->[2] || rgb($in3) ? ($im3->dummy(0,3)>0)*255 : ($im3 > 0));
116        $comp = $comp->ushort*$in3->max if $format eq 'SGI' && $in3->max > 0;
117        ok(tapprox($comp,$in3));
118        }
119
120        if ($PDL::debug) {
121          note $in1->px unless $format eq 'TIFF';
122          note $in2->px;
123          note $in3->px;
124        }
125    }
126}
127
128use Data::Dumper;
129note "Dumping diagnostic PDL::IO::Pic converter data...\n";
130note Dumper(\%PDL::IO::Pic::converter);
131