1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
#!/usr/bin/perl -w
use strict;
#use lib qw(blib/lib blib/arch);
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
######################### We start with some black magic to print on failure.
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
use Test::More tests => 25;
use Imager;
use Imager::Test qw(isnt_image is_image);
-d "testout" or mkdir "testout";
Imager->open_log(log => "testout/t36oofont.log");
my @test_output;
my $fontname_tt=$ENV{'TTFONTTEST'}||'./fontfiles/dodge.ttf';
my $green=Imager::Color->new(92,205,92,128);
die $Imager::ERRSTR unless $green;
my $red=Imager::Color->new(205, 92, 92, 255);
die $Imager::ERRSTR unless $red;
SKIP:
{
$Imager::formats{"tt"} && -f $fontname_tt
or skip("FT1.x missing or disabled", 25);
my $img=Imager->new(xsize=>300, ysize=>100) or die "$Imager::ERRSTR\n";
my $font=Imager::Font->new(file=>$fontname_tt,size=>25)
or die $img->{ERRSTR};
ok(1, "create TT font object");
ok($img->string(font=>$font, text=>"XMCLH", 'x'=>100, 'y'=>100),
"draw text");
$img->line(x1=>0, x2=>300, y1=>50, y2=>50, color=>$green);
my $text="LLySja";
my @bbox=$font->bounding_box(string=>$text, 'x'=>0, 'y'=>50);
is(@bbox, 8, "bbox list size");
$img->box(box=>\@bbox, color=>$green);
$text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
ok($img->string(font=>$font, text=>$text, 'x'=>100, 'y'=>50, utf8=>1),
"draw hand-encoded UTF8 text");
SKIP:
{
$] >= 5.006
or skip("perl too old for native utf8", 1);
eval q{$text = "A\x{2010}A"};
ok($img->string(font=>$font, text=>$text, 'x'=>200, 'y'=>50),
"draw native UTF8 text");
}
ok($img->write(file=>"testout/t36oofont2.ppm", type=>'pnm'),
"write t36oofont2.ppm")
or print "# ", $img->errstr,"\n";
ok($font->utf8, "make sure utf8 method returns true");
my $has_chars = $font->has_chars(string=>"\x01A");
is($has_chars, "\x00\x01", "has_chars scalar");
my @has_chars = $font->has_chars(string=>"\x01A");
ok(!$has_chars[0], "has_chars list 0");
ok($has_chars[1], "has_chars list 1");
{ # RT 71469
my $font1 = Imager::Font->new(file => $fontname_tt, type => "tt");
my $font2 = Imager::Font::Truetype->new(file => $fontname_tt);
for my $font ($font1, $font2) {
print "# ", join(",", $font->{color}->rgba), "\n";
my $im = Imager->new(xsize => 20, ysize => 20, channels => 4);
ok($im->string(text => "T", font => $font, y => 15),
"draw with default color")
or print "# ", $im->errstr, "\n";
my $work = Imager->new(xsize => 20, ysize => 20);
my $cmp = $work->copy;
$work->rubthrough(src => $im);
isnt_image($work, $cmp, "make sure something was drawn");
}
}
{ # RT 73359
# non-AA font drawing isn't normal mode
Imager->log("testing no-aa normal output\n");
my $font = Imager::Font->new(file => "fontfiles/ImUgly.ttf", type => "tt");
ok($font, "make a work font");
my %common =
(
x => 10,
font => $font,
size => 25,
aa => 0,
align => 0,
);
# build our comparison image
my $cmp = Imager->new(xsize => 120, ysize => 100);
my $layer = Imager->new(xsize => 120, ysize => 100, channels => 4);
ok($layer->string(%common, y => 10, text => "full", color => "#8080FF"),
"draw non-aa text at full coverage to layer image");
ok($layer->string(%common, y => 40, text => "half", color => "#FF808080"),
"draw non-aa text at half coverage to layer image");
ok($layer->string(%common, y => 70, text => "quarter", color => "#80FF8040"),
"draw non-aa text at zero coverage to layer image");
ok($cmp->rubthrough(src => $layer), "rub layer onto comparison image");
my $im = Imager->new(xsize => 120, ysize => 100);
ok($im->string(%common, y => 10, text => "full", color => "#8080FF"),
"draw non-aa text at full coverage");
ok($im->string(%common, y => 40, text => "half", color => "#FF808080"),
"draw non-aa text at half coverage");
ok($im->string(%common, y => 70, text => "quarter", color => "#80FF8040"),
"draw non-aa text at zero coverage");
is_image($im, $cmp, "check the result");
push @test_output, "ttaanorm.ppm", "ttaacmp.ppm";
ok($cmp->write(file => "testout/ttaacmp.ppm"), "save cmp image")
or diag "Saving cmp image: ", $cmp->errstr;
ok($im->write(file => "testout/ttaanorm.ppm"), "save test image")
or diag "Saving result image: ", $im->errstr;
}
}
Imager->close_log;
END {
unless ($ENV{IMAGER_KEEP_FILES}) {
unlink map "testout/$_", @test_output;
}
}
|
