flood_fill() wouldn't fill the right side of a single scan-line fill area.
[imager.git] / t / t38ft2font.t
1 #!perl -w
2 use strict;
3 use Test::More tests => 189;
4 use Cwd qw(getcwd abs_path);
5 ++$|;
6 # Before `make install' is performed this script should be runnable with
7 # `make test'. After `make install' it should work as `perl test.pl'
8
9 ######################### We start with some black magic to print on failure.
10
11 # Change 1..1 below to 1..last_test_to_print .
12 # (It may become useful if the test is moved to ./t subdirectory.)
13
14 BEGIN { use_ok(Imager => ':all') }
15
16 use Imager::Test qw(diff_text_with_nul is_color3);
17
18 init_log("testout/t38ft2font.log",2);
19
20 my $deffont = "fontfiles/dodge.ttf";
21
22 my @base_color = (64, 255, 64);
23
24 SKIP:
25 {
26   i_has_format("ft2") or skip("no freetype2 library found", 188);
27
28   print "# has ft2\n";
29   
30   my $fontname=$ENV{'TTFONTTEST'} || $deffont;
31
32   -f $fontname or skip("cannot find fontfile $fontname", 188);
33
34
35   my $bgcolor=i_color_new(255,0,0,0);
36   my $overlay=Imager::ImgRaw::new(200,70,3);
37   
38   my $ttraw=Imager::Font::FreeType2::i_ft2_new($fontname, 0);
39   
40   $ttraw or print Imager::_error_as_msg(),"\n";
41   ok($ttraw, "loaded raw font");
42
43   my @bbox=Imager::Font::FreeType2::i_ft2_bbox($ttraw, 50.0, 0, 'XMCLH', 0);
44   print "#bbox @bbox\n";
45   
46   is(@bbox, 8, "i_ft2_bbox() returns 8 values");
47
48   ok(Imager::Font::FreeType2::i_ft2_cp($ttraw,$overlay,5,50,1,50.0,50, 'XMCLH',1,1, 0, 0), "drawn to channel");
49   i_line($overlay,0,50,100,50,$bgcolor,1);
50
51   open(FH,">testout/t38ft2font.ppm") || die "cannot open testout/t38ft2font.ppm\n";
52   binmode(FH);
53   my $IO = Imager::io_new_fd(fileno(FH));
54   ok(i_writeppm_wiol($overlay, $IO), "saved image");
55   close(FH);
56
57   $bgcolor=i_color_set($bgcolor,200,200,200,0);
58   my $backgr=Imager::ImgRaw::new(500,300,3);
59   
60   #     i_tt_set_aa(2);
61   ok(Imager::Font::FreeType2::i_ft2_text($ttraw,$backgr,100,150,NC(255, 64, 64),200.0,50, 'MAW',1,1,0, 0), "drew MAW");
62   Imager::Font::FreeType2::i_ft2_settransform($ttraw, [0.9659, 0.2588, 0, -0.2588, 0.9659, 0 ]);
63   ok(Imager::Font::FreeType2::i_ft2_text($ttraw,$backgr,100,150,NC(0, 128, 0),200.0,50, 'MAW',0,1, 0, 0), "drew rotated MAW");
64   i_line($backgr, 0,150, 499, 150, NC(0, 0, 255),1);
65
66   open(FH,">testout/t38ft2font2.ppm") || die "cannot open testout/t38ft2font.ppm\n";
67   binmode(FH);
68   $IO = Imager::io_new_fd(fileno(FH));
69   ok(i_writeppm_wiol($backgr,$IO), "saved second image");
70   close(FH);
71
72   my $oof = Imager::Font->new(file=>$fontname, type=>'ft2', 'index'=>0);
73
74   ok($oof, "loaded OO font");
75
76   my $im = Imager->new(xsize=>400, ysize=>250);
77   
78   ok($im->string(font=>$oof,
79                  text=>"Via OO",
80                  'x'=>20,
81                  'y'=>20,
82                  size=>60,
83                  color=>NC(255, 128, 255),
84                  aa => 1,
85                  align=>0), "drawn through OO interface");
86   ok($oof->transform(matrix=>[1, 0.1, 0, 0, 1, 0]),
87      "set matrix via OO interface");
88   ok($im->string(font=>$oof,
89                  text=>"Shear",
90                  'x'=>20,
91                  'y'=>40,
92                  size=>60,
93                  sizew=>50,
94                  channel=>1,
95                  aa=>1,
96                  align=>1), "drawn transformed through OO");
97   use Imager::Matrix2d ':handy';
98   ok($oof->transform(matrix=>m2d_rotate(degrees=>-30)),
99      "set transform from m2d module");
100   ok($im->string(font=>$oof,
101                  text=>"SPIN",
102                  'x'=>20,
103                  'y'=>50,
104                  size=>50,
105                  sizew=>40,
106                  color=>NC(255,255,0),
107                  aa => 1,
108                  align=>0, vlayout=>0), "drawn first rotated");
109
110   ok($im->string(font=>$oof,
111                  text=>"SPIN",
112                  'x'=>20,
113                  'y'=>50,
114                  size=>50,
115                  sizew=>40,
116             channel=>2,
117                  aa => 1,
118                  align=>0, vlayout=>0), "drawn second rotated");
119   
120   $oof->transform(matrix=>m2d_identity());
121   $oof->hinting(hinting=>1);
122
123   # UTF8 testing
124   # the test font (dodge.ttf) only supports one character above 0xFF that
125   # I can see, 0x2010 HYPHEN (which renders the same as 0x002D HYPHEN MINUS)
126   # an attempt at utf8 support
127   # first attempt to use native perl UTF8
128  SKIP:
129   {
130     skip("no native UTF8 support in this version of perl", 1) 
131       unless $] >= 5.006;
132     my $text;
133     # we need to do this in eval to prevent compile time errors in older
134     # versions
135     eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
136     #$text = "A".chr(0x2010)."A"; # this one works too
137     unless (ok($im->string(font=>$oof,
138                            text=>$text,
139                            'x'=>20,
140                            'y'=>200,
141                            size=>50,
142                            color=>NC(0,255,0),
143                            aa=>1), "drawn UTF natively")) {
144       print "# ",$im->errstr,"\n";
145     }
146   }
147
148   # an attempt using emulation of UTF8
149   my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
150   #my $text = "A\xE2\x80\x90\x41\x{2010}";
151   #substr($text, -1, 0) = '';
152   unless (ok($im->string(font=>$oof,
153                          text=>$text,
154                          'x'=>20,
155                          'y'=>230,
156                          size=>50,
157                          color=>NC(255,128,0),
158                          aa=>1, 
159                          utf8=>1), "drawn UTF emulated")) {
160     print "# ",$im->errstr,"\n";
161   }
162
163   # just a bit of fun
164   # well it was - it demostrates what happens when you combine
165   # transformations and font hinting
166   for my $steps (0..39) {
167     $oof->transform(matrix=>m2d_rotate(degrees=>-$steps+5));
168     # demonstrates why we disable hinting on a doing a transform
169     # if the following line is enabled then the 0 degrees output sticks 
170     # out a bit
171     # $oof->hinting(hinting=>1);
172     $im->string(font=>$oof,
173                 text=>"SPIN",
174                 'x'=>160,
175                 'y'=>70,
176                 size=>65,
177                 color=>NC(255, $steps * 5, 200-$steps * 5),
178                 aa => 1,
179                 align=>0, );
180   }
181
182   $im->write(file=>'testout/t38_oo.ppm')
183     or print "# could not save OO output: ",$im->errstr,"\n";
184   
185   my (@got) = $oof->has_chars(string=>"\x01H");
186   ok(@got == 2, "has_chars returned 2 items");
187   ok(!$got[0], "have no chr(1)");
188   ok($got[1], "have 'H'");
189   is($oof->has_chars(string=>"H\x01"), "\x01\x00",
190      "scalar has_chars()");
191
192   print "# OO bounding boxes\n";
193   @bbox = $oof->bounding_box(string=>"hello", size=>30);
194   my $bbox = $oof->bounding_box(string=>"hello", size=>30);
195
196   is(@bbox, 8, "list bbox returned 8 items");
197   ok($bbox->isa('Imager::Font::BBox'), "scalar bbox returned right class");
198   ok($bbox->start_offset == $bbox[0], "start_offset");
199   ok($bbox->end_offset == $bbox[2], "end_offset");
200   ok($bbox->global_ascent == $bbox[3], "global_ascent");
201   ok($bbox->global_descent == $bbox[1], "global_descent");
202   ok($bbox->ascent == $bbox[5], "ascent");
203   ok($bbox->descent == $bbox[4], "descent");
204   ok($bbox->advance_width == $bbox[6], "advance_width");
205
206   print "# aligned text output\n";
207   my $alimg = Imager->new(xsize=>300, ysize=>300);
208   $alimg->box(color=>'40FF40', filled=>1);
209
210   $oof->transform(matrix=>m2d_identity());
211   $oof->hinting(hinting=>1);
212   
213   align_test('left', 'top', 10, 10, $oof, $alimg);
214   align_test('start', 'top', 10, 40, $oof, $alimg);
215   align_test('center', 'top', 150, 70, $oof, $alimg);
216   align_test('end', 'top', 290, 100, $oof, $alimg);
217   align_test('right', 'top', 290, 130, $oof, $alimg);
218
219   align_test('center', 'top', 150, 160, $oof, $alimg);
220   align_test('center', 'center', 150, 190, $oof, $alimg);
221   align_test('center', 'bottom', 150, 220, $oof, $alimg);
222   align_test('center', 'baseline', 150, 250, $oof, $alimg);
223   
224   ok($alimg->write(file=>'testout/t38aligned.ppm'), 
225      "saving aligned output image");
226   
227   my $exfont = Imager::Font->new(file=>'fontfiles/ExistenceTest.ttf',
228                                  type=>'ft2');
229   SKIP:
230   {
231     ok($exfont, "loaded existence font") or
232       skip("couldn't load test font", 11);
233
234     # the test font is known to have a shorter advance width for that char
235     my @bbox = $exfont->bounding_box(string=>"/", size=>100);
236     is(@bbox, 8, "should be 8 entries");
237     isnt($bbox[6], $bbox[2], "different advance width");
238     my $bbox = $exfont->bounding_box(string=>"/", size=>100);
239     ok($bbox->pos_width != $bbox->advance_width, "OO check");
240
241     cmp_ok($bbox->right_bearing, '<', 0, "check right bearing");
242
243     cmp_ok($bbox->display_width, '>', $bbox->advance_width,
244            "check display width (roughly)");
245
246     # check with a char that fits inside the box
247     $bbox = $exfont->bounding_box(string=>"!", size=>100);
248     print "# pos width ", $bbox->pos_width, "\n";
249     is($bbox->pos_width, $bbox->advance_width, 
250        "check backwards compatibility");
251     cmp_ok($bbox->left_bearing, '>', 0, "left bearing positive");
252     cmp_ok($bbox->right_bearing, '>', 0, "right bearing positive");
253     cmp_ok($bbox->display_width, '<', $bbox->advance_width,
254            "display smaller than advance");
255
256     # name tests
257     # make sure the number of tests on each branch match
258     if (Imager::Font::FreeType2::i_ft2_can_face_name()) {
259       my $facename = Imager::Font::FreeType2::i_ft2_face_name($exfont->{id});
260       print "# face name '$facename'\n";
261       is($facename, 'ExistenceTest', "test face name");
262       $facename = $exfont->face_name;
263       is($facename, 'ExistenceTest', "test face name OO");
264     }
265     else {
266       # make sure we get the error we expect
267       my $facename = Imager::Font::FreeType2::i_ft2_face_name($exfont->{id});
268       my ($msg) = Imager::_error_as_msg();
269       ok(!defined($facename), "test face name not supported");
270       print "# $msg\n";
271       ok(scalar($msg =~ /or later required/), "test face name not supported");
272     }
273   }
274
275   SKIP:
276   {
277     Imager::Font::FreeType2->can_glyph_names
278         or skip("FT2 compiled without glyph names support", 9);
279         
280     # FT2 considers POST tables in TTF fonts unreliable, so use
281     # a type 1 font, see below for TTF test 
282     my $exfont = Imager::Font->new(file=>'fontfiles/ExistenceTest.pfb',
283                                type=>'ft2');
284   SKIP:
285     {
286       ok($exfont, "load Type 1 via FT2")
287         or skip("couldn't load type 1 with FT2", 8);
288       my @glyph_names = 
289         Imager::Font::FreeType2::i_ft2_glyph_name($exfont->{id}, "!J/");
290       #use Data::Dumper;
291       #print Dumper \@glyph_names;
292       is($glyph_names[0], 'exclam', "check exclam name");
293       ok(!defined($glyph_names[1]), "check for no J name");
294       is($glyph_names[2], 'slash', "check slash name");
295
296       # oo interfaces
297       @glyph_names = $exfont->glyph_names(string=>"!J/");
298       is($glyph_names[0], 'exclam', "check exclam name OO");
299       ok(!defined($glyph_names[1]), "check for no J name OO");
300       is($glyph_names[2], 'slash', "check slash name OO");
301
302       # make sure a missing string parameter is handled correctly
303       eval {
304         $exfont->glyph_names();
305       };
306       is($@, "", "correct error handling");
307       cmp_ok(Imager->errstr, '=~', qr/no string parameter/, "error message");
308     }
309   
310     # freetype 2 considers truetype glyph name tables unreliable
311     # due to some specific fonts, supplying reliable_only=>0 bypasses
312     # that check and lets us get the glyph names even for truetype fonts
313     # so we can test this stuff <sigh>
314     # we can't use ExistenceTest.ttf since that's generated with 
315     # AppleStandardEncoding since the same .sfd needs to generate
316     # a .pfb file, NameTest.ttf uses a Unicode encoding
317     
318     # we were using an unsigned char to store a unicode character
319     # https://rt.cpan.org/Ticket/Display.html?id=7949
320     $exfont = Imager::Font->new(file=>'fontfiles/NameTest.ttf',
321                                 type=>'ft2');
322   SKIP:
323     {
324       ok($exfont, "load TTF via FT2")
325         or skip("could not load TTF with FT2", 1);
326       my $text = pack("C*", 0xE2, 0x80, 0x90); # "\x{2010}" as utf-8
327       my @names = $exfont->glyph_names(string=>$text,
328                                        utf8=>1, reliable_only=>0);
329       is($names[0], "hyphentwo", "check utf8 glyph name");
330     }
331   }
332
333   # check that error codes are translated correctly
334   my $errfont = Imager::Font->new(file=>"t/t38ft2font.t", type=>"ft2");
335   is($errfont, undef, "new font vs non font");
336   cmp_ok(Imager->errstr, '=~', qr/unknown file format/, "check error message");
337
338   # Multiple Master tests
339   # we check a non-MM font errors correctly
340   print "# check that the methods act correctly for a non-MM font\n";
341   ok(!$exfont->is_mm, "exfont not MM");
342   ok((() = $exfont->mm_axes) == 0, "exfont has no MM axes");
343   cmp_ok(Imager->errstr, '=~', qr/no multiple masters/, 
344          "and returns correct error when we ask");
345   ok(!$exfont->set_mm_coords(coords=>[0, 0]), "fail setting axis on exfont");
346   cmp_ok(Imager->errstr, '=~', qr/no multiple masters/, 
347          "and returns correct error when we ask");
348
349   # try a MM font now - test font only has A defined
350   print "# Try a multiple master font\n";
351   my $mmfont = Imager::Font->new(file=>"fontfiles/MMOne.pfb", type=>"ft2", 
352                                  color=>"white", aa=>1, size=>60);
353   ok($mmfont, "loaded MM font");
354   ok($mmfont->is_mm, "font is multiple master");
355   my @axes = $mmfont->mm_axes;
356   is(@axes, 2, "check we got both axes");
357   is($axes[0][0], "Weight", "name of first axis");
358   is($axes[0][1],  50, "min for first axis");
359   is($axes[0][2], 999, "max for first axis");
360   is($axes[1][0], "Slant", "name of second axis");
361   is($axes[1][1],   0, "min for second axis");
362   is($axes[1][2], 999, "max for second axis");
363   my $mmim = Imager->new(xsize=>200, ysize=>200);
364   $mmim->string(font=>$mmfont, x=>0, 'y'=>50, text=>"A");
365   ok($mmfont->set_mm_coords(coords=>[ 700, 0 ]), "set to bold, unsloped");
366   $mmim->string(font=>$mmfont, x=>0, 'y'=>100, text=>"A", color=>'blue');
367   my @weights = qw(50 260 525 760 999);
368   my @slants = qw(0 333 666 999);
369   for my $windex (0 .. $#weights) {
370     my $weight = $weights[$windex];
371     for my $sindex (0 .. $#slants) {
372       my $slant = $slants[$sindex];
373       $mmfont->set_mm_coords(coords=>[ $weight, $slant ]);
374       $mmim->string(font=>$mmfont, x=>30+32*$windex, 'y'=>50+45*$sindex,
375                     text=>"A");
376     }
377   }
378
379   ok($mmim->write(file=>"testout/t38mm.ppm"), "save MM output");
380
381  SKIP:
382   { print "# alignment tests\n";
383     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
384     ok($font, "loaded deffont OO")
385       or skip("could not load font:".Imager->errstr, 4);
386     my $im = Imager->new(xsize=>140, ysize=>150);
387     my %common = 
388       (
389        font=>$font, 
390        size=>40, 
391        aa=>1,
392       );
393     $im->line(x1=>0, y1=>40, x2=>139, y2=>40, color=>'blue');
394     $im->line(x1=>0, y1=>90, x2=>139, y2=>90, color=>'blue');
395     $im->line(x1=>0, y1=>110, x2=>139, y2=>110, color=>'blue');
396     for my $args ([ x=>5,   text=>"A", color=>"white" ],
397                   [ x=>40,  text=>"y", color=>"white" ],
398                   [ x=>75,  text=>"A", channel=>1 ],
399                   [ x=>110, text=>"y", channel=>1 ]) {
400       ok($im->string(%common, @$args, 'y'=>40), "A no alignment");
401       ok($im->string(%common, @$args, 'y'=>90, align=>1), "A align=1");
402       ok($im->string(%common, @$args, 'y'=>110, align=>0), "A align=0");
403     }
404     ok($im->write(file=>'testout/t38align.ppm'), "save align image");
405   }
406
407
408   { # outputting a space in non-AA could either crash 
409     # or fail (ft 2.2+)
410     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
411     my $im = Imager->new(xsize => 100, ysize => 100);
412     ok($im->string(x => 10, y => 10, string => "test space", aa => 0,
413                    color => '#FFF', size => 8, font => $font),
414        "draw space non-antialiased (color)");
415     ok($im->string(x => 10, y => 50, string => "test space", aa => 0,
416                    channel => 0, size => 8, font => $font),
417        "draw space non-antialiased (channel)");
418   }
419
420   { # cannot output "0"
421     # https://rt.cpan.org/Ticket/Display.html?id=21770
422     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
423     ok($font, "loaded imugly");
424     my $imbase = Imager->new(xsize => 100, ysize => 100);
425     my $im = $imbase->copy;
426     ok($im->string(x => 10, y => 50, string => "0", aa => 0,
427                    color => '#FFF', size => 20, font => $font),
428        "draw '0'");
429     ok(Imager::i_img_diff($im->{IMG}, $imbase->{IMG}),
430        "make sure we actually drew it");
431     $im = $imbase->copy;
432     ok($im->string(x => 10, y => 50, string => 0.0, aa => 0,
433                    color => '#FFF', size => 20, font => $font),
434        "draw 0.0");
435     ok(Imager::i_img_diff($im->{IMG}, $imbase->{IMG}),
436        "make sure we actually drew it");
437   }
438   { # string output cut off at NUL ('\0')
439     # https://rt.cpan.org/Ticket/Display.html?id=21770 cont'd
440     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
441     ok($font, "loaded imugly");
442
443     diff_text_with_nul("a\\0b vs a", "a\0b", "a", 
444                        font => $font, color => '#FFFFFF');
445     diff_text_with_nul("a\\0b vs a", "a\0b", "a", 
446                        font => $font, channel => 1);
447
448     # UTF8 encoded \x{2010}
449     my $dash = pack("C*", 0xE2, 0x80, 0x90);
450     diff_text_with_nul("utf8 dash\0dash vs dash", "$dash\0$dash", $dash,
451                        font => $font, color => '#FFFFFF', utf8 => 1);
452     diff_text_with_nul("utf8 dash\0dash vs dash", "$dash\0$dash", $dash,
453                        font => $font, channel => 1, utf8 => 1);
454   }
455
456   { # RT 11972
457     # when rendering to a transparent image the coverage should be
458     # expressed in terms of the alpha channel rather than the color
459     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
460     my $im = Imager->new(xsize => 40, ysize => 20, channels => 4);
461     ok($im->string(string => "AB", size => 20, aa => 1, color => '#F00',
462                    x => 0, y => 15, font => $font),
463        "draw to transparent image");
464     my $im_noalpha = $im->convert(preset => 'noalpha');
465     my $im_pal = $im->to_paletted(make_colors => 'mediancut');
466     my @colors = $im_pal->getcolors;
467     is(@colors, 2, "should be only 2 colors");
468     @colors = sort { ($a->rgba)[0] <=> ($b->rgba)[0] } @colors;
469     is_color3($colors[0], 0, 0, 0, "check we got black");
470     is_color3($colors[1], 255, 0, 0, "and red");
471   }
472
473   { # RT 27546
474     my $im = Imager->new(xsize => 100, ysize => 100, channels => 4);
475     $im->box(filled => 1, color => '#ff0000FF');
476     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
477     ok($im->string(x => 0, 'y' => 40, text => 'test', 
478                    size => 11, sizew => 11, font => $font, aa => 1),
479        'draw on translucent image')
480   }
481
482   { # RT 60199
483     # not ft2 specific, but Imager
484     my $im = Imager->new(xsize => 100, ysize => 100);
485     my $font = Imager::Font->new(file=>'fontfiles/ImUgly.ttf', type=>'ft2');
486     my $imcopy = $im->copy;
487     ok($im, "make test image");
488     ok($font, "make test font");
489     ok($im->align_string(valign => "center", halign => "center",
490                          x => 50, y => 50, string => "0", color => "#FFF",
491                          font => $font),
492        "draw 0 aligned");
493     ok(Imager::i_img_diff($im->{IMG}, $imcopy->{IMG}),
494        "make sure we drew the '0'");
495   }
496
497  SKIP:
498   { # RT 60509
499     # checks that a c:foo or c:\foo path is handled correctly on win32
500     my $type = "ft2";
501     $^O eq "MSWin32" || $^O eq "cygwin"
502       or skip("only for win32", 2);
503     my $dir = getcwd
504       or skip("Cannot get cwd", 2);
505     if ($^O eq "cygwin") {
506       $dir = Cygwin::posix_to_win_path($dir);
507     }
508     my $abs_path = abs_path($deffont);
509     my $font = Imager::Font->new(file => $abs_path, type => $type);
510     ok($font, "found font by absolute path")
511       or print "# path $abs_path\n";
512     undef $font;
513
514     $^O eq "cygwin"
515       and skip("cygwin doesn't support drive relative DOSsish paths", 1);
516     my ($drive) = $dir =~ /^([a-z]:)/i
517       or skip("cwd has no drive letter", 2);
518     my $drive_path = $drive . $deffont;
519     $font = Imager::Font->new(file => $drive_path, type => $type);
520     ok($font, "found font by drive relative path")
521       or print "# path $drive_path\n";
522   }
523
524 }
525
526 sub align_test {
527   my ($h, $v, $x, $y, $f, $img) = @_;
528
529   my @pos = $f->align(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
530                       image=>$img, size=>15, color=>'FFFFFF',
531                       string=>"x$h ${v}y", channel=>1, aa=>1);
532   @pos = $img->align_string(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
533                       font=>$f, size=>15, color=>'FF99FF',
534                       string=>"x$h ${v}y", aa=>1);
535   if (ok(@pos == 4, "$h $v aligned output")) {
536     # checking corners
537     my $cx = int(($pos[0] + $pos[2]) / 2);
538     my $cy = int(($pos[1] + $pos[3]) / 2);
539     
540     print "# @pos cx $cx cy $cy\n";
541     okmatchcolor($img, $cx, $pos[1]-1, @base_color, "outer top edge");
542     okmatchcolor($img, $cx, $pos[3], @base_color, "outer bottom edge");
543     okmatchcolor($img, $pos[0]-1, $cy, @base_color, "outer left edge");
544     okmatchcolor($img, $pos[2], $cy, @base_color, "outer right edge");
545     
546     okmismatchcolor($img, $cx, $pos[1], @base_color, "inner top edge");
547     okmismatchcolor($img, $cx, $pos[3]-1, @base_color, "inner bottom edge");
548     okmismatchcolor($img, $pos[0], $cy, @base_color, "inner left edge");
549 #    okmismatchcolor($img, $pos[2]-1, $cy, @base_color, "inner right edge");
550 # XXX: This gets triggered by a freetype2 bug I think 
551 #    $ rpm -qa | grep freetype
552 #    freetype-2.1.3-6
553 #
554 # (addi: 4/1/2004).
555
556     cross($img, $x, $y, 'FF0000');
557     cross($img, $cx, $pos[1]-1, '0000FF');
558     cross($img, $cx, $pos[3], '0000FF');
559     cross($img, $pos[0]-1, $cy, '0000FF');
560     cross($img, $pos[2], $cy, '0000FF');
561   }
562   else {
563     SKIP: { skip("couldn't draw text", 7) };
564   }
565 }
566
567 sub okmatchcolor {
568   my ($img, $x, $y, $r, $g, $b, $about) = @_;
569
570   my $c = $img->getpixel('x'=>$x, 'y'=>$y);
571   my ($fr, $fg, $fb) = $c->rgba;
572   ok($fr == $r && $fg == $g && $fb == $b,
573       "want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
574 }
575
576 sub okmismatchcolor {
577   my ($img, $x, $y, $r, $g, $b, $about) = @_;
578
579   my $c = $img->getpixel('x'=>$x, 'y'=>$y);
580   my ($fr, $fg, $fb) = $c->rgba;
581   ok($fr != $r || $fg != $g || $fb != $b,
582       "don't want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
583 }
584
585 sub cross {
586   my ($img, $x, $y, $color) = @_;
587
588   $img->setpixel('x'=>[$x, $x, $x, $x, $x, $x-2, $x-1, $x+1, $x+2], 
589                  'y'=>[$y-2, $y-1, $y, $y+1, $y+2, $y, $y, $y, $y], 
590                  color => $color);
591   
592 }