All the little fixup changes for the 0.42 release.
[imager.git] / t / t38ft2font.t
1 #!perl -w
2 # Before `make install' is performed this script should be runnable with
3 # `make test'. After `make install' it should work as `perl test.pl'
4
5 ######################### We start with some black magic to print on failure.
6
7 # Change 1..1 below to 1..last_test_to_print .
8 # (It may become useful if the test is moved to ./t subdirectory.)
9
10 BEGIN { $| = 1; print "1..116\n"; }
11 END {print "not ok 1\n" unless $loaded;}
12 use Imager qw(:all);
13
14 require "t/testtools.pl";
15 $loaded = 1;
16 okx(1, "loaded");
17
18 init_log("testout/t38ft2font.log",2);
19
20 if (!(i_has_format("ft2")) ) { 
21   skipx(124, "No freetype2 library found");
22   exit;
23 }
24 print "# has ft2\n";
25
26 $fontname=$ENV{'TTFONTTEST'}||'./fontfiles/dodge.ttf';
27
28 if (! -f $fontname) {
29   skipx(124, "cannot find fontfile $fontname");
30   malloc_state();
31   exit;
32 }
33
34 #i_init_fonts();
35 #     i_tt_set_aa(1);
36
37 $bgcolor=i_color_new(255,0,0,0);
38 $overlay=Imager::ImgRaw::new(200,70,3);
39
40 $ttraw=Imager::Font::FreeType2::i_ft2_new($fontname, 0);
41
42 $ttraw or print Imager::_error_as_msg(),"\n";
43 okx($ttraw, "loaded raw font");
44 #use Data::Dumper;
45 #warn Dumper($ttraw);
46
47 @bbox=Imager::Font::FreeType2::i_ft2_bbox($ttraw, 50.0, 0, 'XMCLH', 0);
48 print "#bbox @bbox\n";
49
50 okx(@bbox == 7, "i_ft2_bbox() returns 7 values");
51
52 okx(Imager::Font::FreeType2::i_ft2_cp($ttraw,$overlay,5,50,1,50.0,50, 'XMCLH',1,1, 0, 0), "drawn to channel");
53 i_line($overlay,0,50,100,50,$bgcolor,1);
54
55 open(FH,">testout/t38ft2font.ppm") || die "cannot open testout/t38ft2font.ppm\n";
56 binmode(FH);
57 my $IO = Imager::io_new_fd(fileno(FH));
58 okx(i_writeppm_wiol($overlay, $IO), "saved image");
59 close(FH);
60
61 $bgcolor=i_color_set($bgcolor,200,200,200,0);
62 $backgr=Imager::ImgRaw::new(500,300,3);
63
64 #     i_tt_set_aa(2);
65 okx(Imager::Font::FreeType2::i_ft2_text($ttraw,$backgr,100,150,NC(255, 64, 64),200.0,50, 'MAW',1,1,0, 0), "drew MAW");
66 Imager::Font::FreeType2::i_ft2_settransform($ttraw, [0.9659, 0.2588, 0, -0.2588, 0.9659, 0 ]);
67 okx(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");
68 i_line($backgr, 0,150, 499, 150, NC(0, 0, 255),1);
69
70 open(FH,">testout/t38ft2font2.ppm") || die "cannot open testout/t38ft2font.ppm\n";
71 binmode(FH);
72 $IO = Imager::io_new_fd(fileno(FH));
73 okx(i_writeppm_wiol($backgr,$IO), "saved second image");
74 close(FH);
75
76 #$fontname = 'fontfiles/arial.ttf';
77 my $oof = Imager::Font->new(file=>$fontname, type=>'ft2', 'index'=>0);
78
79 okx($oof, "loaded OO font");
80
81 my $im = Imager->new(xsize=>400, ysize=>250);
82
83 okx($im->string(font=>$oof,
84             text=>"Via OO",
85             'x'=>20,
86             'y'=>20,
87             size=>60,
88             color=>NC(255, 128, 255),
89             aa => 1,
90             align=>0), "drawn through OO interface");
91 okx($oof->transform(matrix=>[1, 0.1, 0, 0, 1, 0]),
92     "set matrix via OO interface");
93 okx($im->string(font=>$oof,
94             text=>"Shear",
95             'x'=>20,
96             'y'=>40,
97             size=>60,
98             sizew=>50,
99             channel=>1,
100             aa=>1,
101             align=>1), "drawn transformed through OO");
102 use Imager::Matrix2d ':handy';
103 okx($oof->transform(matrix=>m2d_rotate(degrees=>-30)),
104                    "set transform from m2d module");
105 #$oof->transform(matrix=>m2d_identity());
106 okx($im->string(font=>$oof,
107             text=>"SPIN",
108             'x'=>20,
109             'y'=>50,
110             size=>50,
111             sizew=>40,
112             color=>NC(255,255,0),
113             aa => 1,
114             align=>0, vlayout=>0), "drawn first rotated");
115
116 okx($im->string(font=>$oof,
117             text=>"SPIN",
118             'x'=>20,
119             'y'=>50,
120             size=>50,
121             sizew=>40,
122             channel=>2,
123             aa => 1,
124             align=>0, vlayout=>0), "drawn second rotated");
125
126 $oof->transform(matrix=>m2d_identity());
127 $oof->hinting(hinting=>1);
128
129 # UTF8 testing
130 # the test font (dodge.ttf) only supports one character above 0xFF that
131 # I can see, 0x2010 HYPHEN (which renders the same as 0x002D HYPHEN MINUS)
132 # an attempt at utf8 support
133 # first attempt to use native perl UTF8
134 if ($] >= 5.006) {
135   my $text;
136   # we need to do this in eval to prevent compile time errors in older
137   # versions
138   eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
139   #$text = "A".chr(0x2010)."A"; # this one works too
140   unless (okx($im->string(font=>$oof,
141               text=>$text,
142               'x'=>20,
143               'y'=>200,
144               size=>50,
145               color=>NC(0,255,0),
146               aa=>1), "drawn UTF natively")) {
147     print "# ",$im->errstr,"\n";
148   }
149 }
150 else {
151   skipx(1, "no native UTF8 support in this version of perl");
152 }
153
154 # an attempt using emulation of UTF8
155 my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
156 #my $text = "A\xE2\x80\x90\x41\x{2010}";
157 #substr($text, -1, 0) = '';
158 unless (okx($im->string(font=>$oof,
159                 text=>$text,
160                 'x'=>20,
161                 'y'=>230,
162                 size=>50,
163                 color=>NC(255,128,0),
164                 aa=>1, 
165                 utf8=>1), "drawn UTF emulated")) {
166   print "# ",$im->errstr,"\n";
167 }
168
169 # just a bit of fun
170 # well it was - it demostrates what happens when you combine
171 # transformations and font hinting
172 for my $steps (0..39) {
173   $oof->transform(matrix=>m2d_rotate(degrees=>-$steps+5));
174   # demonstrates why we disable hinting on a doing a transform
175   # if the following line is enabled then the 0 degrees output sticks 
176   # out a bit
177   # $oof->hinting(hinting=>1);
178   $im->string(font=>$oof,
179               text=>"SPIN",
180               'x'=>160,
181               'y'=>70,
182               size=>65,
183               color=>NC(255, $steps * 5, 200-$steps * 5),
184               aa => 1,
185               align=>0, );
186 }
187
188 $im->write(file=>'testout/t38_oo.ppm')
189   or print "# could not save OO output: ",$im->errstr,"\n";
190
191 my (@got) = $oof->has_chars(string=>"\x01H");
192 okx(@got == 2, "has_chars returned 2 items");
193 okx(!$got[0], "have no chr(1)");
194 okx($got[1], "have 'H'");
195 okx($oof->has_chars(string=>"H\x01") eq "\x01\x00",
196     "scalar has_chars()");
197
198 print "# OO bounding boxes\n";
199 my @bbox = $oof->bounding_box(string=>"hello", size=>30);
200 my $bbox = $oof->bounding_box(string=>"hello", size=>30);
201
202 okx(@bbox == 7, "list bbox returned 7 items");
203 okx($bbox->isa('Imager::Font::BBox'), "scalar bbox returned right class");
204 okx($bbox->start_offset == $bbox[0], "start_offset");
205 okx($bbox->end_offset == $bbox[2], "end_offset");
206 okx($bbox->global_ascent == $bbox[3], "global_ascent");
207 okx($bbox->global_descent == $bbox[1], "global_descent");
208 okx($bbox->ascent == $bbox[5], "ascent");
209 okx($bbox->descent == $bbox[4], "descent");
210 okx($bbox->advance_width == $bbox[6], "advance_width");
211
212 print "# aligned text output\n";
213 my $alimg = Imager->new(xsize=>300, ysize=>300);
214 $alimg->box(color=>'40FF40', filled=>1);
215 my @base_color = (64, 255, 64);
216
217 $oof->transform(matrix=>m2d_identity());
218 $oof->hinting(hinting=>1);
219
220 align_test('left', 'top', 10, 10, $oof, $alimg);
221 align_test('start', 'top', 10, 40, $oof, $alimg);
222 align_test('center', 'top', 150, 70, $oof, $alimg);
223 align_test('end', 'top', 290, 100, $oof, $alimg);
224 align_test('right', 'top', 290, 130, $oof, $alimg);
225
226 align_test('center', 'top', 150, 160, $oof, $alimg);
227 align_test('center', 'center', 150, 190, $oof, $alimg);
228 align_test('center', 'bottom', 150, 220, $oof, $alimg);
229 align_test('center', 'baseline', 150, 250, $oof, $alimg);
230
231 okx($alimg->write(file=>'testout/t38aligned.ppm'), 
232     "saving aligned output image");
233
234 my $exfont = Imager::Font->new(file=>'fontfiles/ExistenceTest.ttf',
235                                type=>'ft2');
236 if (okx($exfont, "loaded existence font")) {
237   # the test font is known to have a shorter advance width for that char
238   my @bbox = $exfont->bounding_box(string=>"/", size=>100);
239   okx(@bbox == 7, "should be 7 entries");
240   okx($bbox[6] != $bbox[4], "different advance width");
241   my $bbox = $exfont->bounding_box(string=>"/", size=>100);
242   okx($bbox->pos_width != $bbox->advance_width, "OO check");
243
244   # name tests
245   my $facename = Imager::Font::FreeType2::i_ft2_face_name($exfont->{id});
246   print "# face name '$facename'\n";
247   okx($facename eq 'ExistenceTest', "test face name");
248   $facename = $exfont->face_name;
249   okx($facename eq 'ExistenceTest', "test face name OO");
250
251 }
252 else {
253   skipx(5, "couldn't load test font");
254 }
255
256 if (Imager::Font::FreeType2->can_glyph_names) {
257   # pfaedit doesn't seem to save glyph names into TTF files
258   my $exfont = Imager::Font->new(file=>'fontfiles/ExistenceTest.pfb',
259                                type=>'ft2');
260   if (okx($exfont, "load Type 1 via FT2")) {
261     my @glyph_names = 
262       Imager::Font::FreeType2::i_ft2_glyph_name($exfont->{id}, "!J/");
263     #use Data::Dumper;
264     #print Dumper \@glyph_names;
265     okx($glyph_names[0] eq 'exclam', "check exclam name");
266     okx(!defined($glyph_names[1]), "check for no J name");
267     okx($glyph_names[2] eq 'slash', "check slash name");
268
269     # oo interfaces
270     @glyph_names = $exfont->glyph_names(string=>"!J/");
271     okx($glyph_names[0] eq 'exclam', "check exclam name OO");
272     okx(!defined($glyph_names[1]), "check for no J name OO");
273     okx($glyph_names[2] eq 'slash', "check slash name OO");
274   }
275   else {
276     skipx(6, "couldn't load type 1 with FT2");
277   }
278 }
279 else {
280   skipx(7, "FT2 compiled without glyph names support");
281 }
282
283 sub align_test {
284   my ($h, $v, $x, $y, $f, $img) = @_;
285
286   my @pos = $f->align(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
287                       image=>$img, size=>15, color=>'FFFFFF',
288                       string=>"x$h ${v}y", channel=>1, aa=>1);
289   @pos = $f->align(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
290                       image=>$img, size=>15, color=>'FF99FF',
291                       string=>"x$h ${v}y", aa=>1);
292   if (okx(@pos == 4, "$h $v aligned output")) {
293     # checking corners
294     my $cx = int(($pos[0] + $pos[2]) / 2);
295     my $cy = int(($pos[1] + $pos[3]) / 2);
296     
297     print "# @pos cx $cx cy $cy\n";
298     okmatchcolor($img, $cx, $pos[1]-1, @base_color, "outer top edge");
299     okmatchcolor($img, $cx, $pos[3], @base_color, "outer bottom edge");
300     okmatchcolor($img, $pos[0]-1, $cy, @base_color, "outer left edge");
301     okmatchcolor($img, $pos[2], $cy, @base_color, "outer right edge");
302     
303     okmismatchcolor($img, $cx, $pos[1], @base_color, "inner top edge");
304     okmismatchcolor($img, $cx, $pos[3]-1, @base_color, "inner bottom edge");
305     okmismatchcolor($img, $pos[0], $cy, @base_color, "inner left edge");
306 #    okmismatchcolor($img, $pos[2]-1, $cy, @base_color, "inner right edge");
307 # XXX: This gets triggered by a freetype2 bug I think 
308 #    $ rpm -qa | grep freetype
309 #    freetype-2.1.3-6
310 #
311 # (addi: 4/1/2004).
312
313     cross($img, $x, $y, 'FF0000');
314     cross($img, $cx, $pos[1]-1, '0000FF');
315     cross($img, $cx, $pos[3], '0000FF');
316     cross($img, $pos[0]-1, $cy, '0000FF');
317     cross($img, $pos[2], $cy, '0000FF');
318   }
319   else {
320     skipx(8, "couldn't draw text");
321   }
322 }
323
324 sub okmatchcolor {
325   my ($img, $x, $y, $r, $g, $b, $about) = @_;
326
327   my $c = $img->getpixel('x'=>$x, 'y'=>$y);
328   my ($fr, $fg, $fb) = $c->rgba;
329   okx($fr == $r && $fg == $g && $fb == $b,
330       "want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
331 }
332
333 sub okmismatchcolor {
334   my ($img, $x, $y, $r, $g, $b, $about) = @_;
335
336   my $c = $img->getpixel('x'=>$x, 'y'=>$y);
337   my ($fr, $fg, $fb) = $c->rgba;
338   okx($fr != $r || $fg != $g || $fb != $b,
339       "don't want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
340 }
341
342 sub cross {
343   my ($img, $x, $y, $color) = @_;
344
345   $img->setpixel('x'=>[$x, $x, $x, $x, $x, $x-2, $x-1, $x+1, $x+2], 
346                  'y'=>[$y-2, $y-1, $y, $y+1, $y+2, $y, $y, $y, $y], 
347                  color => $color);
348   
349 }