3661b45ef63e49e9a3b51d63156f2349ab00525d
[imager.git] / t / t67convert.t
1 #!perl -w
2 use strict;
3 use Imager qw(:all :handy);
4 use Test::More tests=>19;
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 my $imnew = Imager::i_img_new();
14 SKIP:
15 {
16   skip("convert to white failed", 3)
17     unless ok(i_convert($imnew, $imbase, [ [ 0, 0, 0, 1 ] ]), "convert to white");
18
19   my ($w, $h, $ch) = i_img_info($imnew);
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($imnew, 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 my $im16targ = Imager::i_img_16_new(200, 300, 3);
53 SKIP:
54 {
55   skip("could not convert 16-bit image", 2)
56     unless ok(i_convert($im16targ, $imbase, [ [ 0, 0, 0, 1 ],
57                                               [ 0, 0, 0, 0 ],
58                                               [ 0, 0, 0, 0 ] ]),
59               "convert 16/bit sample image");
60   # image should still be 16-bit
61   is(Imager::i_img_bits($im16targ), 16, "Image still 16-bit/sample");
62   # make sure that it's roughly red
63   my $c = Imager::i_gpixf($im16targ, 0, 0);
64   my @ch = $c->rgba;
65   ok(abs($ch[0] - 1) <= 0.0001 && abs($ch[1]) <= 0.0001 && abs($ch[2]) <= 0.0001,
66      "image roughly red");
67 }
68
69 # test against palette based images
70 my $impal = Imager::i_img_pal_new(200, 300, 3, 256);
71 my $black = NC(0, 0, 0);
72 my $blackindex = Imager::i_addcolors($impal, $black);
73 ok($blackindex, "add black to paletted");
74 for my $y (0..299) {
75   Imager::i_ppal($impal, 0, $y, ($blackindex) x 200);
76 }
77 my $impalout = Imager::i_img_pal_new(200, 300, 3, 256);
78 SKIP:
79 {
80   skip("could not convert paletted", 3)
81     unless ok(i_convert($impalout, $impal, [ [ 0, 0, 0, 0 ],
82                                    [ 0, 0, 0, 1 ],
83                                    [ 0, 0, 0, 0 ] ]),
84              "convert paletted");
85   is(Imager::i_img_type($impalout), 1, "image still paletted");
86   is(Imager::i_colorcount($impalout), 1, "still only one colour");
87   my $c = Imager::i_getcolors($impalout, $blackindex);
88   ok($c, "get color from palette");
89   my @ch = $c->rgba;
90   print "# @ch\n";
91   ok($ch[0] == 0 && $ch[1] == 255 && $ch[2] == 0, 
92      "colour is as expected");
93 }
94
95 { # http://rt.cpan.org/NoAuth/Bug.html?id=9672
96   my $warning;
97   local $SIG{__WARN__} = 
98     sub { 
99       $warning = "@_";
100       my $printed = $warning;
101       $printed =~ s/\n$//;
102       $printed =~ s/\n/\n\#/g; 
103       print "# ",$printed, "\n";
104     };
105   my $img = Imager->new(xsize=>10, ysize=>10);
106   $img->convert(preset=>"grey");
107   cmp_ok($warning, '=~', 'void', "correct warning");
108   cmp_ok($warning, '=~', 't67convert\\.t', "correct file");
109 }