- Finished/rewrote Arnar's old SGI RGB file format support, so Imager
[imager.git] / t / t67convert.t
1 #!perl -w
2 use strict;
3 use Imager qw(:all :handy);
4 use Test::More tests=>21;
5
6 Imager::init("log"=>'testout/t67convert.log');
7
8 my $imbase = Imager::ImgRaw::new(200,300,3);
9
10 # first a basic test, make sure the basic things happen ok
11 # make a 1 channel image from the above (black) image
12 # but with 1 as the 'extra' value
13 SKIP:
14 {
15   my $im_white = i_convert($imbase, [ [ 0, 0, 0, 1 ] ]);
16   skip("convert to white failed", 3)
17     unless ok($im_white, "convert to white");
18
19   my ($w, $h, $ch) = i_img_info($im_white);
20
21   # the output image should now have one channel
22   is($ch, 1, "one channel image now");
23   # should have the same width and height
24   ok($w == 200 && $h == 300, "check converted size is the same");
25
26   # should be a white image now, let's check
27   my $c = Imager::i_get_pixel($im_white, 20, 20);
28   my @c = $c->rgba;
29   print "# @c\n";
30   is($c[0], 255, "check image is white");
31 }
32
33 # test the highlevel interface
34 # currently this requires visual inspection of the output files
35 my $im = Imager->new;
36 SKIP:
37 {
38   skip("could not load scale.ppm", 3)
39     unless $im->read(file=>'testimg/scale.ppm');
40   my $out = $im->convert(preset=>'gray');
41   ok($out, "convert preset gray");
42   ok($out->write(file=>'testout/t67_gray.ppm', type=>'pnm'),
43     "save grey image");
44   $out = $im->convert(preset=>'blue');
45   ok($out, "convert preset blue");
46
47   ok($out->write(file=>'testout/t67_blue.ppm', type=>'pnm'),
48      "save blue image");
49 }
50
51 # test against 16-bit/sample images
52 SKIP:
53 {
54   my $imbase16 = Imager::i_img_16_new(200, 200, 3);
55   
56   my $im16targ = i_convert($imbase16, [ [ 0, 0, 0, 1 ],
57                                         [ 0, 0, 0, 0 ],
58                                         [ 0, 0, 0, 0 ] ]);
59   skip("could not convert 16-bit image", 2)
60     unless ok($im16targ, "convert 16/bit sample image");
61   # image should still be 16-bit
62   is(Imager::i_img_bits($im16targ), 16, "Image still 16-bit/sample");
63   # make sure that it's roughly red
64   my $c = Imager::i_gpixf($im16targ, 0, 0);
65   my @ch = $c->rgba;
66   ok(abs($ch[0] - 1) <= 0.0001 && abs($ch[1]) <= 0.0001 && abs($ch[2]) <= 0.0001,
67      "image roughly red")
68     or print "# @ch\n";
69 }
70
71 # test against palette based images
72 my $impal = Imager::i_img_pal_new(200, 300, 3, 256);
73 my $black = NC(0, 0, 0);
74 my $blackindex = Imager::i_addcolors($impal, $black);
75 ok($blackindex, "add black to paletted");
76 for my $y (0..299) {
77   Imager::i_ppal($impal, 0, $y, ($blackindex) x 200);
78 }
79
80 SKIP:
81 {
82   my $impalout = i_convert($impal, [ [ 0, 0, 0, 0 ],
83                                      [ 0, 0, 0, 1 ],
84                                      [ 0, 0, 0, 0 ] ]);
85   skip("could not convert paletted", 3)
86     unless ok($impalout, "convert paletted");
87   is(Imager::i_img_type($impalout), 1, "image still paletted");
88   is(Imager::i_colorcount($impalout), 1, "still only one colour");
89   my $c = Imager::i_getcolors($impalout, $blackindex);
90   ok($c, "get color from palette");
91   my @ch = $c->rgba;
92   print "# @ch\n";
93   ok($ch[0] == 0 && $ch[1] == 255 && $ch[2] == 0, 
94      "colour is as expected");
95 }
96
97 { # http://rt.cpan.org/NoAuth/Bug.html?id=9672
98   my $warning;
99   local $SIG{__WARN__} = 
100     sub { 
101       $warning = "@_";
102       my $printed = $warning;
103       $printed =~ s/\n$//;
104       $printed =~ s/\n/\n\#/g; 
105       print "# ",$printed, "\n";
106     };
107   my $img = Imager->new(xsize=>10, ysize=>10);
108   $img->convert(preset=>"grey");
109   cmp_ok($warning, '=~', 'void', "correct warning");
110   cmp_ok($warning, '=~', 't67convert\\.t', "correct file");
111 }
112
113 { # http://rt.cpan.org/NoAuth/Bug.html?id=28492
114   my $im = Imager->new(xsize => 20, ysize => 20, channels => 3, 
115                        bits => 'double');
116   is($im->bits, 'double', 'check source bits');
117   my $conv = $im->convert(preset => 'grey');
118   is($conv->bits, 'double', 'make sure result has extra bits');
119 }