[imager.git] / t / t38ft2font.t

#!perl -w
# 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.)

BEGIN { $| = 1; print "1..116\n"; }
END {print "not ok 1\n" unless $loaded;}
use Imager qw(:all);

require "t/testtools.pl";
$loaded = 1;
okx(1, "loaded");

init_log("testout/t38ft2font.log",2);

if (!(i_has_format("ft2")) ) { 
  skipx(115, "No freetype2 library found");
  exit;
}
print "# has ft2\n";

$fontname=$ENV{'TTFONTTEST'}||'./fontfiles/dodge.ttf';

if (! -f $fontname) {
  skipx(124, "cannot find fontfile $fontname");
  malloc_state();
  exit;
}

#i_init_fonts();
#     i_tt_set_aa(1);

$bgcolor=i_color_new(255,0,0,0);
$overlay=Imager::ImgRaw::new(200,70,3);

$ttraw=Imager::Font::FreeType2::i_ft2_new($fontname, 0);

$ttraw or print Imager::_error_as_msg(),"\n";
okx($ttraw, "loaded raw font");
#use Data::Dumper;
#warn Dumper($ttraw);

@bbox=Imager::Font::FreeType2::i_ft2_bbox($ttraw, 50.0, 0, 'XMCLH', 0);
print "#bbox @bbox\n";

okx(@bbox == 7, "i_ft2_bbox() returns 7 values");

okx(Imager::Font::FreeType2::i_ft2_cp($ttraw,$overlay,5,50,1,50.0,50, 'XMCLH',1,1, 0, 0), "drawn to channel");
i_line($overlay,0,50,100,50,$bgcolor,1);

open(FH,">testout/t38ft2font.ppm") || die "cannot open testout/t38ft2font.ppm\n";
binmode(FH);
my $IO = Imager::io_new_fd(fileno(FH));
okx(i_writeppm_wiol($overlay, $IO), "saved image");
close(FH);

$bgcolor=i_color_set($bgcolor,200,200,200,0);
$backgr=Imager::ImgRaw::new(500,300,3);

#     i_tt_set_aa(2);
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");
Imager::Font::FreeType2::i_ft2_settransform($ttraw, [0.9659, 0.2588, 0, -0.2588, 0.9659, 0 ]);
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");
i_line($backgr, 0,150, 499, 150, NC(0, 0, 255),1);

open(FH,">testout/t38ft2font2.ppm") || die "cannot open testout/t38ft2font.ppm\n";
binmode(FH);
$IO = Imager::io_new_fd(fileno(FH));
okx(i_writeppm_wiol($backgr,$IO), "saved second image");
close(FH);

#$fontname = 'fontfiles/arial.ttf';
my $oof = Imager::Font->new(file=>$fontname, type=>'ft2', 'index'=>0);

okx($oof, "loaded OO font");

my $im = Imager->new(xsize=>400, ysize=>250);

okx($im->string(font=>$oof,
            text=>"Via OO",
            'x'=>20,
            'y'=>20,
            size=>60,
            color=>NC(255, 128, 255),
            aa => 1,
            align=>0), "drawn through OO interface");
okx($oof->transform(matrix=>[1, 0.1, 0, 0, 1, 0]),
    "set matrix via OO interface");
okx($im->string(font=>$oof,
            text=>"Shear",
            'x'=>20,
            'y'=>40,
            size=>60,
            sizew=>50,
            channel=>1,
            aa=>1,
            align=>1), "drawn transformed through OO");
use Imager::Matrix2d ':handy';
okx($oof->transform(matrix=>m2d_rotate(degrees=>-30)),
                   "set transform from m2d module");
#$oof->transform(matrix=>m2d_identity());
okx($im->string(font=>$oof,
            text=>"SPIN",
            'x'=>20,
            'y'=>50,
            size=>50,
  	    sizew=>40,
            color=>NC(255,255,0),
            aa => 1,
            align=>0, vlayout=>0), "drawn first rotated");

okx($im->string(font=>$oof,
            text=>"SPIN",
            'x'=>20,
            'y'=>50,
            size=>50,
	    sizew=>40,
            channel=>2,
            aa => 1,
            align=>0, vlayout=>0), "drawn second rotated");

$oof->transform(matrix=>m2d_identity());
$oof->hinting(hinting=>1);

# UTF8 testing
# the test font (dodge.ttf) only supports one character above 0xFF that
# I can see, 0x2010 HYPHEN (which renders the same as 0x002D HYPHEN MINUS)
# an attempt at utf8 support
# first attempt to use native perl UTF8
if ($] >= 5.006) {
  my $text;
  # we need to do this in eval to prevent compile time errors in older
  # versions
  eval q{$text = "A\x{2010}A"}; # A, HYPHEN, A in our test font
  #$text = "A".chr(0x2010)."A"; # this one works too
  unless (okx($im->string(font=>$oof,
              text=>$text,
              'x'=>20,
              'y'=>200,
              size=>50,
              color=>NC(0,255,0),
              aa=>1), "drawn UTF natively")) {
    print "# ",$im->errstr,"\n";
  }
}
else {
  skipx(1, "no native UTF8 support in this version of perl");
}

# an attempt using emulation of UTF8
my $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
#my $text = "A\xE2\x80\x90\x41\x{2010}";
#substr($text, -1, 0) = '';
unless (okx($im->string(font=>$oof,
                text=>$text,
                'x'=>20,
                'y'=>230,
                size=>50,
                color=>NC(255,128,0),
                aa=>1, 
                utf8=>1), "drawn UTF emulated")) {
  print "# ",$im->errstr,"\n";
}

# just a bit of fun
# well it was - it demostrates what happens when you combine
# transformations and font hinting
for my $steps (0..39) {
  $oof->transform(matrix=>m2d_rotate(degrees=>-$steps+5));
  # demonstrates why we disable hinting on a doing a transform
  # if the following line is enabled then the 0 degrees output sticks 
  # out a bit
  # $oof->hinting(hinting=>1);
  $im->string(font=>$oof,
              text=>"SPIN",
              'x'=>160,
              'y'=>70,
              size=>65,
              color=>NC(255, $steps * 5, 200-$steps * 5),
              aa => 1,
              align=>0, );
}

$im->write(file=>'testout/t38_oo.ppm')
  or print "# could not save OO output: ",$im->errstr,"\n";

my (@got) = $oof->has_chars(string=>"\x01H");
okx(@got == 2, "has_chars returned 2 items");
okx(!$got[0], "have no chr(1)");
okx($got[1], "have 'H'");
okx($oof->has_chars(string=>"H\x01") eq "\x01\x00",
    "scalar has_chars()");

print "# OO bounding boxes\n";
my @bbox = $oof->bounding_box(string=>"hello", size=>30);
my $bbox = $oof->bounding_box(string=>"hello", size=>30);

okx(@bbox == 7, "list bbox returned 7 items");
okx($bbox->isa('Imager::Font::BBox'), "scalar bbox returned right class");
okx($bbox->start_offset == $bbox[0], "start_offset");
okx($bbox->end_offset == $bbox[2], "end_offset");
okx($bbox->global_ascent == $bbox[3], "global_ascent");
okx($bbox->global_descent == $bbox[1], "global_descent");
okx($bbox->ascent == $bbox[5], "ascent");
okx($bbox->descent == $bbox[4], "descent");
okx($bbox->advance_width == $bbox[6], "advance_width");

print "# aligned text output\n";
my $alimg = Imager->new(xsize=>300, ysize=>300);
$alimg->box(color=>'40FF40', filled=>1);
my @base_color = (64, 255, 64);

$oof->transform(matrix=>m2d_identity());
$oof->hinting(hinting=>1);

align_test('left', 'top', 10, 10, $oof, $alimg);
align_test('start', 'top', 10, 40, $oof, $alimg);
align_test('center', 'top', 150, 70, $oof, $alimg);
align_test('end', 'top', 290, 100, $oof, $alimg);
align_test('right', 'top', 290, 130, $oof, $alimg);

align_test('center', 'top', 150, 160, $oof, $alimg);
align_test('center', 'center', 150, 190, $oof, $alimg);
align_test('center', 'bottom', 150, 220, $oof, $alimg);
align_test('center', 'baseline', 150, 250, $oof, $alimg);

okx($alimg->write(file=>'testout/t38aligned.ppm'), 
    "saving aligned output image");

my $exfont = Imager::Font->new(file=>'fontfiles/ExistenceTest.ttf',
                               type=>'ft2');
if (okx($exfont, "loaded existence font")) {
  # the test font is known to have a shorter advance width for that char
  my @bbox = $exfont->bounding_box(string=>"/", size=>100);
  okx(@bbox == 7, "should be 7 entries");
  okx($bbox[6] != $bbox[4], "different advance width");
  my $bbox = $exfont->bounding_box(string=>"/", size=>100);
  okx($bbox->pos_width != $bbox->advance_width, "OO check");

  # name tests
  # make sure the number of tests on each branch match
  if (Imager::Font::FreeType2::i_ft2_can_face_name()) {
    my $facename = Imager::Font::FreeType2::i_ft2_face_name($exfont->{id});
    print "# face name '$facename'\n";
    okx($facename eq 'ExistenceTest', "test face name");
    $facename = $exfont->face_name;
    okx($facename eq 'ExistenceTest', "test face name OO");
  }
  else {
    # make sure we get the error we expect
    my $facename = Imager::Font::FreeType2::i_ft2_face_name($exfont->{id});
    my ($msg) = Imager::_error_as_msg();
    okx(!defined($facename), "test face name not supported");
    print "# $msg\n";
    okx(scalar($msg =~ /or later required/), "test face name not supported");
  }
}
else {
  skipx(5, "couldn't load test font");
}

if (Imager::Font::FreeType2->can_glyph_names) {
  # pfaedit doesn't seem to save glyph names into TTF files
  my $exfont = Imager::Font->new(file=>'fontfiles/ExistenceTest.pfb',
                               type=>'ft2');
  if (okx($exfont, "load Type 1 via FT2")) {
    my @glyph_names = 
      Imager::Font::FreeType2::i_ft2_glyph_name($exfont->{id}, "!J/");
    #use Data::Dumper;
    #print Dumper \@glyph_names;
    okx($glyph_names[0] eq 'exclam', "check exclam name");
    okx(!defined($glyph_names[1]), "check for no J name");
    okx($glyph_names[2] eq 'slash', "check slash name");

    # oo interfaces
    @glyph_names = $exfont->glyph_names(string=>"!J/");
    okx($glyph_names[0] eq 'exclam', "check exclam name OO");
    okx(!defined($glyph_names[1]), "check for no J name OO");
    okx($glyph_names[2] eq 'slash', "check slash name OO");
  }
  else {
    skipx(6, "couldn't load type 1 with FT2");
  }
}
else {
  skipx(7, "FT2 compiled without glyph names support");
}

sub align_test {
  my ($h, $v, $x, $y, $f, $img) = @_;

  my @pos = $f->align(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
                      image=>$img, size=>15, color=>'FFFFFF',
                      string=>"x$h ${v}y", channel=>1, aa=>1);
  @pos = $f->align(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
                      image=>$img, size=>15, color=>'FF99FF',
                      string=>"x$h ${v}y", aa=>1);
  if (okx(@pos == 4, "$h $v aligned output")) {
    # checking corners
    my $cx = int(($pos[0] + $pos[2]) / 2);
    my $cy = int(($pos[1] + $pos[3]) / 2);
    
    print "# @pos cx $cx cy $cy\n";
    okmatchcolor($img, $cx, $pos[1]-1, @base_color, "outer top edge");
    okmatchcolor($img, $cx, $pos[3], @base_color, "outer bottom edge");
    okmatchcolor($img, $pos[0]-1, $cy, @base_color, "outer left edge");
    okmatchcolor($img, $pos[2], $cy, @base_color, "outer right edge");
    
    okmismatchcolor($img, $cx, $pos[1], @base_color, "inner top edge");
    okmismatchcolor($img, $cx, $pos[3]-1, @base_color, "inner bottom edge");
    okmismatchcolor($img, $pos[0], $cy, @base_color, "inner left edge");
#    okmismatchcolor($img, $pos[2]-1, $cy, @base_color, "inner right edge");
# XXX: This gets triggered by a freetype2 bug I think 
#    $ rpm -qa | grep freetype
#    freetype-2.1.3-6
#
# (addi: 4/1/2004).

    cross($img, $x, $y, 'FF0000');
    cross($img, $cx, $pos[1]-1, '0000FF');
    cross($img, $cx, $pos[3], '0000FF');
    cross($img, $pos[0]-1, $cy, '0000FF');
    cross($img, $pos[2], $cy, '0000FF');
  }
  else {
    skipx(8, "couldn't draw text");
  }
}

sub okmatchcolor {
  my ($img, $x, $y, $r, $g, $b, $about) = @_;

  my $c = $img->getpixel('x'=>$x, 'y'=>$y);
  my ($fr, $fg, $fb) = $c->rgba;
  okx($fr == $r && $fg == $g && $fb == $b,
      "want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
}

sub okmismatchcolor {
  my ($img, $x, $y, $r, $g, $b, $about) = @_;

  my $c = $img->getpixel('x'=>$x, 'y'=>$y);
  my ($fr, $fg, $fb) = $c->rgba;
  okx($fr != $r || $fg != $g || $fb != $b,
      "don't want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
}

sub cross {
  my ($img, $x, $y, $color) = @_;

  $img->setpixel('x'=>[$x, $x, $x, $x, $x, $x-2, $x-1, $x+1, $x+2], 
                 'y'=>[$y-2, $y-1, $y, $y+1, $y+2, $y, $y, $y, $y], 
                 color => $color);
  
}
Commit	Line	Data
faa9b3e7 TC	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
3a6bb91b	10	BEGIN { $\| = 1; print "1..116\n"; }
faa9b3e7 TC	11	END {print "not ok 1\n" unless $loaded;}
faa9b3e7 TC	12	use Imager qw(:all);
3799c4d1 TC	13
3799c4d1 TC	14	require "t/testtools.pl";
faa9b3e7	15	$loaded = 1;
3799c4d1	16	okx(1, "loaded");
faa9b3e7	17
db6d10cc	18	init_log("testout/t38ft2font.log",2);
faa9b3e7	19
3799c4d1	20	if (!(i_has_format("ft2")) ) {
2e6041a0	21	skipx(115, "No freetype2 library found");
3799c4d1	22	exit;
faa9b3e7	23	}
faa9b3e7 TC	24	print "# has ft2\n";
	25
	26	$fontname=$ENV{'TTFONTTEST'}\|\|'./fontfiles/dodge.ttf';
	27
	28	if (! -f $fontname) {
3799c4d1 TC	29	skipx(124, "cannot find fontfile $fontname");
	30	malloc_state();
	31	exit;
faa9b3e7 TC	32	}
faa9b3e7 TC	33
3799c4d1	34	#i_init_fonts();
faa9b3e7 TC	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";
3799c4d1	43	okx($ttraw, "loaded raw font");
faa9b3e7 TC	44	#use Data::Dumper;
	45	#warn Dumper($ttraw);
	46
5cb9270b	47	@bbox=Imager::Font::FreeType2::i_ft2_bbox($ttraw, 50.0, 0, 'XMCLH', 0);
3799c4d1 TC	48	print "#bbox @bbox\n";
	49
	50	okx(@bbox == 7, "i_ft2_bbox() returns 7 values");
faa9b3e7	51
3799c4d1	52	okx(Imager::Font::FreeType2::i_ft2_cp($ttraw,$overlay,5,50,1,50.0,50, 'XMCLH',1,1, 0, 0), "drawn to channel");
aa833c97	53	i_line($overlay,0,50,100,50,$bgcolor,1);
faa9b3e7 TC	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));
3799c4d1	58	okx(i_writeppm_wiol($overlay, $IO), "saved image");
faa9b3e7 TC	59	close(FH);
faa9b3e7 TC	60
faa9b3e7 TC	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);
3799c4d1	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");
faa9b3e7	66	Imager::Font::FreeType2::i_ft2_settransform($ttraw, [0.9659, 0.2588, 0, -0.2588, 0.9659, 0 ]);
3799c4d1	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");
aa833c97	68	i_line($backgr, 0,150, 499, 150, NC(0, 0, 255),1);
faa9b3e7 TC	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));
3799c4d1	73	okx(i_writeppm_wiol($backgr,$IO), "saved second image");
faa9b3e7 TC	74	close(FH);
faa9b3e7 TC	75
faa9b3e7	76	#$fontname = 'fontfiles/arial.ttf';
3799c4d1 TC	77	my $oof = Imager::Font->new(file=>$fontname, type=>'ft2', 'index'=>0);
	78
	79	okx($oof, "loaded OO font");
faa9b3e7 TC	80
	81	my $im = Imager->new(xsize=>400, ysize=>250);
	82
3799c4d1	83	okx($im->string(font=>$oof,
faa9b3e7	84	text=>"Via OO",
9d540150 TC	85	'x'=>20,
9d540150 TC	86	'y'=>20,
faa9b3e7 TC	87	size=>60,
	88	color=>NC(255, 128, 255),
	89	aa => 1,
3799c4d1 TC	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,
faa9b3e7	94	text=>"Shear",
9d540150	95	'x'=>20,
faa9b3e7 TC	96	'y'=>40,
	97	size=>60,
	98	sizew=>50,
	99	channel=>1,
	100	aa=>1,
3799c4d1	101	align=>1), "drawn transformed through OO");
faa9b3e7	102	use Imager::Matrix2d ':handy';
3799c4d1 TC	103	okx($oof->transform(matrix=>m2d_rotate(degrees=>-30)),
3799c4d1 TC	104	"set transform from m2d module");
faa9b3e7	105	#$oof->transform(matrix=>m2d_identity());
3799c4d1	106	okx($im->string(font=>$oof,
faa9b3e7	107	text=>"SPIN",
9d540150	108	'x'=>20,
faa9b3e7 TC	109	'y'=>50,
	110	size=>50,
	111	sizew=>40,
	112	color=>NC(255,255,0),
	113	aa => 1,
3799c4d1 TC	114	align=>0, vlayout=>0), "drawn first rotated");
	115
	116	okx($im->string(font=>$oof,
faa9b3e7	117	text=>"SPIN",
9d540150	118	'x'=>20,
faa9b3e7 TC	119	'y'=>50,
	120	size=>50,
	121	sizew=>40,
	122	channel=>2,
	123	aa => 1,
3799c4d1	124	align=>0, vlayout=>0), "drawn second rotated");
faa9b3e7 TC	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
3799c4d1	140	unless (okx($im->string(font=>$oof,
faa9b3e7	141	text=>$text,
9d540150	142	'x'=>20,
faa9b3e7 TC	143	'y'=>200,
	144	size=>50,
	145	color=>NC(0,255,0),
3799c4d1 TC	146	aa=>1), "drawn UTF natively")) {
3799c4d1 TC	147	print "# ",$im->errstr,"\n";
faa9b3e7 TC	148	}
	149	}
	150	else {
3799c4d1	151	skipx(1, "no native UTF8 support in this version of perl");
faa9b3e7 TC	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) = '';
3799c4d1	158	unless (okx($im->string(font=>$oof,
faa9b3e7	159	text=>$text,
9d540150	160	'x'=>20,
faa9b3e7 TC	161	'y'=>230,
	162	size=>50,
	163	color=>NC(255,128,0),
	164	aa=>1,
3799c4d1 TC	165	utf8=>1), "drawn UTF emulated")) {
3799c4d1 TC	166	print "# ",$im->errstr,"\n";
faa9b3e7 TC	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",
9d540150	180	'x'=>160,
faa9b3e7 TC	181	'y'=>70,
	182	size=>65,
	183	color=>NC(255, $steps * 5, 200-$steps * 5),
	184	aa => 1,
3799c4d1	185	align=>0, );
faa9b3e7 TC	186	}
	187
	188	$im->write(file=>'testout/t38_oo.ppm')
	189	or print "# could not save OO output: ",$im->errstr,"\n";
3dec2c92 TC	190
3dec2c92 TC	191	my (@got) = $oof->has_chars(string=>"\x01H");
3799c4d1 TC	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
042cdaea TC	245	# make sure the number of tests on each branch match
	246	if (Imager::Font::FreeType2::i_ft2_can_face_name()) {
	247	my $facename = Imager::Font::FreeType2::i_ft2_face_name($exfont->{id});
	248	print "# face name '$facename'\n";
	249	okx($facename eq 'ExistenceTest', "test face name");
	250	$facename = $exfont->face_name;
	251	okx($facename eq 'ExistenceTest', "test face name OO");
	252	}
	253	else {
	254	# make sure we get the error we expect
	255	my $facename = Imager::Font::FreeType2::i_ft2_face_name($exfont->{id});
	256	my ($msg) = Imager::_error_as_msg();
	257	okx(!defined($facename), "test face name not supported");
	258	print "# $msg\n";
	259	okx(scalar($msg =~ /or later required/), "test face name not supported");
	260	}
3799c4d1 TC	261	}
	262	else {
	263	skipx(5, "couldn't load test font");
	264	}
	265
	266	if (Imager::Font::FreeType2->can_glyph_names) {
	267	# pfaedit doesn't seem to save glyph names into TTF files
	268	my $exfont = Imager::Font->new(file=>'fontfiles/ExistenceTest.pfb',
	269	type=>'ft2');
	270	if (okx($exfont, "load Type 1 via FT2")) {
	271	my @glyph_names =
	272	Imager::Font::FreeType2::i_ft2_glyph_name($exfont->{id}, "!J/");
	273	#use Data::Dumper;
	274	#print Dumper \@glyph_names;
	275	okx($glyph_names[0] eq 'exclam', "check exclam name");
	276	okx(!defined($glyph_names[1]), "check for no J name");
	277	okx($glyph_names[2] eq 'slash', "check slash name");
	278
	279	# oo interfaces
	280	@glyph_names = $exfont->glyph_names(string=>"!J/");
	281	okx($glyph_names[0] eq 'exclam', "check exclam name OO");
	282	okx(!defined($glyph_names[1]), "check for no J name OO");
	283	okx($glyph_names[2] eq 'slash', "check slash name OO");
	284	}
	285	else {
	286	skipx(6, "couldn't load type 1 with FT2");
	287	}
	288	}
	289	else {
	290	skipx(7, "FT2 compiled without glyph names support");
	291	}
	292
	293	sub align_test {
	294	my ($h, $v, $x, $y, $f, $img) = @_;
	295
	296	my @pos = $f->align(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
	297	image=>$img, size=>15, color=>'FFFFFF',
	298	string=>"x$h ${v}y", channel=>1, aa=>1);
3a6bb91b AMH	299	@pos = $f->align(halign=>$h, valign=>$v, 'x'=>$x, 'y'=>$y,
	300	image=>$img, size=>15, color=>'FF99FF',
	301	string=>"x$h ${v}y", aa=>1);
3799c4d1 TC	302	if (okx(@pos == 4, "$h $v aligned output")) {
	303	# checking corners
	304	my $cx = int(($pos[0] + $pos[2]) / 2);
	305	my $cy = int(($pos[1] + $pos[3]) / 2);
	306
	307	print "# @pos cx $cx cy $cy\n";
	308	okmatchcolor($img, $cx, $pos[1]-1, @base_color, "outer top edge");
	309	okmatchcolor($img, $cx, $pos[3], @base_color, "outer bottom edge");
	310	okmatchcolor($img, $pos[0]-1, $cy, @base_color, "outer left edge");
	311	okmatchcolor($img, $pos[2], $cy, @base_color, "outer right edge");
	312
	313	okmismatchcolor($img, $cx, $pos[1], @base_color, "inner top edge");
	314	okmismatchcolor($img, $cx, $pos[3]-1, @base_color, "inner bottom edge");
	315	okmismatchcolor($img, $pos[0], $cy, @base_color, "inner left edge");
3a6bb91b AMH	316	# okmismatchcolor($img, $pos[2]-1, $cy, @base_color, "inner right edge");
	317	# XXX: This gets triggered by a freetype2 bug I think
	318	# $ rpm -qa \| grep freetype
	319	# freetype-2.1.3-6
	320	#
	321	# (addi: 4/1/2004).
	322
3799c4d1 TC	323	cross($img, $x, $y, 'FF0000');
	324	cross($img, $cx, $pos[1]-1, '0000FF');
	325	cross($img, $cx, $pos[3], '0000FF');
	326	cross($img, $pos[0]-1, $cy, '0000FF');
	327	cross($img, $pos[2], $cy, '0000FF');
	328	}
	329	else {
	330	skipx(8, "couldn't draw text");
	331	}
	332	}
	333
	334	sub okmatchcolor {
	335	my ($img, $x, $y, $r, $g, $b, $about) = @_;
	336
	337	my $c = $img->getpixel('x'=>$x, 'y'=>$y);
	338	my ($fr, $fg, $fb) = $c->rgba;
	339	okx($fr == $r && $fg == $g && $fb == $b,
	340	"want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
	341	}
	342
	343	sub okmismatchcolor {
	344	my ($img, $x, $y, $r, $g, $b, $about) = @_;
	345
	346	my $c = $img->getpixel('x'=>$x, 'y'=>$y);
	347	my ($fr, $fg, $fb) = $c->rgba;
	348	okx($fr != $r \|\| $fg != $g \|\| $fb != $b,
	349	"don't want ($r,$g,$b) found ($fr,$fg,$fb)\@($x,$y) $about");
	350	}
	351
	352	sub cross {
	353	my ($img, $x, $y, $color) = @_;
	354
	355	$img->setpixel('x'=>[$x, $x, $x, $x, $x, $x-2, $x-1, $x+1, $x+2],
	356	'y'=>[$y-2, $y-1, $y, $y+1, $y+2, $y, $y, $y, $y],
	357	color => $color);
	358
	359	}