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