t/t36oofont.t

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 #use lib qw(blib/lib blib/arch);
   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 my $loaded;
  15 BEGIN { $| = 1; print "1..20\n"; }
  16 END {print "not ok 1\n" unless $loaded;}
  17 use Imager;
  18 BEGIN { require "t/testtools.pl"; }
  19 $loaded=1;
  20 okx(1, "loaded");
  21
  22 init_log("testout/t36oofont.log", 1);
  23
  24 my $fontname_tt=$ENV{'TTFONTTEST'}||'./fontfiles/dodge.ttf';
  25 my $fontname_pfb=$ENV{'T1FONTTESTPFB'}||'./fontfiles/dcr10.pfb';
  26
  27
  28 my $green=Imager::Color->new(92,205,92,128);
  29 die $Imager::ERRSTR unless $green;
  30 my $red=Imager::Color->new(205, 92, 92, 255);
  31 die $Imager::ERRSTR unless $red;
  32
  33 if (i_has_format("t1") and -f $fontname_pfb) {
  34
  35   my $img=Imager->new(xsize=>300, ysize=>100) or die "$Imager::ERRSTR\n";
  36
  37   my $font=Imager::Font->new(file=>$fontname_pfb,size=>25)
  38     or die $img->{ERRSTR};
  39
  40   okx(1, "created font");
  41
  42   okx($img->string(font=>$font, text=>"XMCLH", 'x'=>100, 'y'=>100),
  43       "draw text");
  44   $img->line(x1=>0, x2=>300, y1=>50, y2=>50, color=>$green);
  45
  46   my $text="LLySja";
  47   my @bbox=$font->bounding_box(string=>$text, 'x'=>0, 'y'=>50);
  48
  49   isx(@bbox, 8, "bounding box list length");
  50
  51   $img->box(box=>\@bbox, color=>$green);
  52
  53   # "utf8" support
  54   $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
  55   okx($img->string(font=>$font, text=>$text, 'x'=>100, 'y'=>50, utf8=>1,
  56                    overline=>1),
  57       "draw 'utf8' hand-encoded text");
  58
  59   okx($img->string(font=>$font, text=>$text, 'x'=>140, 'y'=>50, utf8=>1,
  60                    underline=>1, channel=>2),
  61       "channel 'utf8' hand-encoded text");
  62
  63   if($] >= 5.006) {
  64     eval q{$text = "A\x{2010}A"};
  65     okx($img->string(font=>$font, text=>$text, 'x'=>180, 'y'=>50,
  66                     strikethrough=>1),
  67        "draw native UTF8 text");
  68     okx($img->string(font=>$font, text=>$text, 'x'=>220, 'y'=>50, channel=>1),
  69        "channel native UTF8 text");
  70   }
  71   else {
  72     skipx(2, "perl too old for native utf8");
  73   }
  74
  75   okx($img->write(file=>"testout/t36oofont1.ppm", type=>'pnm'),
  76       "write t36oofont1.ppm")
  77     or print "# ",$img->errstr,"\n";
  78
  79 } else {
  80   skipx(8, "T1lib missing or disabled");
  81 }
  82
  83 if (i_has_format("tt") and -f $fontname_tt) {
  84
  85   my $img=Imager->new(xsize=>300, ysize=>100) or die "$Imager::ERRSTR\n";
  86
  87   my $font=Imager::Font->new(file=>$fontname_tt,size=>25)
  88     or die $img->{ERRSTR};
  89
  90   okx(1, "create TT font object");
  91
  92   okx($img->string(font=>$font, text=>"XMCLH", 'x'=>100, 'y'=>100),
  93       "draw text");
  94
  95   $img->line(x1=>0, x2=>300, y1=>50, y2=>50, color=>$green);
  96
  97   my $text="LLySja";
  98   my @bbox=$font->bounding_box(string=>$text, 'x'=>0, 'y'=>50);
  99
 100   isx(@bbox, 8, "bbox list size");
 101
 102   $img->box(box=>\@bbox, color=>$green);
 103
 104   $text = pack("C*", 0x41, 0xE2, 0x80, 0x90, 0x41);
 105   okx($img->string(font=>$font, text=>$text, 'x'=>100, 'y'=>50, utf8=>1),
 106       "draw hand-encoded UTF8 text");
 107
 108   if($] >= 5.006) {
 109     eval q{$text = "A\x{2010}A"};
 110     okx($img->string(font=>$font, text=>$text, 'x'=>200, 'y'=>50),
 111        "draw native UTF8 text");
 112   }
 113   else {
 114     skipx(1, "perl too old for native utf8");
 115   }
 116
 117   okx($img->write(file=>"testout/t36oofont2.ppm", type=>'pnm'),
 118       "write t36oofont2.ppm")
 119     or print "# ", $img->errstr,"\n";
 120
 121   okx($font->utf8, "make sure utf8 method returns true");
 122
 123   my $has_chars = $font->has_chars(string=>"\x01A");
 124   okx($has_chars eq "\x00\x01", "has_chars scalar");
 125   my @has_chars = $font->has_chars(string=>"\x01A");
 126   okx(!$has_chars[0], "has_chars list 0");
 127   okx($has_chars[1], "has_chars list 1");
 128 } else {
 129   skipx(10, "FT1.x missing or disabled");
 130 }
 131
 132 okx(1, "end");