add X org dist's rgb.txt location to search path
[imager.git] / lib / Imager / Test.pm
CommitLineData
9a6ab99c
TC
1package Imager::Test;
2use strict;
3use Test::Builder;
4require Exporter;
5use vars qw(@ISA @EXPORT_OK);
6@ISA = qw(Exporter);
9c106321 7@EXPORT_OK = qw(diff_text_with_nul test_image_raw test_image_16 is_color3 is_color1 is_image);
9a6ab99c
TC
8
9sub 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
9c106321
TC
28sub 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);
47Color mismatch:
48 Red: $red vs $cr
49Green: $green vs $cg
50 Blue: $blue vs $cb
51END_DIAG
52 return;
53 }
54
55 return 1;
56}
57
58sub 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);
77Color mismatch:
78 Grey: $grey vs $cgrey
79END_DIAG
80 return;
81 }
82
83 return 1;
84}
85
86sub 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
101sub 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
114sub 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
9a6ab99c
TC
1671;
168
169__END__
170
171=head1 NAME
172
173Imager::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
182This is a repository of functions used in testing Imager.
183
184Some functions will only be useful in testing Imager itself, while
185others should be useful in testing modules that use Imager.
186
187No functions are exported by default.
188
189=head1 FUNCTIONS
190
191=over
192
9c106321
TC
193=item is_color3($color, $red, $blue, $green, $comment)
194
195Tests is $color matches the given ($red, $blue, $green)
196
ae12796a
TC
197=item is_image($im1, $im2, $comment)
198
199Tests if the 2 images have the same content. Both images must be
200defined, have the same width, height, channels and the same color in
201each pixel. The color comparison is done at 8-bits per pixel. The
202color representation such as direct vs paletted, bits per sample are
203not checked.
204
9c106321
TC
205=item test_image_raw()
206
207Returns a 150x150x3 Imager::ImgRaw test image.
208
209=item test_image_16()
210
211Returns a 150x150x3 16-bit/sample OO test image.
212
213=item diff_text_with_nul($test_name, $text1, $text2, @options)
9a6ab99c
TC
214
215Creates 2 test images and writes $text1 to the first image and $text2
216to the second image with the string() method. Each call adds 3 ok/not
217ok to the output of the test script.
218
219Extra options that should be supplied include the font and either a
220color or channel parameter.
221
222This was explicitly created for regression tests on #21770.
223
224=back
225
226=head1 AUTHOR
227
228Tony Cook <tony@develop-help.com>
229
230=cut