4 #use lib qw(blib/lib blib/arch);
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'
9 ######################### We start with some black magic to print on failure.
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 use Test::More tests => 20;
15 BEGIN { use_ok('Imager') };
17 -d "testout" or mkdir "testout";
19 init_log("testout/t36oofont.log", 1);
21 my $fontname_tt=$ENV{'TTFONTTEST'}||'./fontfiles/dodge.ttf';
22 my $fontname_pfb=$ENV{'T1FONTTESTPFB'}||'./fontfiles/dcr10.pfb';
25 my $green=Imager::Color->new(92,205,92,128);
26 die $Imager::ERRSTR unless $green;
27 my $red=Imager::Color->new(205, 92, 92, 255);
28 die $Imager::ERRSTR unless $red;
32 i_has_format("t1") && -f $fontname_pfb
33 or skip("T1lib missing or disabled", 8);
35 my $img=Imager->new(xsize=>300, ysize=>100) or die "$Imager::ERRSTR\n";
37 my $font=Imager::Font->new(file=>$fontname_pfb,size=>25)
38 or die $img->{ERRSTR};
40 ok(1, "created font");
42 ok($img->string(font=>$font, text=>"XMCLH", 'x'=>100, 'y'=>100),
44 $img->line(x1=>0, x2=>300, y1=>50, y2=>50, color=>$green);
47 my @bbox=$font->bounding_box(string=>$text, 'x'=>0, 'y'=>50);
49 is(@bbox, 8, "bounding box list length");
51 $img->box(box=>\@bbox, color=>$green);
54 $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
55 ok($img->string(font=>$font, text=>$text, 'x'=>100, 'y'=>50, utf8=>1,
57 "draw 'utf8' hand-encoded text");
59 ok($img->string(font=>$font, text=>$text, 'x'=>140, 'y'=>50, utf8=>1,
60 underline=>1, channel=>2),
61 "channel 'utf8' hand-encoded text");
66 or skip("perl too old for native utf8", 2);
67 eval q{$text = "A\x{2010}A"};
68 ok($img->string(font=>$font, text=>$text, 'x'=>180, 'y'=>50,
70 "draw native UTF8 text");
71 ok($img->string(font=>$font, text=>$text, 'x'=>220, 'y'=>50, channel=>1),
72 "channel native UTF8 text");
75 ok($img->write(file=>"testout/t36oofont1.ppm", type=>'pnm'),
76 "write t36oofont1.ppm")
77 or print "# ",$img->errstr,"\n";
83 i_has_format("tt") && -f $fontname_tt
84 or skip("FT1.x missing or disabled", 10);
86 my $img=Imager->new(xsize=>300, ysize=>100) or die "$Imager::ERRSTR\n";
88 my $font=Imager::Font->new(file=>$fontname_tt,size=>25)
89 or die $img->{ERRSTR};
91 ok(1, "create TT font object");
93 ok($img->string(font=>$font, text=>"XMCLH", 'x'=>100, 'y'=>100),
96 $img->line(x1=>0, x2=>300, y1=>50, y2=>50, color=>$green);
99 my @bbox=$font->bounding_box(string=>$text, 'x'=>0, 'y'=>50);
101 is(@bbox, 8, "bbox list size");
103 $img->box(box=>\@bbox, color=>$green);
105 $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
106 ok($img->string(font=>$font, text=>$text, 'x'=>100, 'y'=>50, utf8=>1),
107 "draw hand-encoded UTF8 text");
112 or skip("perl too old for native utf8", 1);
113 eval q{$text = "A\x{2010}A"};
114 ok($img->string(font=>$font, text=>$text, 'x'=>200, 'y'=>50),
115 "draw native UTF8 text");
118 ok($img->write(file=>"testout/t36oofont2.ppm", type=>'pnm'),
119 "write t36oofont2.ppm")
120 or print "# ", $img->errstr,"\n";
122 ok($font->utf8, "make sure utf8 method returns true");
124 my $has_chars = $font->has_chars(string=>"\x01A");
125 is($has_chars, "\x00\x01", "has_chars scalar");
126 my @has_chars = $font->has_chars(string=>"\x01A");
127 ok(!$has_chars[0], "has_chars list 0");
128 ok($has_chars[1], "has_chars list 1");