src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/Utils.pm

   1 package Font::TTF::Utils;
   2
   3 =head1 NAME
   4
   5 Font::TTF::Utils - Utility functions to save fingers
   6
   7 =head1 DESCRIPTION
   8
   9 Lots of useful functions to save my fingers, especially for trivial tables
  10
  11 =head1 FUNCTIONS
  12
  13 The following functions are exported
  14
  15 =cut
  16
  17 use strict;
  18 use vars qw(@ISA @EXPORT $VERSION @EXPORT_OK);
  19 require Exporter;
  20
  21 @ISA = qw(Exporter);
  22 @EXPORT = qw(TTF_Init_Fields TTF_Read_Fields TTF_Out_Fields TTF_Pack
  23              TTF_Unpack TTF_word_utf8 TTF_utf8_word TTF_bininfo);
  24 @EXPORT_OK = (@EXPORT, qw(XML_hexdump));
  25 $VERSION = 0.0001;
  26
  27 =head2 ($val, $pos) = TTF_Init_Fields ($str, $pos)
  28
  29 Given a field description from the C<DATA> section, creates an absolute entry
  30 in the fields associative array for the class
  31
  32 =cut
  33
  34 sub TTF_Init_Fields
  35 {
  36     my ($str, $pos, $inval) = @_;
  37     my ($key, $val, $res, $len, $rel);
  38
  39     $str =~ s/\r?\n$//o;
  40     if ($inval)
  41     { ($key, $val) = ($str, $inval); }
  42     else
  43     { ($key, $val) = split(',\s*', $str); }
  44     return (undef, undef, 0) unless (defined $key && $key ne "");
  45     if ($val =~ m/^(\+?)(\d*)(\D+)(\d*)/oi)
  46     {
  47         $rel = $1;
  48         if ($rel eq "+")
  49         { $pos += $2; }
  50         elsif ($2 ne "")
  51         { $pos = $2; }
  52         $val = $3;
  53         $len = $4;
  54     }
  55     $len = "" unless defined $len;
  56     $pos = 0 if !defined $pos || $pos eq "";
  57     $res = "$pos:$val:$len";
  58     if ($val eq "f" || $val eq 'v' || $val =~ m/^[l]/oi)
  59     { $pos += 4 * ($len ne "" ? $len : 1); }
  60     elsif ($val eq "F" || $val =~ m/^[s]/oi)
  61     { $pos += 2 * ($len ne "" ? $len : 1); }
  62     else
  63     { $pos += 1 * ($len ne "" ? $len : 1); }
  64
  65     ($key, $res, $pos);
  66 }
  67
  68
  69 =head2 TTF_Read_Fields($obj, $dat, $fields)
  70
  71 Given a block of data large enough to account for all the fields in a table,
  72 processes the data block to convert to the values in the objects instance
  73 variables by name based on the list in the C<DATA> block which has been run
  74 through C<TTF_Init_Fields>
  75
  76 =cut
  77
  78 sub TTF_Read_Fields
  79 {
  80     my ($self, $dat, $fields) = @_;
  81     my ($pos, $type, $res, $f, $arrlen, $arr, $frac);
  82
  83     foreach $f (keys %{$fields})
  84     {
  85         ($pos, $type, $arrlen) = split(':', $fields->{$f});
  86         $pos = 0 if $pos eq "";
  87         if ($arrlen ne "")
  88         { $self->{$f} = [TTF_Unpack("$type$arrlen", substr($dat, $pos))]; }
  89         else
  90         { $self->{$f} = TTF_Unpack("$type", substr($dat, $pos)); }
  91     }
  92     $self;
  93 }
  94
  95
  96 =head2 TTF_Unpack($fmt, $dat)
  97
  98 A TrueType types equivalent of Perls C<unpack> function. Thus $fmt consists of
  99 type followed by an optional number of elements to read including *. The type
 100 may be one of:
 101
 102     c       BYTE
 103     C       CHAR
 104     f       FIXED
 105     F       F2DOT14
 106     l       LONG
 107     L       ULONG
 108     s       SHORT
 109     S       USHORT
 110     v       Version number (FIXED)
 111
 112 Note that C<FUNIT>, C<FWORD> and C<UFWORD> are not data types but units.
 113
 114 Returns array of scalar (first element) depending on context
 115
 116 =cut
 117
 118 sub TTF_Unpack
 119 {
 120     my ($fmt, $dat) = @_;
 121     my ($res, $frac, $i, $arrlen, $type, @res);
 122
 123     while ($fmt =~ s/^([cflsv])(\d+|\*)?//oi)
 124     {
 125         $type = $1;
 126         $arrlen = $2;
 127         $arrlen = 1 if !defined $arrlen || $arrlen eq "";
 128         $arrlen = -1 if $arrlen eq "*";
 129
 130         for ($i = 0; ($arrlen == -1 && $dat ne "") || $i < $arrlen; $i++)
 131         {
 132             if ($type eq "f")
 133             {
 134                 ($res, $frac) = unpack("nn", $dat);
 135                 substr($dat, 0, 4) = "";
 136                 $res -= 65536 if $res > 32767;
 137                 $res += $frac / 65536.;
 138             }
 139             elsif ($type eq "v")
 140             {
 141                 ($res, $frac) = unpack("nn", $dat);
 142                 substr($dat, 0, 4) = "";
 143                 $res -= 65536 if $res > 32767;
 144                 $res = sprintf("%d.%X", $res, $frac);
 145             }
 146             elsif ($type eq "F")
 147             {
 148                 $res = unpack("n", $dat);
 149                 substr($dat, 0, 2) = "";
 150 #                $res -= 65536 if $res >= 32768;
 151                 $frac = $res & 0x3fff;
 152                 $res >>= 14;
 153                 $res -= 4 if $res > 1;
 154 #                $frac -= 16384 if $frac > 8191;
 155                 $res += $frac / 16384.;
 156             }
 157             elsif ($type =~ m/^[l]/oi)
 158             {
 159                 $res = unpack("N", $dat);
 160                 substr($dat, 0, 4) = "";
 161                 $res -= (1 << 32) if ($type eq "l" && $res >= 1 << 31);
 162             }
 163             elsif ($type =~ m/^[s]/oi)
 164             {
 165                 $res = unpack("n", $dat);
 166                 substr($dat, 0, 2) = "";
 167                 $res -= 65536 if ($type eq "s" && $res >= 32768);
 168             }
 169             elsif ($type eq "c")
 170             {
 171                 $res = unpack("c", $dat);
 172                 substr($dat, 0, 1) = "";
 173             }
 174             else
 175             {
 176                 $res = unpack("C", $dat);
 177                 substr($dat, 0, 1) = "";
 178             }
 179             push (@res, $res);
 180         }
 181     }
 182     return wantarray ? @res : $res[0];
 183 }
 184
 185
 186 =head2 $dat = TTF_Out_Fields($obj, $fields, $len)
 187
 188 Given the fields table from C<TTF_Init_Fields> writes out the instance variables from
 189 the object to the filehandle in TTF binary form.
 190
 191 =cut
 192
 193 sub TTF_Out_Fields
 194 {
 195     my ($obj, $fields, $len) = @_;
 196     my ($dat) = "\000" x $len;
 197     my ($f, $pos, $type, $res, $arr, $arrlen, $frac);
 198
 199     foreach $f (keys %{$fields})
 200     {
 201         ($pos, $type, $arrlen) = split(':', $fields->{$f});
 202         if ($arrlen ne "")
 203         { $res = TTF_Pack("$type$arrlen", @{$obj->{$f}}); }
 204         else
 205         { $res = TTF_Pack("$type", $obj->{$f}); }
 206         substr($dat, $pos, length($res)) = $res;
 207     }
 208     $dat;
 209 }
 210
 211
 212 =head2 $dat = TTF_Pack($fmt, @data)
 213
 214 The TrueType equivalent to Perl's C<pack> function. See details of C<TTF_Unpack>
 215 for how to work the $fmt string.
 216
 217 =cut
 218
 219 sub TTF_Pack
 220 {
 221     my ($fmt, @obj) = @_;
 222     my ($type, $i, $arrlen, $dat, $res, $frac);
 223
 224     $dat = '';
 225     while ($fmt =~ s/^([flscv])(\d+|\*)?//oi)
 226     {
 227         $type = $1;
 228         $arrlen = $2 || "";
 229         $arrlen = $#obj + 1 if $arrlen eq "*";
 230         $arrlen = 1 if $arrlen eq "";
 231
 232         for ($i = 0; $i < $arrlen; $i++)
 233         {
 234             $res = shift(@obj) || 0;
 235             if ($type eq "f")
 236             {
 237                 $frac = int(($res - int($res)) * 65536);
 238                 $res = (int($res) << 16) + $frac;
 239                 $dat .= pack("N", $res);
 240             }
 241             elsif ($type eq "v")
 242             {
 243                 if ($res =~ s/\.(\d+)$//o)
 244                 {
 245                     $frac = $1;
 246                     $frac .= "0" x (4 - length($frac));
 247                 }
 248                 else
 249                 { $frac = 0; }
 250                 $dat .= pack('nn', $res, eval("0x$frac"));
 251             }
 252             elsif ($type eq "F")
 253             {
 254                 $frac = int(($res - int($res)) * 16384);
 255                 $res = (int($res) << 14) + $frac;
 256                 $dat .= pack("n", $res);
 257             }
 258             elsif ($type =~ m/^[l]/oi)
 259             {
 260                 $res += 1 << 32 if ($type eq 'L' && $res < 0);
 261                 $dat .= pack("N", $res);
 262             }
 263             elsif ($type =~ m/^[s]/oi)
 264             {
 265                 $res += 1 << 16 if ($type eq 'S' && $res < 0);
 266                 $dat .= pack("n", $res);
 267             }
 268             elsif ($type eq "c")
 269             { $dat .= pack("c", $res); }
 270             else
 271             { $dat .= pack("C", $res); }
 272         }
 273     }
 274     $dat;
 275 }
 276
 277
 278 =head2 ($num, $range, $select, $shift) = TTF_bininfo($num)
 279
 280 Calculates binary search information from a number of elements
 281
 282 =cut
 283
 284 sub TTF_bininfo
 285 {
 286     my ($num, $block) = @_;
 287     my ($range, $select, $shift);
 288
 289     $range = 1;
 290     for ($select = 0; $range <= $num; $select++)
 291     { $range *= 2; }
 292     $select--; $range /= 2;
 293     $range *= $block;
 294
 295     $shift = $num * $block - $range;
 296     ($num, $range, $select, $shift);
 297 }
 298
 299
 300 =head2 TTF_word_utf8($str)
 301
 302 Returns the UTF8 form of the 16 bit string, assumed to be in big endian order,
 303 including surrogate handling
 304
 305 =cut
 306
 307 sub TTF_word_utf8
 308 {
 309     my ($str) = @_;
 310     my ($res, $i);
 311     my (@dat) = unpack("n*", $str);
 312
 313     return pack("U*", @dat) if ($] >= 5.006);
 314     for ($i = 0; $i <= $#dat; $i++)
 315     {
 316         my ($dat) = $dat[$i];
 317         if ($dat < 0x80)        # Thanks to Gisle Aas for some of his old code
 318         { $res .= chr($dat); }
 319         elsif ($dat < 0x800)
 320         { $res .= chr(0xC0 | ($dat >> 6)) . chr(0x80 | ($dat & 0x3F)); }
 321         elsif ($dat >= 0xD800 && $dat < 0xDC00)
 322         {
 323             my ($dat1) = $dat[++$i];
 324             my ($top) = (($dat & 0x3C0) >> 6) + 1;
 325             $res .= chr(0xF0 | ($top >> 2))
 326                   . chr(0x80 | (($top & 1) << 4) | (($dat & 0x3C) >> 2))
 327                   . chr(0x80 | (($dat & 0x3) << 4) | (($dat1 & 0x3C0) >> 6))
 328                   . chr(0x80 | ($dat1 & 0x3F));
 329         } else
 330         { $res .= chr(0xE0 | ($dat >> 12)) . chr(0x80 | (($dat >> 6) & 0x3F))
 331                 . chr(0x80 | ($dat & 0x3F)); }
 332     }
 333     $res;
 334 }
 335
 336
 337 =head2 TTF_utf8_word($str)
 338
 339 Returns the 16-bit form in big endian order of the UTF 8 string, including
 340 surrogate handling to Unicode.
 341
 342 =cut
 343
 344 sub TTF_utf8_word
 345 {
 346     my ($str) = @_;
 347     my ($res);
 348
 349     return pack("n*", unpack("U*", $str)) if ($^V ge v5.6.0);
 350     $str = "$str";              # copy $str
 351     while (length($str))        # Thanks to Gisle Aas for some of his old code
 352     {
 353         $str =~ s/^[\x80-\xBF]+//o;
 354         if ($str =~ s/^([\x00-\x7F]+)//o)
 355         { $res .= pack("n*", unpack("C*", $1)); }
 356         elsif ($str =~ s/^([\xC0-\xDF])([\x80-\xBF])//o)
 357         { $res .= pack("n", ((ord($1) & 0x1F) << 6) | (ord($2) & 0x3F)); }
 358         elsif ($str =~ s/^([\0xE0-\xEF])([\x80-\xBF])([\x80-\xBF])//o)
 359         { $res .= pack("n", ((ord($1) & 0x0F) << 12)
 360                           | ((ord($2) & 0x3F) << 6)
 361                           | (ord($3) & 0x3F)); }
 362         elsif ($str =~ s/^([\xF0-\xF7])([\x80-\xBF])([\x80-\xBF])([\x80-\xBF])//o)
 363         {
 364             my ($b1, $b2, $b3, $b4) = (ord($1), ord($2), ord($3), ord($4));
 365             $res .= pack("n", ((($b1 & 0x07) << 8) | (($b2 & 0x3F) << 2)
 366                             | (($b3 & 0x30) >> 4)) + 0xD600);  # account for offset
 367             $res .= pack("n", ((($b3 & 0x0F) << 6) | ($b4 & 0x3F)) + 0xDC00);
 368         }
 369         elsif ($str =~ s/^[\xF8-\xFF][\x80-\xBF]*//o)
 370         { }
 371     }
 372     $res;
 373 }
 374
 375
 376 =head2 XML_hexdump($context, $dat)
 377
 378 Dumps out the given data as a sequence of <data> blocks each 16 bytes wide
 379
 380 =cut
 381
 382 sub XML_hexdump
 383 {
 384     my ($context, $depth, $dat) = @_;
 385     my ($fh) = $context->{'fh'};
 386     my ($i, $len, $out);
 387
 388     $len = length($dat);
 389     for ($i = 0; $i < $len; $i += 16)
 390     {
 391         $out = join(' ', map {sprintf("%02X", ord($_))} (split('', substr($dat, $i, 16))));
 392         $fh->printf("%s<data addr='%04X'>%s</data>\n", $depth, $i, $out);
 393     }
 394 }
 395
 396
 397 =head2 XML_outhints
 398
 399 Converts a binary string of hinting code into a textual representation
 400
 401 =cut
 402
 403 {
 404     my (@hints) = (
 405     ['SVTCA[0]'], ['SVTCA[1]'], ['SPVTCA[0]'], ['SPVTCA[1]'], ['SFVTCA[0]'], ['SFVTCA[1]'], ['SPVTL[0]'], ['SPVTL[1]'],
 406     ['SFVTL[0]'], ['SFVTL[1]'], ['SPVFS'], ['SFVFS'], ['GPV'], ['GFV'], ['SVFTPV'], ['ISECT'],
 407 # 10
 408     ['SRP0'], ['SRP1'], ['SRP2'], ['SZP0'], ['SZP1'], ['SZP2'], ['SZPS'], ['SLOOP'],
 409     ['RTG'], ['RTHG'], ['SMD'], ['ELSE'], ['JMPR'], ['SCVTCI'], ['SSWCI'], ['SSW'],
 410 # 20
 411     ['DUP'], ['POP'], ['CLEAR'], ['SWAP'], ['DEPTH'], ['CINDEX'], ['MINDEX'], ['ALIGNPTS'],
 412     [], ['UTP'], ['LOOPCALL'], ['CALL'], ['FDEF'], ['ENDF'], ['MDAP[0]'], ['MDAP[1]'],
 413 # 30
 414     ['IUP[0]'], ['IUP[1]'], ['SHP[0]'], ['SHP[1]'], ['SHC[0]'], ['SHC[1]'], ['SHZ[0]'], ['SHZ[1]'],
 415     ['SHPIX'], ['IP'], ['MSIRP[0]'], ['MSIRP[1]'], ['ALIGNRP'], ['RTDG'], ['MIAP[0]'], ['MIAP[1]'],
 416 # 40
 417     ['NPUSHB', -1, 1], ['NPUSHW', -1, 2], ['WS', 0, 0], ['RS', 0, 0], ['WCVTP', 0, 0], ['RCVT', 0, 0], ['GC[0]'], ['GC[1]'],
 418     ['SCFS'], ['MD[0]'], ['MD[1]'], ['MPPEM'], ['MPS'], ['FLIPON'], ['FLIPOFF'], ['DEBUG'],
 419 # 50
 420     ['LT'], ['LTEQ'], ['GT'], ['GTEQ'], ['EQ'], ['NEQ'], ['ODD'], ['EVEN'],
 421     ['IF'], ['EIF'], ['AND'], ['OR'], ['NOT'], ['DELTAP1'], ['SDB'], ['SDS'],
 422 # 60
 423     ['ADD'], ['SUB'], ['DIV'], ['MULT'], ['ABS'], ['NEG'], ['FLOOR'], ['CEILING'],
 424     ['ROUND[0]'], ['ROUND[1]'], ['ROUND[2]'], ['ROUND[3]'], ['NROUND[0]'], ['NROUND[1]'], ['NROUND[2]'], ['NROUND[3]'],
 425 # 70
 426     ['WCVTF'], ['DELTAP2'], ['DELTAP3'], ['DELTAC1'], ['DELTAC2'], ['DELTAC3'], ['SROUND'], ['S45ROUND'],
 427     ['JROT'], ['JROF'], ['ROFF'], [], ['RUTG'], ['RDTG'], ['SANGW'], [],
 428 # 80
 429     ['FLIPPT'], ['FLIPRGON'], ['FLIPRGOFF'], [], [], ['SCANCTRL'], ['SDPVTL[0]'], ['SDPVTL[1]'],
 430     ['GETINFO'], ['IDEF'], ['ROLL'], ['MAX'], ['MIN'], ['SCANTYPE'], ['INSTCTRL'], [],
 431 # 90
 432     [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [],
 433 # A0
 434     [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [],
 435 # B0
 436     ['PUSHB1', 1, 1], ['PUSHB2', 2, 1], ['PUSHB3', 3, 1], ['PUSHB4', 4, 1], ['PUSHB5', 5, 1], ['PUSHB6', 6, 1], ['PUSHB7', 7, 1], ['PUSHB8', 8, 1],
 437     ['PUSHW1', 1, 2], ['PUSHW2', 2, 2], ['PUSHW3', 3, 2], ['PUSHW4', 4, 2], ['PUSHW5', 5, 2], ['PUSHW6', 6, 2], ['PUSHW7', 7, 2], ['PUSHW8', 8, 2],
 438 # C0
 439     ['MDRP[0]'], ['MDRP[1]'], ['MDRP[2]'], ['MDRP[3]'], ['MDRP[4]'], ['MDRP[5]'], ['MDRP[6]'], ['MDRP[7]'],
 440     ['MDRP[8]'], ['MDRP[9]'], ['MDRP[A]'], ['MDRP[B]'], ['MDRP[C]'], ['MDRP[D]'], ['MDRP[E]'], ['MDRP[F]'],
 441 # D0
 442     ['MDRP[10]'], ['MDRP[11]'], ['MDRP[12]'], ['MDRP[13]'], ['MDRP[14]'], ['MDRP[15]'], ['MDRP[16]'], ['MDRP[17]'],
 443     ['MDRP[18]'], ['MDRP[19]'], ['MDRP[1A]'], ['MDRP[1B]'], ['MDRP[1C]'], ['MDRP[1D]'], ['MDRP[1E]'], ['MDRP[1F]'],
 444 # E0
 445     ['MIRP[0]'], ['MIRP[1]'], ['MIRP[2]'], ['MIRP[3]'], ['MIRP[4]'], ['MIRP[5]'], ['MIRP[6]'], ['MIRP[7]'],
 446     ['MIRP[8]'], ['MIRP[9]'], ['MIRP[A]'], ['MIRP[B]'], ['MIRP[C]'], ['MIRP[D]'], ['MIRP[E]'], ['MIRP[F]'],
 447 # F0
 448     ['MIRP[10]'], ['MIRP[11]'], ['MIRP[12]'], ['MIRP[13]'], ['MIRP[14]'], ['MIRP[15]'], ['MIRP[16]'], ['MIRP[17]'],
 449     ['MIRP[18]'], ['MIRP[19]'], ['MIRP[1A]'], ['MIRP[1B]'], ['MIRP[1C]'], ['MIRP[1D]'], ['MIRP[1E]'], ['MIRP[1F]']);
 450
 451     my ($i);
 452     my (%hints) = map { $_->[0] => $i++ if (defined $_->[0]); } @hints;
 453
 454     sub XML_binhint
 455     {
 456         my ($dat) = @_;
 457         my ($len) = length($dat);
 458         my ($res, $i, $text, $size, $num);
 459
 460         for ($i = 0; $i < $len; $i++)
 461         {
 462             ($text, $num, $size) = @{$hints[ord(substr($dat, $i, 1))]};
 463             $num = 0 unless (defined $num);
 464             $text = sprintf("UNK[%02X]", ord(substr($dat, $i, 1))) unless defined $text;
 465             $res .= $text;
 466             if ($num != 0)
 467             {
 468                 if ($num < 0)
 469                 {
 470                     $i++;
 471                     my ($nnum) = unpack($num == -1 ? 'C' : 'n', substr($dat, $i, -$num));
 472                     $i += -$num - 1;
 473                     $num = $nnum;
 474                 }
 475                 $res .= "\t" . join(' ', unpack($size == 1 ? 'C*' : 'n*', substr($dat, $i + 1, $num * $size)));
 476                 $i += $num * $size;
 477             }
 478             $res .= "\n";
 479         }
 480         $res;
 481     }
 482
 483     sub XML_hintbin
 484     {
 485         my ($dat) = @_;
 486         my ($l, $res, @words, $num);
 487
 488         foreach $l (split(/\s*\n\s*/, $dat))
 489         {
 490             @words = split(/\s*/, $l);
 491             next unless (defined $hints{$words[0]});
 492             $num = $hints{$words[0]};
 493             $res .= pack('C', $num);
 494             if ($hints[$num][1] < 0)
 495             {
 496                 $res .= pack($hints[$num][1] == -1 ? 'C' : 'n', $#words);
 497                 $res .= pack($hints[$num][2] == 1 ? 'C*' : 'n*', @words[1 .. $#words]);
 498             }
 499             elsif ($hints[$num][1] > 0)
 500             {
 501                 $res .= pack($hints[$num][2] == 1 ? 'C*' : 'n*', @words[1 .. $hints[$num][1]]);
 502             }
 503         }
 504         $res;
 505     }
 506 }
 507
 508
 509 =head2 make_circle($f, $cmap, [$dia, $sb, $opts])
 510
 511 Adds a dotted circle to a font. This function is very configurable. The
 512 parameters passed in are:
 513
 514 =over 4
 515
 516 =item $f
 517
 518 Font to work with. This is required.
 519
 520 =item $cmap
 521
 522 A cmap table (not the 'val' sub-element of a cmap) to add the glyph too. Optional.
 523
 524 =item $dia
 525
 526 Optional diameter for the main circle. Defaults to 80% em
 527
 528 =item $sb
 529
 530 Side bearing. The left and right side-bearings are always the same. This value
 531 defaults to 10% em.
 532
 533 =back
 534
 535 There are various options to control all sorts of interesting aspects of the circle
 536
 537 =over 4
 538
 539 =item numDots
 540
 541 Number of dots in the circle
 542
 543 =item numPoints
 544
 545 Number of curve points to use to create each dot
 546
 547 =item uid
 548
 549 Unicode reference to store this glyph under in the cmap. Defaults to 0x25CC
 550
 551 =item pname
 552
 553 Postscript name to give the glyph. Defaults to uni25CC.
 554
 555 =item -dRadius
 556
 557 Radius of each dot.
 558
 559 =back
 560
 561 =cut
 562
 563 sub make_circle
 564 {
 565     my ($font, $cmap, $dia, $sb, %opts) = @_;
 566     my ($upem) = $font->{'head'}{'unitsPerEm'};
 567     my ($glyph) = Font::TTF::Glyph->new('PARENT' => $font, 'read' => 2);
 568     my ($PI) = 3.1415926535;
 569     my ($R, $r, $xorg, $yorg);
 570     my ($i, $j, $numg, $maxp);
 571     my ($numc) = $opts{'-numDots'} || 16;
 572     my ($nump) = ($opts{'-numPoints'} * 2) || 8;
 573     my ($uid) = $opts{'-uid'} || 0x25CC;
 574     my ($pname) = $opts{'-pname'} || 'uni25CC';
 575
 576     $dia ||= $upem * .8;    # .95 to fit exactly
 577     $sb ||= $upem * .1;
 578     $R = $dia / 2;
 579     $r = $opts{'-dRadius'} || ($R * .1);
 580     ($xorg, $yorg) = ($R + $r, $R);
 581
 582     $xorg += $sb;
 583     $font->{'post'}->read;
 584     $font->{'glyf'}->read;
 585     for ($i = 0; $i < $numc; $i++)
 586     {
 587         my ($pxorg, $pyorg) = ($xorg + $R * cos(2 * $PI * $i / $numc),
 588                                     $yorg + $R * sin(2 * $PI * $i / $numc));
 589         for ($j = 0; $j < $nump; $j++)
 590         {
 591             push (@{$glyph->{'x'}}, int ($pxorg + ($j & 1 ? 1/cos(2*$PI/$nump) : 1) * $r * cos(2 * $PI * $j / $nump)));
 592             push (@{$glyph->{'y'}}, int ($pyorg + ($j & 1 ? 1/cos(2*$PI/$nump) : 1) * $r * sin(2 * $PI * $j / $nump)));
 593             push (@{$glyph->{'flags'}}, $j & 1 ? 0 : 1);
 594         }
 595         push (@{$glyph->{'endPoints'}}, $#{$glyph->{'x'}});
 596     }
 597     $glyph->{'numberOfContours'} = $#{$glyph->{'endPoints'}} + 1;
 598     $glyph->{'numPoints'} = $#{$glyph->{'x'}} + 1;
 599     $glyph->update;
 600     $numg = $font->{'maxp'}{'numGlyphs'};
 601     $font->{'maxp'}{'numGlyphs'}++;
 602
 603     $font->{'hmtx'}{'advance'}[$numg] = int($xorg + $R + $r + $sb + .5);
 604     $font->{'hmtx'}{'lsb'}[$numg] = int($xorg - $R - $r + .5);
 605     $font->{'loca'}{'glyphs'}[$numg] = $glyph;
 606     $cmap->{'val'}{$uid} = $numg if ($cmap);
 607     $font->{'post'}{'VAL'}[$numg] = $pname;
 608     delete $font->{'hdmx'};
 609     delete $font->{'VDMX'};
 610     delete $font->{'LTSH'};
 611
 612     $font->tables_do(sub {$_[0]->dirty;});
 613     $font->update;
 614     return ($numg - 1);
 615 }
 616
 617
 618 1;
 619
 620 =head1 BUGS
 621
 622 No known bugs
 623
 624 =head1 AUTHOR
 625
 626 Martin Hosken Martin_Hosken@sil.org. See L<Font::TTF::Font> for copyright and
 627 licensing.
 628
 629 =cut
 630