Various changes:
[imager.git] / lib / Imager / Test.pm
1 package Imager::Test;
2 use strict;
3 use Test::Builder;
4 require Exporter;
5 use vars qw(@ISA @EXPORT_OK);
6 @ISA = qw(Exporter);
7 @EXPORT_OK = qw(diff_text_with_nul test_image_raw test_image_16 is_color3 is_color1 is_image);
8
9 sub diff_text_with_nul {
10   my ($desc, $text1, $text2, @params) = @_;
11
12   my $builder = Test::Builder->new;
13
14   print "# $desc\n";
15   my $imbase = Imager->new(xsize => 100, ysize => 100);
16   my $imcopy = Imager->new(xsize => 100, ysize => 100);
17
18   $builder->ok($imbase->string(x => 5, 'y' => 50, size => 20,
19                                string => $text1,
20                                @params), "$desc - draw text1");
21   $builder->ok($imcopy->string(x => 5, 'y' => 50, size => 20,
22                                string => $text2,
23                                @params), "$desc - draw text2");
24   $builder->isnt_num(Imager::i_img_diff($imbase->{IMG}, $imcopy->{IMG}), 0,
25                      "$desc - check result different");
26 }
27
28 sub is_color3($$$$$) {
29   my ($color, $red, $green, $blue, $comment) = @_;
30
31   my $builder = Test::Builder->new;
32
33   unless (defined $color) {
34     $builder->ok(0, $comment);
35     $builder->diag("color is undef");
36     return;
37   }
38   unless ($color->can('rgba')) {
39     $builder->ok(0, $comment);
40     $builder->diag("color is not a color object");
41     return;
42   }
43
44   my ($cr, $cg, $cb) = $color->rgba;
45   unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) {
46     $builder->diag(<<END_DIAG);
47 Color mismatch:
48   Red: $red vs $cr
49 Green: $green vs $cg
50  Blue: $blue vs $cb
51 END_DIAG
52     return;
53   }
54
55   return 1;
56 }
57
58 sub is_color1($$$) {
59   my ($color, $grey, $comment) = @_;
60
61   my $builder = Test::Builder->new;
62
63   unless (defined $color) {
64     $builder->ok(0, $comment);
65     $builder->diag("color is undef");
66     return;
67   }
68   unless ($color->can('rgba')) {
69     $builder->ok(0, $comment);
70     $builder->diag("color is not a color object");
71     return;
72   }
73
74   my ($cgrey) = $color->rgba;
75   unless ($builder->ok($cgrey == $grey, $comment)) {
76     $builder->diag(<<END_DIAG);
77 Color mismatch:
78   Grey: $grey vs $cgrey
79 END_DIAG
80     return;
81   }
82
83   return 1;
84 }
85
86 sub test_image_raw {
87   my $green=Imager::i_color_new(0,255,0,255);
88   my $blue=Imager::i_color_new(0,0,255,255);
89   my $red=Imager::i_color_new(255,0,0,255);
90   
91   my $img=Imager::ImgRaw::new(150,150,3);
92   
93   Imager::i_box_filled($img,70,25,130,125,$green);
94   Imager::i_box_filled($img,20,25,80,125,$blue);
95   Imager::i_arc($img,75,75,30,0,361,$red);
96   Imager::i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
97
98   $img;
99 }
100
101 sub test_image_16 {
102   my $green = Imager::Color->new(0, 255, 0, 255);
103   my $blue  = Imager::Color->new(0, 0, 255, 255);
104   my $red   = Imager::Color->new(255, 0, 0, 255);
105   my $img = Imager->new(xsize => 150, ysize => 150, bits => 16);
106   $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
107   $img->box(filled => 1, color => $blue,  box => [ 20, 25, 80, 125 ]);
108   $img->arc(x => 75, y => 75, r => 30, color => $red);
109   $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
110
111   $img;
112 }
113
114 sub is_image($$$) {
115   my ($left, $right, $comment) = @_;
116
117   my $builder = Test::Builder->new;
118
119   unless (defined $left) {
120     $builder->ok(0, $comment);
121     $builder->diag("left is undef");
122     return;
123   } 
124   unless (defined $right) {
125     $builder->ok(0, $comment);
126     $builder->diag("right is undef");
127     return;
128   }
129   unless ($left->{IMG}) {
130     $builder->ok(0, $comment);
131     $builder->diag("left image has no low level object");
132     return;
133   }
134   unless ($right->{IMG}) {
135     $builder->ok(0, $comment);
136     $builder->diag("right image has no low level object");
137     return;
138   }
139   unless ($left->getwidth == $right->getwidth) {
140     $builder->ok(0, $comment);
141     $builder->diag("left width " . $left->getwidth . " vs right width " 
142                    . $right->getwidth);
143     return;
144   }
145   unless ($left->getheight == $right->getheight) {
146     $builder->ok(0, $comment);
147     $builder->diag("left height " . $left->getheight . " vs right height " 
148                    . $right->getheight);
149     return;
150   }
151   unless ($left->getchannels == $right->getchannels) {
152     $builder->ok(0, $comment);
153     $builder->diag("left channels " . $left->getchannels . " vs right channels " 
154                    . $right->getchannels);
155     return;
156   }
157   my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
158   unless ($diff == 0) {
159     $builder->ok(0, $comment);
160     $builder->diag("image data different - $diff");
161     return;
162   }
163   
164   return $builder->ok(1, $comment);
165 }
166
167 1;
168
169 __END__
170
171 =head1 NAME
172
173 Imager::Test - common functions used in testing Imager
174
175 =head1 SYNOPSIS
176
177   use Imager::Test 'diff_text_with_nul';
178   diff_text_with_nul($test_name, $text1, $text2, @string_options);
179
180 =head1 DESCRIPTION
181
182 This is a repository of functions used in testing Imager.
183
184 Some functions will only be useful in testing Imager itself, while
185 others should be useful in testing modules that use Imager.
186
187 No functions are exported by default.
188
189 =head1 FUNCTIONS
190
191 =over
192
193 =item is_color3($color, $red, $blue, $green, $comment)
194
195 Tests is $color matches the given ($red, $blue, $green)
196
197 =item test_image_raw()
198
199 Returns a 150x150x3 Imager::ImgRaw test image.
200
201 =item test_image_16()
202
203 Returns a 150x150x3 16-bit/sample OO test image.
204
205 =item diff_text_with_nul($test_name, $text1, $text2, @options)
206
207 Creates 2 test images and writes $text1 to the first image and $text2
208 to the second image with the string() method.  Each call adds 3 ok/not
209 ok to the output of the test script.
210
211 Extra options that should be supplied include the font and either a
212 color or channel parameter.
213
214 This was explicitly created for regression tests on #21770.
215
216 =back
217
218 =head1 AUTHOR
219
220 Tony Cook <tony@develop-help.com>
221
222 =cut