freetype1/pascal/lib/ttload.pas

   1 (*******************************************************************
   2  *
   3  *  TTLoad.Pas                                                 1.0
   4  *
   5  *    TrueType Tables loaders
   6  *
   7  *  Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
   8  *
   9  *  This file is part of the FreeType project, and may only be used
  10  *  modified and distributed under the terms of the FreeType project
  11  *  license, LICENSE.TXT. By continuing to use, modify or distribute
  12  *  this file you indicate that you have read the license and
  13  *  understand and accept it fully.
  14  *
  15  *
  16  *  Difference between 1.0 and 1.1 : HUGE !!
  17  *
  18  *  - Changed the load model to get in touch with TTFile 1.1
  19  *  - Now loads one whole resident table in one call
  20  *  - defined resident and instance records/data
  21  *
  22  ******************************************************************)
  23
  24 Unit TTLoad;
  25
  26 interface
  27
  28 uses FreeType, TTTypes, TTTables, TTCMap, TTObjs;
  29
  30  function LookUp_TrueType_Table( face : PFace;
  31                                  aTag : string ) : int;
  32
  33  function Load_TrueType_Directory( face      : PFace;
  34                                    faceIndex : Int ) : TError;
  35
  36  function Load_TrueType_MaxProfile( face : PFace ) : TError;
  37  function Load_TrueType_Header    ( face : PFace ) : TError;
  38  function Load_TrueType_Locations ( face : PFace ) : TError;
  39  function Load_TrueType_CVT       ( face : PFace ) : TError;
  40  function Load_TrueType_CMap      ( face : PFace ) : TError;
  41  function Load_TrueType_Gasp      ( face : PFace ) : TError;
  42  function Load_TrueType_Names     ( face : PFace ) : TError;
  43  function Load_TrueType_Programs  ( face : PFace ) : TError;
  44  function Load_trueType_Postscript( face : PFace ) : TError;
  45  function Load_TrueType_OS2       ( face : PFace ) : TError;
  46  function Load_TrueType_HDMX      ( face : PFace ) : TError;
  47
  48  function Load_TrueType_Metrics_Header( face     : PFace;
  49                                         vertical : Boolean ) : TError;
  50
  51  function Load_TrueType_Any( face        : PFace;
  52                              tag         : longint;
  53                              offset      : longint;
  54                              var buffer;
  55                              var length  : longint ) : TError;
  56
  57 implementation
  58
  59 uses TTError, TTMemory, TTFile, TTCalc;
  60
  61   (* Composite glyph decoding flags *)
  62
  63 (*******************************************************************
  64  *
  65  *  Function    :  LookUp_TrueType_Table
  66  *
  67  *  Description :  Looks for a TrueType table by name
  68  *
  69  *  Input  :  face   resident table to look for
  70  *            aTag        searched tag
  71  *
  72  *  Output :  index of table if found, -1 otherwise.
  73  *
  74  ******************************************************************)
  75
  76  function LookUp_TrueType_Table( face : PFace;
  77                                  aTag : string ) : int;
  78  var
  79    ltag : Long;
  80    i   : int;
  81  begin
  82    ltag := (Long(ord(aTag[1])) shl 24) +  (Long(ord(aTag[2])) shl 16) +
  83            (Long(ord(aTag[3])) shl 8 ) +   Long(ord(aTag[4]));
  84
  85    for i := 0 to face^.numTables-1 do
  86      begin
  87
  88        if face^.dirTables^[i].Tag = lTag then
  89          begin
  90            LookUp_TrueType_Table := i;
  91            exit;
  92          end
  93      end;
  94
  95    (* couldn't find the table *)
  96    LookUp_TrueType_Table := -1;
  97  end;
  98
  99
 100  function LookUp_Mandatory_Table( face : PFace;
 101                                   aTag : string ) : int;
 102  var
 103    table : int;
 104  begin
 105    table := LookUp_TrueType_Table( face, aTag );
 106    if table < 0 then
 107      error := TT_Err_Table_Missing;
 108
 109    LookUp_Mandatory_Table := table;
 110  end;
 111
 112 (*******************************************************************
 113  *
 114  *  Function    :  Load_TrueType_Collection
 115  *
 116  *  Description :
 117  *
 118  *  Input  :  face
 119  *
 120  *  Output :  True on success. False on failure
 121  *
 122  *  Notes : A table directory doesn't own subttables. There is no
 123  *          constructor or destructor for it.
 124  *
 125  ******************************************************************)
 126
 127  function Load_TrueType_Collection( face : PFace ) : TError;
 128  var
 129    n : Int;
 130  const
 131    TTC_Tag = ( ord('t') shl 24 ) +
 132              ( ord('t') shl 16 ) +
 133              ( ord('c') shl 8  ) +
 134              ( ord(' ')        );
 135  begin
 136    Load_TrueType_Collection := Failure;
 137
 138    with face^.ttcHeader do
 139    begin
 140
 141      if TT_Seek_File( 0 )     or
 142         TT_Access_Frame( 12 ) then exit;
 143
 144      Tag      := Get_ULong;
 145      version  := Get_Long;
 146      dirCount := Get_Long;
 147
 148      TT_Forget_Frame;
 149
 150      if Tag <> TTC_Tag then
 151      begin
 152        Tag            := 0;
 153        version        := 0;
 154        dirCount       := 0;
 155        tableDirectory := nil;
 156
 157        error := TT_Err_File_Is_Not_Collection;
 158        exit;
 159      end;
 160
 161      if Alloc( tableDirectory, dirCount * sizeof(ULong) ) or
 162         TT_Access_Frame( dirCount*4 ) then exit;
 163
 164      for n := 0 to dirCount-1 do
 165        tableDirectory^[n] := Get_ULong;
 166
 167      TT_Forget_Frame;
 168    end;
 169
 170    Load_TrueType_Collection := Success;
 171  end;
 172
 173 (*******************************************************************
 174  *
 175  *  Function    :  Load_TrueType_Directory
 176  *
 177  *  Description :
 178  *
 179  *  Input  :  face
 180  *
 181  *  Output :  True on success. False on failure
 182  *
 183  *  Notes : A table directory doesn't own subttables. There is no
 184  *          constructor or destructor for it.
 185  *
 186  ******************************************************************)
 187
 188  function Load_TrueType_Directory( face      : PFace;
 189                                    faceIndex : Int ) : TError;
 190  var
 191    n        : Int;
 192    tableDir : TTableDir;
 193  begin
 194     Load_TrueType_Directory := Failure;
 195
 196     {$IFDEF DEBUG} Write('Directory '); {$ENDIF}
 197
 198     if Load_TrueType_Collection(face) then
 199       begin
 200         if error <> TT_Err_File_Is_Not_Collection then
 201           exit;
 202
 203         (* The file isn't a collection, exit if index isn't 0 *)
 204         if faceIndex <> 0 then
 205           exit;
 206
 207         error := TT_Err_Ok;
 208
 209         (* Now skip to the beginning of the file *)
 210         if TT_Seek_File(0) then
 211           exit;
 212       end
 213     else
 214       begin
 215         (* file is a collection. Check the index *)
 216         if ( faceIndex < 0 ) or
 217            ( faceIndex >= face^.ttcHeader.dirCount ) then
 218           begin
 219             error := TT_Err_Bad_Argument;
 220             exit;
 221           end;
 222
 223         (* select a TT Font within the ttc file *)
 224         if TT_Seek_File( face^.ttcHeader.tableDirectory^[faceIndex] ) then
 225           exit;
 226       end;
 227
 228     if TT_Access_Frame( 12 ) then
 229       exit;
 230
 231     tableDir.version   := GET_Long;
 232     tableDir.numTables := GET_UShort;
 233
 234     tableDir.searchRange   := GET_UShort;
 235     tableDir.entrySelector := GET_UShort;
 236     tableDir.rangeShift    := GET_UShort;
 237
 238     {$IFDEF DEBUG} Writeln('Tables number : ', tableDir.numTables ); {$ENDIF}
 239
 240     TT_Forget_Frame;
 241
 242     (* Check that we have a 'sfnt' format there *)
 243     if (tableDir.version <> $10000   ) and     (* MS fonts  *)
 244        (tableDir.version <> $74727565) then    (* Mac fonts *)
 245     begin
 246       {$IFDEF DEBUG} Writeln('Invalid font format'); {$ENDIF}
 247       error := TT_Err_Invalid_File_Format;
 248       exit;
 249     end;
 250
 251     with face^ do
 252     begin
 253
 254       numTables := tableDir.numTables;
 255
 256       if Alloc( dirTables, numTables * sizeof( TTableDirEntry ) ) or
 257          TT_Access_Frame( 16 * numTables ) then exit;
 258
 259       for n := 0 to numTables-1 do with dirTables^[n] do
 260       begin
 261         Tag        := GET_ULong;
 262         Checksum   := GET_ULong;
 263         Offset     := GET_Long;
 264         Length     := Get_Long;
 265       end;
 266
 267       TT_Forget_Frame;
 268
 269    end;
 270
 271    {$IFDEF DEBUG} Writeln('loaded'); {$ENDIF}
 272
 273    Load_TrueType_Directory := Success;
 274  end;
 275
 276 (*******************************************************************
 277  *
 278  *  Function    :  Load_TrueType_MaxProfile
 279  *
 280  *  Description :
 281  *
 282  *  Input  :  face
 283  *
 284  *  Output :  True on success. False on failure
 285  *
 286  *  Notes : A maximum profile is a static table that owns no
 287  *          subttable. It has then no constructor nor destructor
 288  *
 289  ******************************************************************)
 290
 291  function Load_TrueType_MaxProfile( face : PFace ) : TError;
 292  var
 293    table : int;
 294  begin
 295
 296    Load_TrueType_MaxProfile := Failure;
 297
 298    {$IFDEF DEBUG} Write('MaxProfile '); {$ENDIF}
 299
 300    table := LookUp_Mandatory_Table( face, 'maxp');
 301    if table < 0 then exit;
 302
 303    with face^ do
 304    begin
 305
 306      if TT_Seek_File( dirTables^[table].Offset ) or
 307         TT_Access_Frame( 32 ) then exit;
 308
 309      with MaxProfile do
 310       begin
 311
 312         ULong(Version) := GET_ULong;
 313
 314         numGlyphs   := GET_UShort;
 315         maxPoints   := GET_UShort;
 316         maxContours := GET_UShort;
 317
 318         maxCompositePoints   := GET_UShort;
 319         maxCompositeContours := GET_UShort;
 320         maxZones             := GET_UShort;
 321         maxTwilightPoints    := GET_UShort;
 322         maxStorage           := GET_UShort;
 323         maxFunctionDefs      := GET_UShort;
 324         maxINstructionDefs   := GET_UShort;
 325         maxStackElements     := GET_UShort;
 326
 327         maxSizeOfInstructions := GET_UShort;
 328         maxComponentElements  := GET_UShort;
 329         maxComponentDepth     := GET_UShort;
 330       end;
 331
 332      TT_Forget_Frame;
 333
 334     (* XXX : an adjustement that is necessary to load certain */
 335     /*       broken fonts like "Keystrokes MT" :-(            */
 336     /*                                                        */
 337     /*   We allocate 64 function entries by default when      */
 338     /*   the maxFunctionDefs field is null.                   *)
 339
 340     (*   otherwise, we increment this field by one, in order  *)
 341     (*   to load some old Apple fonts..                       *)
 342
 343      if maxProfile.maxFunctionDefs = 0 then
 344        maxProfile.maxFunctionDefs := 64;
 345
 346      numGlyphs := MaxProfile.numGlyphs;
 347      (* compute number of glyphs *)
 348
 349      maxPoints := MaxProfile.maxCompositePoints;
 350      if (maxPoints < MaxProfile.maxPoints) then
 351        maxPoints := MaxProfile.maxPoints;
 352      (* compute max number of points *)
 353
 354      maxContours := MaxProfile.maxCompositeContours;
 355      if maxContours < MaxProfile.maxContours then
 356        maxContours := MaxProfile.maxContours;
 357      (* compute max number of contours *)
 358
 359      maxComponents := MaxProfile.maxComponentElements +
 360                       MaxProfile.maxComponentDepth;
 361      (* compute max number of components for glyph loading *)
 362
 363      (* XXX: some fonts have maxComponents set to 0; we will *)
 364      (*      then use 16 of them by default                  *)
 365      if maxComponents = 0 then maxComponents := 16;
 366
 367      (* We also increase maxPoints and maxContours in order to support *)
 368      (* some broken fonts                                              *)
 369      inc( maxPoints,   8 );
 370      inc( maxContours, 4 );
 371    end;
 372
 373    {$IFDEF DEBUG} Writeln('loaded'); {$ENDIF}
 374
 375    Load_TrueType_MaxProfile := Success;
 376  end;
 377
 378 (*******************************************************************
 379  *
 380  *  Function    :  Load_TrueType_Gasp
 381  *
 382  *  Description :
 383  *
 384  *  Input  :  face
 385  *
 386  ******************************************************************)
 387
 388  function Load_TrueType_Gasp( face : PFace ) : TError;
 389  var
 390    gRanges  : PGaspRanges;
 391    table, i : Int;
 392  label
 393    Fail;
 394  begin
 395    Load_TrueType_Gasp := Failure;
 396
 397    with face^.gasp do
 398    begin
 399      version    := 0;
 400      numRanges  := 0;
 401      gaspRanges := nil;
 402    end;
 403
 404    table := Lookup_TrueType_Table( face, 'gasp' );
 405    if ( table < 0 ) then
 406    begin
 407      Load_TrueType_Gasp := Success;
 408      exit;
 409    end;
 410
 411    if TT_Seek_File( face^.dirTables^[table].Offset ) or
 412       TT_Access_Frame( 4 ) then exit;
 413
 414    with face^.gasp do
 415    begin
 416      version    := Get_UShort;
 417      numRanges  := Get_UShort;
 418      gaspRanges := nil;
 419    end;
 420
 421    TT_Forget_Frame;
 422
 423    if Alloc( gRanges, face^.gasp.numRanges * sizeof(TGaspRange) ) or
 424       TT_Access_Frame( face^.gasp.numRanges * 4 ) then
 425      goto Fail;
 426
 427    face^.gasp.gaspRanges := gRanges;
 428
 429    for i := 0 to face^.gasp.numRanges-1 do
 430      with gRanges^[i] do
 431      begin
 432        maxPPEM  := Get_UShort;
 433        gaspFlag := Get_UShort;
 434      end;
 435
 436    TT_Forget_Frame;
 437
 438    Load_TrueType_Gasp := Success;
 439    exit;
 440
 441  Fail:
 442    Free( gRanges );
 443    face^.gasp.numRanges := 0;
 444  end;
 445
 446
 447 (*******************************************************************
 448  *
 449  *  Function    :  Load_TrueType_Header
 450  *
 451  *  Description :  Load the TrueType header table in the resident
 452  *                 table
 453  *
 454  *  Input  :  face   current leading segment.
 455  *
 456  *  Output :  True on success. False on failure
 457  *
 458  *  Notes : A font header is a static table that owns no
 459  *          subttable. It has then no constructor nor destructor
 460  *
 461  ******************************************************************)
 462
 463  function  Load_TrueType_Header( face : PFace ) : TError;
 464  var
 465    i : int;
 466  begin
 467    Load_TrueType_Header := Failure;
 468
 469    {$IFDEF DEBUG} Write('Header '); {$ENDIF}
 470
 471    i := LookUp_Mandatory_Table(face, 'head');
 472    if i <= 0 then exit;
 473
 474    with face^ do
 475    begin
 476
 477      if TT_Seek_File( dirTables^[i].offset ) or
 478         TT_Access_Frame( 54 ) then exit;
 479
 480      with FontHeader do
 481      begin
 482
 483        ULong(Table_Version) := GET_ULong;
 484        ULong(Font_Revision) := GET_ULong;
 485
 486        Checksum_Adjust := GET_Long;
 487        Magic_Number    := GET_Long;
 488
 489        Flags        := GET_UShort;
 490        Units_Per_EM := GET_UShort;
 491
 492        Created [0] := GET_Long; Created [1] := GET_Long;
 493        Modified[0] := GET_Long; Modified[1] := GET_Long;
 494
 495        xMin := GET_Short;
 496        yMin := GET_SHort;
 497        xMax := GET_SHort;
 498        yMax := GET_Short;
 499
 500        Mac_Style       := GET_UShort;
 501        Lowest_Rec_PPEM := GET_UShort;
 502
 503        Font_Direction      := GET_Short;
 504        Index_To_Loc_Format := GET_Short;
 505        Glyph_Data_Format   := GET_Short;
 506
 507        {$IFDEF DEBUG} Writeln('Units per EM : ',Units_Per_EM ); {$ENDIF}
 508
 509      end;
 510
 511      TT_Forget_Frame;
 512
 513    end;
 514
 515    {$IFDEF DEBUG} Writeln('loaded'); {$ENDIF}
 516
 517    Load_TrueType_Header := Success;
 518  end;
 519
 520 (*******************************************************************
 521  *
 522  *  Function    : Load_TrueType_Metrics
 523  *
 524  *  Description : Load TrueType metrics either from the "hmtx" or
 525  *                "vmtx" table.
 526  *
 527  *  Input  :  face      current resident leading segment
 528  *            vertical  boolean. When set, try to load the vertical
 529  *                      header.
 530  *
 531  *  Output :  True on success. False on failure
 532  *
 533  ******************************************************************)
 534
 535  function Load_TrueType_Metrics( face     : PFace;
 536                                  vertical : Boolean ) : TError;
 537  var
 538    table, n           : int;
 539    num_longs          : int;
 540    num_shorts         : int;
 541    num_shorts_checked : int;
 542    temp               : Short;
 543
 544    header     : ^TT_Horizontal_Header;
 545
 546    shorts     : ^PTableShortMetrics;
 547    longs      : ^PTableLongMetrics;
 548
 549  begin
 550    Load_TrueType_Metrics := Failure;
 551
 552    {$IFDEF DEBUG}
 553    if vertical then
 554      Write('vmtx ')
 555    else
 556      Write('hmtx ');
 557    {$ENDIF}
 558
 559    if vertical then
 560      begin
 561
 562        table := LookUp_TrueType_Table( face, 'vmtx' );
 563        if table < 0 then
 564          begin
 565            (* This is an optional table. Return silently if it *)
 566            (* wasn't found. Note : some fonts have a vertical  *)
 567            (* header, but no 'vmtx'. E.g. : mingliu.ttf        *)
 568
 569            face^.verticalHeader.number_Of_VMetrics := 0;
 570            Load_TrueType_Metrics := Success;
 571            exit;
 572          end;
 573
 574        header := @TT_Horizontal_Header(face^.verticalHeader);
 575      end
 576    else
 577      begin
 578        table := LookUp_Mandatory_Table( face, 'hmtx' );
 579        if table < 0 then
 580          exit;
 581
 582        header := @face^.horizontalHeader;
 583      end;
 584
 585
 586    shorts     := @PTableShortMetrics(header^.short_metrics);
 587    longs      := @PTableLongMetrics (header^.long_metrics );
 588
 589    num_longs  := header^.number_Of_HMetrics;
 590    num_shorts := face^.numGlyphs - num_longs;
 591
 592    num_shorts_checked := (face^.dirTables^[table].Length - num_longs*4) div 2;
 593
 594    if num_shorts < 0 then
 595    begin
 596      {$IFDEF DEBUG} Writeln('!! More metrics than glyphs !\n'); {$ENDIF}
 597      if vertical then  error := TT_Err_Invalid_Vert_Metrics
 598                  else  error := TT_Err_Invalid_Horiz_Metrics;
 599      exit;
 600    end;
 601
 602    if Alloc( longs^,  sizeof(TLongMetrics) * num_longs )   or
 603       Alloc( shorts^, sizeof(TShortMetrics)* num_shorts )  or
 604
 605       TT_Seek_File( face^.dirTables^[table].Offset )       or
 606       TT_Access_Frame( face^.dirTables^[table].Length )    then exit;
 607
 608    for n := 0 to num_longs-1 do with longs^^[n] do
 609    begin
 610      advance := GET_UShort;
 611      bearing := GET_Short;
 612    end;
 613
 614    (* do we have an inconsistent number of metric values ? *)
 615    if num_shorts > num_shorts_checked then
 616      begin
 617        for n := 0 to num_shorts_checked-1 do
 618          shorts^^[n] := GET_Short;
 619
 620         (* we fill up the missing left side bearings with the    *)
 621         (* last valid value. Since this will occur for buggy CJK *)
 622         (* fonts usually, nothing serious will happen.           *)
 623
 624         temp := shorts^^[num_shorts_checked-1];
 625
 626         for n := num_shorts_checked to num_shorts-1 do
 627           shorts^^[n] := temp;
 628      end
 629    else
 630      for n := 0 to num_shorts-1 do
 631        shorts^^[n] := GET_Short;
 632
 633    TT_Forget_Frame;
 634
 635    {$IFDEF DEBUG} Writeln('loaded'); {$ENDIF}
 636
 637    Load_TrueType_Metrics := Success;
 638  end;
 639
 640
 641 (*******************************************************************
 642  *
 643  *  Function    : Load_TrueType_Metrics_Header
 644  *
 645  *  Description :
 646  *
 647  *  Input  :  face      current resident leading segment
 648  *            vertical  boolean. When set, try to load the vertical
 649  *                      header.
 650  *
 651  *  Output :  True on success. False on failure
 652  *
 653  ******************************************************************)
 654
 655  function Load_TrueType_Metrics_Header( face     : PFace;
 656                                         vertical : Boolean ) : TError;
 657  var
 658    table  : int;
 659    header : ^TT_Horizontal_Header;
 660  begin
 661    Load_TrueType_Metrics_Header := Failure;
 662
 663     {$IFDEF DEBUG}
 664     if vertical then
 665       Write('Vertical Header ')
 666     else
 667       Write('Horizontal Header ');
 668     {$ENDIF}
 669
 670    if vertical then
 671      begin
 672        face^.verticalInfo := False;
 673
 674        (* the vertical header is an optional table.. so return *)
 675        (* silently if we don't find it                         *)
 676        table := LookUp_TrueType_Table( face, 'vhea' );
 677        if (table < 0) then
 678          begin
 679            Load_TrueType_Metrics_Header := Success;
 680            exit;
 681          end;
 682
 683        face^.verticalInfo := True;
 684        header := @TT_Horizontal_Header(face^.verticalHeader);
 685      end
 686    else
 687      begin
 688        table := LookUp_Mandatory_Table( face, 'hhea');
 689        if ( table < 0 ) then
 690          exit;
 691        header := @face^.horizontalHeader;
 692      end;
 693
 694    with face^ do
 695    begin
 696
 697      if TT_Seek_File( dirTables^[table].Offset ) or
 698         TT_Access_Frame( 36 ) then
 699         exit;
 700
 701      with header^ do
 702      begin
 703
 704        Long(Version) := GET_ULong;
 705        Ascender      := GET_Short;
 706        Descender     := GET_Short;
 707        Line_Gap      := GET_Short;
 708
 709        advance_Width_Max := GET_UShort;
 710
 711        min_Left_Side_Bearing  := GET_Short;
 712        min_Right_Side_Bearing := GET_Short;
 713        xMax_Extent            := GET_Short;
 714        caret_Slope_Rise       := GET_Short;
 715        caret_Slope_Run        := GET_Short;
 716
 717        Reserved[0] := GET_Short;  (* this is cared offset for vertical *)
 718
 719        Reserved[1] := GET_Short;
 720        Reserved[2] := GET_Short;
 721        Reserved[3] := GET_Short;
 722        Reserved[4] := GET_Short;
 723
 724        metric_Data_Format := GET_Short;
 725        number_Of_HMetrics := GET_UShort;
 726
 727        short_metrics := nil;
 728        long_metrics  := nil;
 729
 730      end;
 731
 732      TT_Forget_Frame;
 733
 734    end;
 735
 736    {$IFDEF DEBUG} Writeln('loaded'); {$ENDIF}
 737
 738    Load_TrueType_Metrics_Header := Load_TrueType_Metrics( face, vertical );
 739  end;
 740
 741 (*******************************************************************
 742  *
 743  *  Function    :  Load_TrueType_Locations
 744  *
 745  *  Description :  Loads the location table in resident table
 746  *
 747  *  Input  :  face     Current Resident Leading Segment
 748  *
 749  *  Output :  True on success. False on failure
 750  *
 751  *  NOTES :
 752  *
 753  *    The Font Header *must* be loaded in the leading segment
 754  *    before calling this function.
 755  *
 756  *    This table is destroyed directly by the resident destructor.
 757  *
 758  ******************************************************************)
 759
 760  function Load_TrueType_Locations( face : PFace ): TError;
 761  var
 762    t, n        : int;
 763    LongOffsets : int;
 764  begin
 765
 766    Load_TrueType_Locations := Failure;
 767
 768    {$IFDEF DEBUG} Write('Locations '); {$ENDIF}
 769
 770    with face^ do
 771    begin
 772
 773      LongOffsets :=  fontHeader.Index_To_Loc_Format;
 774
 775      t := LookUp_Mandatory_Table( face, 'loca' );
 776      if t < 0 then exit;
 777
 778      if TT_Seek_File( dirTables^[T].Offset ) then exit;
 779
 780      if LongOffsets <> 0 then
 781        begin
 782
 783          numLocations := dirTables^[T].Length shr 2;
 784
 785          {$IFDEF DEBUG}
 786          Writeln('Glyph locations # ( 32 bits offsets ) : ', numLocations );
 787          {$ENDIF}
 788
 789          if Alloc( glyphLocations, sizeof(Long)*numLocations ) or
 790             TT_Access_Frame( numLocations*4 ) then exit;
 791
 792          for n := 0 to numLocations-1 do
 793            glyphLocations^[n] := GET_Long;
 794
 795          TT_Forget_Frame;
 796
 797        end
 798      else
 799        begin
 800          numLocations := dirTables^[T].Length shr 1;
 801
 802          {$IFDEF DEBUG}
 803          Writeln('Glyph locations # ( 16 bits offsets ) : ', numLocations );
 804          {$ENDIF}
 805
 806          if Alloc( glyphLocations, sizeof(Long)*numLocations ) or
 807             TT_Access_Frame( numLocations*2 ) then exit;
 808
 809          for n := 0 to numLocations-1 do
 810            glyphLocations^[n] := Long(GET_UShort) * 2;
 811
 812          TT_Forget_Frame;
 813        end;
 814
 815    end;
 816
 817    {$IFDEF DEBUG} Writeln('loaded'); {$ENDIF}
 818
 819    Load_TrueType_Locations := Success;
 820  end;
 821
 822
 823 (*******************************************************************
 824  *
 825  *  Function    :  Load_TrueType_Names
 826  *
 827  *  Description :  Loads the name table into the face table
 828  *
 829  *  Input  :  face
 830  *
 831  *  Output :  True on success. False on failure
 832  *
 833  *  Notes  :  This attribute table is destroyed by the resident
 834  *            destructor.
 835  *
 836  ******************************************************************)
 837
 838   function Load_TrueType_Names( face : PFace ) : TError;
 839   var
 840     table, i : Int;
 841     bytes    : Long;
 842   begin
 843     Load_TrueType_Names := Failure;
 844
 845     table := Lookup_Mandatory_Table( face, 'name' );
 846     if table < 0 then exit;
 847
 848     with face^.nameTable do
 849     begin
 850       (* Seek to the beginning of the table and check the frame access. *)
 851       if TT_Seek_File( face^.dirTables^[table].Offset ) or
 852          TT_Access_Frame( 6 ) then exit;
 853
 854       format         := GET_UShort;
 855       numNameRecords := GET_UShort;
 856       storageOffset  := GET_UShort;
 857
 858       TT_Forget_Frame;
 859
 860       if Alloc( names, numNameRecords*sizeof(TName_Record) ) or
 861          TT_Access_Frame( numNameRecords*12 ) then
 862       begin
 863         numNameRecords := 0;
 864         exit;
 865       end;
 866
 867       (* Load the name records and determine how much storage is needed *)
 868       (* to hold the strings themselves                                 *)
 869
 870       bytes := 0;
 871       for i := 0 to numNameRecords-1 do with names^[i] do
 872       begin
 873         platformID := GET_UShort;
 874         encodingID := GET_UShort;
 875         languageID := GET_UShort;
 876         nameID     := GET_UShort;
 877         length     := GET_UShort;
 878         offset     := GET_UShort;
 879
 880         (* this test takes care of 'holes' in the names tabls, as *)
 881         (* reported by Erwin                                      *)
 882         if Offset + Length > bytes then
 883           bytes := Offset + Length;
 884       end;
 885
 886       TT_Forget_Frame;
 887
 888       storage := nil;
 889       if bytes > 0 then
 890       begin
 891         if Alloc( storage, bytes ) then exit;
 892
 893         if TT_Read_At_File( face^.dirTables^[table].Offset + storageOffset,
 894                             storage^, bytes ) then
 895         begin
 896           Free(storage);
 897           exit;
 898         end;
 899       end;
 900
 901     end;
 902
 903     Load_TrueType_Names := Success;
 904     exit;
 905   end;
 906
 907 (*******************************************************************
 908  *
 909  *  Function    :  Load_TrueType_CVT
 910  *
 911  *  Description :
 912  *
 913  *  Input  :  face
 914  *
 915  *  Output :  True on success. False on failure
 916  *
 917  *  Notes  :  This attribute table is destroyed by the resident
 918  *            destructor.
 919  *
 920  ******************************************************************)
 921
 922  function Load_TrueType_CVT( face : PFace ): TError;
 923  var
 924    t, n : Int;
 925  begin
 926    Load_TrueType_CVT := Failure;
 927
 928    {$IFDEF DEBUG} Write('CVT '); {$ENDIF}
 929
 930    (* the CVT table is optional *)
 931
 932    t := LookUp_TrueType_Table( face, 'cvt ');
 933    if t < 0 then
 934    begin
 935      face^.cvt     := nil;
 936      face^.cvtSize := 0;
 937      Load_TrueType_CVT := Success;
 938      {$IFDEF DEBUG}  writeln('none'); {$ENDIF}
 939      exit;
 940    end;
 941
 942    with face^ do
 943    begin
 944
 945      cvtSize := dirTables^[t].Length div 2;
 946
 947      if Alloc( cvt, sizeof(Short)*cvtSize )  or
 948
 949         TT_Seek_File( dirTables^[t].Offset ) or
 950
 951         TT_Access_Frame( 2*cvtSize )         then exit;
 952
 953      for n := 0 to cvtSize-1 do
 954        cvt^[n] := GET_Short;
 955
 956      TT_Forget_Frame;
 957    end;
 958
 959    {$IFDEF DEBUG} Writeln('loaded'); {$ENDIF}
 960    Load_TrueType_CVT := Success;
 961  end;
 962
 963
 964 (*******************************************************************
 965  *
 966  *  Function    :  Load_TrueType_CMap
 967  *
 968  *  Description :
 969  *
 970  *  Input  :  face
 971  *
 972  *  Output :  True on success. False on failure
 973  *
 974  *  Notes  :  The Cmap table directory is destroyed by the resident
 975  *            destructor. The Cmap subtables must be destroyed by
 976  *            Free_CMap_Table.
 977  *
 978  ******************************************************************)
 979
 980  function Load_TrueType_CMap( face : PFace ) : TError;
 981  var
 982    off, table_start : Longint;
 983    n, limit, t      : Int;
 984
 985    cmap_dir : TCMapDir;
 986    entry    : TCMapDirEntry;
 987    cmap     : PCMapTable;
 988  label
 989    Fail;
 990  begin
 991
 992    Load_TrueType_CMap := Failure;
 993
 994    {$IFDEF DEBUG} Write('CMaps '); {$ENDIF}
 995
 996    t := LookUp_Mandatory_Table( face,'cmap' );
 997    if t < 0 then exit;
 998
 999    with face^ do
1000    begin
1001
1002      table_start := dirTables^[t].offset;
1003
1004      if TT_Seek_File( dirTables^[t].Offset ) or
1005         TT_Access_Frame( 4 )  then exit;
1006
1007      cmap_dir.tableVersionNumber := GET_UShort;
1008      cmap_dir.numCMaps           := GET_UShort;
1009
1010      TT_Forget_Frame;
1011
1012      off := TT_File_Pos;
1013
1014      (* save space in face data for cmap tables *)
1015      numCMaps := cmap_dir.numCMaps;
1016      if Alloc( cMaps, numCMaps * sizeof(TCMapTable) ) then exit;
1017
1018      for n := 0 to numCMaps-1 do
1019      begin
1020
1021        if TT_Seek_File   ( off ) or
1022           TT_Access_Frame( 8 )   then exit;
1023
1024        cmap := @cMaps^[n];
1025
1026        entry.platformID         := GET_UShort;
1027        entry.platformEncodingID := GET_UShort;
1028        entry.offset             := GET_Long;
1029
1030        cmap^.loaded             := False;
1031        cmap^.platformID         := entry.platformID;
1032        cmap^.platformEncodingID := entry.platformEncodingID;
1033
1034        TT_Forget_Frame;
1035
1036        off := TT_File_Pos;
1037
1038        if TT_Seek_File   ( table_start + entry.offset ) or
1039           TT_Access_Frame( 6 ) then exit;
1040
1041        cmap^.format  := Get_UShort;
1042        cmap^.length  := Get_UShort;
1043        cmap^.version := Get_UShort;
1044
1045        TT_Forget_Frame;
1046
1047        cmap^.offset := TT_File_Pos;
1048
1049      end;  (* for n *)
1050
1051    end;  (* with face^ *)
1052
1053    {$IFDEF DEBUG} Writeln('loaded'); {$ENDIF}
1054
1055    Load_TrueType_CMap := Success;
1056    exit;
1057
1058  Fail:
1059    Free( face^.cMaps );
1060    Load_TrueType_CMap := Failure;
1061  end;
1062
1063
1064 (*
1065  procedure Free_CMap_Table( var cmap : TCMapTable );
1066  begin
1067    if cmap.cmap0 <> nil then
1068      with cmap do
1069        case format of
1070
1071          0 : begin
1072                Free( cmap0^.glyphIdArray );
1073                Free( cmap0 );
1074              end;
1075
1076          2 : begin
1077                Free( cmap2^.glyphIdArray );
1078                Free( cmap2^.subHeaders );
1079                Free( cmap2 );
1080              end;
1081
1082          4 : begin
1083                Free( cmap4^.glyphIdArray );
1084                Free( cmap4^.segments );
1085                Free( cmap4 );
1086              end;
1087
1088          6 : begin
1089                Free( cmap6^.glyphIdArray );
1090                Free( cmap6 );
1091              end;
1092        end;
1093
1094    cmap.format  := 0;
1095    cmap.length  := 0;
1096    cmap.version := 0;
1097  end;
1098 *)
1099
1100 (*******************************************************************
1101  *
1102  *  Function    :  Load_TrueType_Programs
1103  *
1104  *  Description :  Load the Font and CVT programs in the resident
1105  *                 table
1106  *
1107  *  Input  :  face
1108  *
1109  *  Output :  True on success. False on failure
1110  *
1111  ******************************************************************)
1112
1113  function Load_TrueType_Programs( face : PFace ) : TError;
1114  var
1115    t : Int;
1116  begin
1117
1118    Load_TrueType_Programs := Failure;
1119
1120    {$IFDEF DEBUG} Write('Font program '); {$ENDIF}
1121
1122    (* The font program is optional *)
1123
1124    t := Lookup_TrueType_Table( face, 'fpgm' );
1125
1126    if t < 0 then
1127
1128      with face^ do
1129      begin
1130        fontProgram := nil;
1131        fontPgmSize := 0;
1132
1133        {$IFDEF DEBUG} Writeln('none in file'); {$ENDIF}
1134      end
1135
1136    else
1137
1138      with face^ do
1139      begin
1140
1141        fontPgmSize := dirTables^[t].Length;
1142
1143        if Alloc( fontProgram, fontPgmSize ) or
1144           TT_Read_At_File( dirTables^[t].offset,
1145                            fontProgram^,
1146                            fontPgmSize ) then exit;
1147
1148        {$IFDEF DEBUG} Writeln('loaded, ',fontPgmSize,' bytes'); {$ENDIF}
1149      end;
1150
1151    {$IFDEF DEBUG} Write('CVT program '); {$ENDIF}
1152
1153    t := LookUp_trueType_Table( face, 'prep' );
1154
1155    (* The CVT table is optional *)
1156
1157    if t < 0 then
1158
1159      with face^ do
1160      begin
1161        cvtProgram := nil;
1162        cvtPgmSize := 0;
1163
1164        {$IFDEF DEBUG} Writeln('none in file'); {$ENDIF}
1165      end
1166
1167    else
1168
1169      with face^ do
1170      begin
1171
1172        cvtPgmSize := dirTables^[t].Length;
1173
1174        if Alloc( cvtProgram, cvtPgmSize ) or
1175           TT_Read_At_File( dirTables^[t].offset,
1176                            cvtProgram^,
1177                            cvtPgmSize ) then exit;
1178
1179        {$IFDEF DEBUG} Writeln('loaded, ',cvtPgmSize,' bytes'); {$ENDIF}
1180      end;
1181
1182    Load_TrueType_Programs := Success;
1183  end;
1184
1185 (*******************************************************************
1186  *
1187  *  Function    :  Load_TrueType_OS2
1188  *
1189  *  Description :  Load the OS2 Table
1190  *
1191  *  Input  :  face
1192  *
1193  *  Output :  True on success. False on failure
1194  *
1195  ******************************************************************)
1196
1197  function Load_TrueType_OS2( face : PFace ) : TError;
1198  var
1199    table : Int;
1200    i     : Int;
1201  begin
1202    Load_TrueType_OS2 := Failure;
1203
1204    {$IFDEF DEBUG} Write('OS/2 table '); {$ENDIF}
1205
1206    (* We now support Apple fonts who do not have an OS/2 table *)
1207    table := LookUp_Mandatory_Table( face, 'OS/2' );
1208    if table < 0 then begin
1209      face^.os2.version := $FFFF;
1210      Load_TrueType_OS2 := Success;
1211      error             := TT_Err_Ok;  (* clear error *)
1212      exit;
1213    end;
1214
1215    if TT_Seek_File( face^.dirTables^[table].offset ) or
1216       TT_Access_Frame( 78 ) then exit;
1217
1218    with face^.os2 do
1219    begin
1220      version             := Get_UShort;
1221      xAvgCharWidth       := Get_Short;
1222      usWeightClass       := Get_UShort;
1223      usWidthClass        := Get_UShort;
1224      fsType              := Get_Short;
1225      ySubscriptXSize     := Get_Short;
1226      ySubscriptYSize     := Get_Short;
1227      ySubscriptXOffset   := Get_Short;
1228      ySubscriptYOffset   := Get_Short;
1229      ySuperscriptXSize   := Get_Short;
1230      ySuperscriptYSize   := Get_Short;
1231      ySuperscriptXOffset := Get_Short;
1232      ySuperscriptYOffset := Get_Short;
1233      yStrikeoutSize      := Get_Short;
1234      yStrikeoutPosition  := Get_Short;
1235      sFamilyClass        := Get_Short;
1236
1237      for i := 0 to 9 do panose[i] := Get_Byte;
1238
1239      ulUnicodeRange1 := Get_ULong;
1240      ulUnicodeRange2 := Get_ULong;
1241      ulUnicodeRange3 := Get_ULong;
1242      ulUnicodeRange4 := Get_ULong;
1243
1244      for i := 0 to 3 do achVendID[i] := Get_Byte;
1245
1246      fsSelection      := Get_UShort;
1247      usFirstCharIndex := Get_UShort;
1248      usLastCharIndex  := Get_UShort;
1249      sTypoAscender    := Get_UShort;
1250      sTypoDescender   := Get_UShort;
1251      sTypoLineGap     := Get_UShort;
1252      usWinAscent      := Get_UShort;
1253      usWinDescent     := Get_UShort;
1254
1255      TT_Forget_Frame;
1256
1257      if version >= $0001 then
1258        begin
1259          if TT_Access_Frame(8) then exit;
1260
1261          ulCodePageRange1 := Get_ULong;
1262          ulCodePageRange2 := Get_ULong;
1263
1264          TT_Forget_Frame;
1265        end
1266      else
1267        begin
1268          ulCodePageRange1 := 0;
1269          ulCodePageRange2 := 0;
1270        end;
1271
1272    end;
1273
1274    {$IFDEF DEBUG} Writeln('loaded'); {$ENDIF}
1275
1276    Load_TrueType_OS2 := Success;
1277  end;
1278
1279 (*******************************************************************
1280  *
1281  *  Function    :  Load_TrueType_Postscript
1282  *
1283  *  Description :  Load the 'post' table
1284  *
1285  *  Input  :  face
1286  *
1287  *  Output :  True on success. False on failure
1288  *
1289  ******************************************************************)
1290
1291  function Load_TrueType_Postscript( face : PFace ) : TError;
1292  var
1293    table : Int;
1294    i     : Int;
1295  begin
1296    Load_TrueType_Postscript := Failure;
1297
1298    {$IFDEF DEBUG} Write('post table '); {$ENDIF}
1299
1300    table := LookUp_TrueType_Table( face, 'post' );
1301    if table < 0 then exit;
1302
1303    if TT_Seek_File( face^.dirTables^[table].offset ) or
1304       TT_Access_Frame(32) then exit;
1305
1306    with face^.postscript do
1307    begin
1308      formatType         := Get_ULong;
1309      italicAngle        := Get_ULong;
1310      underlinePosition  := Get_Short;
1311      underlineThickness := Get_Short;
1312      isFixedPitch       := Get_ULong;
1313      minMemType42       := Get_ULong;
1314      maxMemType42       := Get_ULong;
1315      minMemType1        := Get_ULong;
1316      maxMemType1        := Get_ULong;
1317    end;
1318
1319    TT_Forget_Frame;
1320
1321    {$IFDEF DEBUG} Writeln('loaded'); {$ENDIF}
1322
1323    Load_trueType_Postscript := Success;
1324  end;
1325
1326 (*******************************************************************
1327  *
1328  *  Function    :  Load_TrueType_HDMX
1329  *
1330  *  Description :  Load the 'hdmx' tables
1331  *
1332  *  Input  :  face
1333  *
1334  *  Output :  True on success. False on failure
1335  *
1336  ******************************************************************)
1337
1338  function Load_TrueType_Hdmx( face : PFace ) : TError;
1339  var
1340    table, n   : Int;
1341    num_glyphs : Int;
1342
1343    version  : UShort;
1344    num_rec  : Short;
1345    recs     : PHdmx_Records;
1346    rec_size : Long;
1347    rec      : PHdmx_Record;
1348  label
1349    Fail;
1350  begin
1351    Load_TrueType_Hdmx := Failure;
1352
1353    with face^.hdmx do
1354    begin
1355      version     := 0;
1356      num_records := 0;
1357      records     := nil;
1358    end;
1359
1360    (* This table is optional *)
1361
1362    table := LookUp_TrueType_Table( face, 'hdmx' );
1363    if table < 0 then
1364    begin
1365      Load_TrueType_Hdmx := Success;
1366      exit;
1367    end;
1368
1369    if TT_Seek_File( face^.dirTables^[table].offset ) or
1370       TT_Access_Frame( 8 ) then exit;
1371
1372    version  := Get_UShort;
1373    num_rec  := Get_Short;
1374    rec_size := Get_Long;
1375
1376    TT_Forget_Frame;
1377
1378    (* right now, we only recognize format 0 *)
1379
1380    if version <> 0 then
1381      exit;
1382
1383    if Alloc( face^.hdmx.records, sizeof(THdmx_Record)*num_rec ) then
1384      exit;
1385
1386    face^.hdmx.num_records := num_rec;
1387    num_glyphs := face^.NumGlyphs;
1388
1389    rec_size := rec_size - num_glyphs - 2;
1390
1391    for n := 0 to num_rec-1 do
1392    begin
1393      rec := @face^.hdmx.records^[n];
1394
1395      (* read record *)
1396
1397      if TT_Access_Frame(2) then
1398        goto Fail;
1399
1400      rec^.ppem      := Get_Byte;
1401      rec^.max_width := Get_Byte;
1402
1403      TT_Forget_Frame;
1404
1405      if Alloc( rec^.widths, num_glyphs ) or
1406         TT_Read_File( rec^.widths^, num_glyphs ) then
1407        goto Fail;
1408
1409      (* skip padding bytes *)
1410
1411      if rec_size > 0 then
1412        if TT_Skip_File( rec_size ) then
1413          goto Fail;
1414    end;
1415
1416    Load_TrueType_HDMX := Success;
1417    exit;
1418
1419  Fail:
1420    for n := 0 to num_rec-1 do
1421     Free( face^.hdmx.records^[n].widths );
1422
1423    Free( face^.hdmx.records );
1424    face^.hdmx.num_records := 0;
1425  end;
1426
1427
1428 (*******************************************************************
1429  *
1430  *  Function    :  Load_TrueType_Any
1431  *
1432  *  Description :  Load any TrueType table in user memory
1433  *
1434  *  Input  :  face    the font file's face object
1435  *            tag     the table
1436  *
1437  *  Output :  True on success. False on failure
1438  *
1439  ******************************************************************)
1440
1441  function Load_TrueType_Any( face        : PFace;
1442                              tag         : longint;
1443                              offset      : longint;
1444                              var buffer;
1445                              var length  : longint ) : TError;
1446  var
1447    stream   : TT_Stream;
1448    found, i : integer;
1449  begin
1450    if tag <> 0 then
1451      begin
1452        found := -1;
1453        i     := 0;
1454        while i < face^.numTables do
1455          if Longint(face^.dirTables^[i].tag) = tag then
1456            begin
1457              found := i;
1458              i := face^.numTables;
1459            end
1460          else
1461            inc(i);
1462
1463        if found < 0 then
1464          begin
1465            error := TT_Err_Table_Missing;
1466            Load_TrueType_Any := Failure;
1467            exit;
1468          end;
1469
1470        inc( offset, face^.dirTables^[found].offset );
1471
1472        (* if length = 0, the user requested the table's size *)
1473        if length = 0 then
1474          begin
1475            length := face^.dirTables^[found].length;
1476            Load_TrueType_Any := Success;
1477            exit;
1478          end;
1479      end
1480    else
1481      (* if length = 0 and tag = 0, the user requested the font file's size *)
1482      if length = 0 then
1483        begin
1484          (* return length of font file *)
1485          length := TT_Stream_Size( face^.stream );
1486          Load_TrueType_Any := Success;
1487          exit;
1488        end;
1489
1490    TT_Use_Stream( face^.stream, stream );
1491    Load_TrueType_Any := TT_Read_At_File( offset, buffer, length );
1492    TT_Done_Stream( face^.stream );
1493  end;
1494
1495 end.
1496