File: picrgb.t

package info (click to toggle)
pdl 1%3A2.019-5
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 12,276 kB
  • sloc: perl: 47,799; fortran: 13,113; ansic: 9,365; sh: 41; makefile: 38; sed: 6
file content (127 lines) | stat: -rw-r--r-- 3,290 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
use PDL;
use PDL::IO::Pic;
use PDL::ImageRGB;
use PDL::Dbg;
use File::Temp qw(tempdir);
use File::Spec;

use strict;
use warnings;

# we need tests with index shuffling once vaffines are fixed
use Test::More;

sub tapprox {
	my($pa,$pb,$mdiff) = @_;
	all approx($pa, $pb,$mdiff || 0.01);
}

sub rpic_unlink {
  my $file = shift;
  my $pdl = PDL->rpic($file);
  unlink $file;
  return $pdl;
}

sub depends_on {
  note "ushort is ok with $_[0]\n"
	if $PDL::IO::Pic::converter{$_[0]}->{ushortok};
  return 1 if $PDL::IO::Pic::converter{$_[0]}->{ushortok};
  return 256;
}

sub mmax { return $_[0] > $_[1] ? $_[0] : $_[1] }

my $warned = 0;
sub tifftest {
  my ($form) = @_;
  return 0 unless $form eq 'TIFF';
  warn "WARNING: you are probably using buggy tiff converters.
     Check IO/Pnm/converters for patched source files\n" unless $warned;
  $warned = 1;
  return 1;
}

$PDL::debug = 0;
$PDL::IO::Pic::debug = 0;
my $iform = 'PNMRAW'; # change to PNMASCII to use ASCII PNM intermediate
                      # output format

#              [FORMAT, extension, ushort-divisor,
#               only RGB/no RGB/any (1/-1/0), mxdiff]
#  no test of PCX format because seems to be severely brain damaged
my %formats = ('PNM'  => ['pnm',1,0,0.01],
	       'GIF'  => ['gif',256,0,1.01],
	       'TIFF' => ['tif',1,0,0.01],
	       'RAST' => ['rast',256,0,0.01],
#	       'SGI'  => ['rgb',1,1,0.01],
 	       'PNG'  => ['png',1,1,0.01],
	      );

# only test PNM format
# netpbm has too many bugs on various platforms
my @allowed = ();
## for ('PNM') { push @allowed, $_
for (keys %formats) {
   if (PDL->rpiccan($_) && PDL->wpiccan($_) && defined $formats{$_}) {
      push @allowed, $_;
   }
}

my $ntests = 2 * (@allowed);
if ($ntests < 1) {
  plan skip_all => "No tests";
}

plan tests => $ntests;

note "Testable formats on this platform:\n".join(',',@allowed)."\n";

my $im1 = ushort pdl [[[0,0,0],[256,65535,256],[0,0,0]],
		     [[256,256,256],[256,256,256],[256,256,256]],
		     [[2560,65535,2560],[256,2560,2560],[65535,65534,65535]]];
my $im2 = byte ($im1/256);

if ($PDL::debug){
   note $im1;
   note $im2;
}

my $usherr = 0;
my $tmpdir = tempdir( CLEANUP => 1 );
sub tmpfile { File::Spec->catfile($tmpdir, $_[0]); }
foreach my $form (sort @allowed) {
    note "** testing $form format **\n";

    my $arr = $formats{$form};
    my $tushort = tmpfile("tushort.$arr->[0]");
    my $tbyte = tmpfile("tbyte.$arr->[0]");
    eval {
        $im1->wpic($tushort,{IFORM => $iform});
    };
    SKIP: {
        my $additional = '';
        if ($@ =~ /maxval is too large/) {
            $additional = ' (recompile pbmplus with PGM_BIGGRAYS!)';
        }
        skip "Error: '$@'$additional", 2 if $@;
        $im2->wpic($tbyte,{IFORM => $iform});

        my $in1 = rpic_unlink($tushort) unless $usherr;
        my $in2 = rpic_unlink($tbyte);

        my $comp = $im1 / PDL::ushort(mmax(depends_on($form),$arr->[1]));
        note "Comparison arr: $comp" if $PDL::debug;
        ok($usherr || tapprox($comp,$in1,$arr->[3]) || tifftest($form));
        ok(tapprox($im2,$in2) || tifftest($form));

        if ($PDL::debug) {
          note $in1->px;
          note $in2->px;
        }
    }
}

use Data::Dumper;
note "PDL::IO::Pic converter data:\n";
note Dumper(\%PDL::IO::Pic::converter);