TextSuite/utsGDI.pas

unit utsGDI;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, utsTypes, syncobjs, dynlibs;

type
  HDC = Cardinal;

  TFixed = packed record
    fract: Word;
    value: Smallint;
  end;

  TMat2 = packed record
    eM11: TFixed;
    eM12: TFixed;
    eM21: TFixed;
    eM22: TFixed;
  end;
  PMat2 = ^TMat2;


const
  GDI_ERROR = DWORD($FFFFFFFF);

  FW_NORMAL = 400;
  FW_BOLD = 700;

  DEFAULT_CHARSET = 1;

  NONANTIALIASED_QUALITY = 3;
  ANTIALIASED_QUALITY = 4;

  GGO_METRICS = 0;
  GGO_BITMAP = 1;
  GGO_GRAY8_BITMAP = 6;
  GGO_GLYPH_INDEX = $80;

  FR_PRIVATE = $10;
  FR_NOT_ENUM = $20;

  LOCALE_USER_DEFAULT = $0400;
  LOCALE_ILANGUAGE = $1;

  GCP_MAXEXTENT = $100000;

  TMPF_FIXED_PITCH = 1;

type
  HFONT = Cardinal;
  HGDIOBJ = Cardinal;

  TLogFontA = record
    lfHeight: Longint;
    lfWidth: Longint;
    lfEscapement: Longint;
    lfOrientation: Longint;
    lfWeight: Longint;
    lfItalic: Byte;
    lfUnderline: Byte;
    lfStrikeOut: Byte;
    lfCharSet: Byte;
    lfOutPrecision: Byte;
    lfClipPrecision: Byte;
    lfQuality: Byte;
    lfPitchAndFamily: Byte;
    lfFaceName: array[0..31] of AnsiChar;
  end;
  PLogFontA = ^TLogFontA;

  TTextMetricW = record
    tmHeight: Longint;
    tmAscent: Longint;
    tmDescent: Longint;
    tmInternalLeading: Longint;
    tmExternalLeading: Longint;
    tmAveCharWidth: Longint;
    tmMaxCharWidth: Longint;
    tmWeight: Longint;
    tmOverhang: Longint;
    tmDigitizedAspectX: Longint;
    tmDigitizedAspectY: Longint;
    tmFirstChar: WideChar;
    tmLastChar: WideChar;
    tmDefaultChar: WideChar;
    tmBreakChar: WideChar;
    tmItalic: Byte;
    tmUnderlined: Byte;
    tmStruckOut: Byte;
    tmPitchAndFamily: Byte;
    tmCharSet: Byte;
  end;
  PTextMetricW = ^TTextMetricW;

  TGlyphMetrics = record
    gmBlackBoxX: Cardinal;
    gmBlackBoxY: Cardinal;
    gmptGlyphOrigin: TtsPosition;
    gmCellIncX: Smallint;
    gmCellIncY: Smallint;
  end;
  PGlyphMetrics = ^TGlyphMetrics;

  TGCPResultsW = record
    lStructSize: DWORD;
    lpOutString: PWideChar;
    lpOrder: PDWORD;
    lpDx: PInteger;
    lpCaretPos: PInteger;
    lpClass: PChar;
    lpGlyphs: PCardinal;
    nGlyphs: Cardinal;
    nMaxFit: Cardinal;
  end;
  PGCPResultsW = ^TGCPResultsW;

  TPanose = record
    bFamilyType: Byte;
    bSerifStyle: Byte;
    bWeight: Byte;
    bProportion: Byte;
    bContrast: Byte;
    bStrokeVariation: Byte;
    bArmStyle: Byte;
    bLetterform: Byte;
    bMidline: Byte;
    bXHeight: Byte;
  end;
  PPanose = ^TPanose;

  TOutlineTextmetricW = record
    otmSize: LongWord;
    otmTextMetrics: TTextMetricW;
    otmFiller: Byte;
    otmPanoseNumber: TPanose;
    otmfsSelection: LongWord;
    otmfsType: LongWord;
    otmsCharSlopeRise: Integer;
    otmsCharSlopeRun: Integer;
    otmItalicAngle: Integer;
    otmEMSquare: LongWord;
    otmAscent: Integer;
    otmDescent: Integer;
    otmLineGap: LongWord;
    otmsCapEmHeight: LongWord;
    otmsXHeight: LongWord;
    otmrcFontBox: TtsRect;
    otmMacAscent: Integer;
    otmMacDescent: Integer;
    otmMacLineGap: LongWord;
    otmusMinimumPPEM: LongWord;
    otmptSubscriptSize: TtsPosition;
    otmptSubscriptOffset: TtsPosition;
    otmptSuperscriptSize: TtsPosition;
    otmptSuperscriptOffset: TtsPosition;
    otmsStrikeoutSize: LongWord;
    otmsStrikeoutPosition: Integer;
    otmsUnderscoreSize: Integer;
    otmsUnderscorePosition: Integer;
    otmpFamilyName: PWideChar;
    otmpFaceName: PWideChar;
    otmpStyleName: PWideChar;
    otmpFullName: PWideChar;
  end;
  POutlineTextmetricW = ^TOutlineTextmetricW;

  TCreateFontIndirectA = function (const p1: TLogFontA): HFONT; stdcall;

  TAddFontResourceA = function(Filename: PAnsiChar): Integer; stdcall;
  TAddFontResourceExA = function(Filename: PAnsiChar; Flag: DWORD; pdv: Pointer): Integer; stdcall;
  TAddFontMemResourceEx = function(pbFont: Pointer; cbFont: DWORD; pdv: Pointer; pcFonts: PDWORD): THandle; stdcall;
  TRemoveFontResourceA = function(Filename: PAnsiChar): Boolean; stdcall;
  TRemoveFontResourceExA = function(filename: PAnsiChar; Flag: DWORD; pdv: Pointer): Boolean; stdcall;
  TRemoveFontMemResourceEx = function(fh: THandle): Boolean; stdcall;

  TGetTextMetricsW = function(DC: HDC; var TM: TTextMetricW): Boolean; stdcall;
  TGetGlyphOutlineA = function(DC: HDC; uChar, uFormat: Cardinal; lpgm: PGlyphMetrics; cbBuffer: DWORD; lpvBuffer: Pointer; lpmat2: PMat2): DWORD; stdcall;

  TGetCharacterPlacementW = function(DC: HDC; Str: PWideChar; Count, MaxExtent: Integer; Result: PGCPResultsW; Flags: DWORD): DWORD; stdcall;
  TGetFontData = function(DC: HDC; TableName, Offset: DWORD; Buffer: Pointer; Data: DWORD): DWORD; stdcall;

  TCreateCompatibleDC = function(DC: HDC): HDC; stdcall;
  TDeleteDC = function(DC: HDC): Boolean; stdcall;
  TSelectObject = function(DC: HDC; p2: HGDIOBJ): HGDIOBJ; stdcall;
  TDeleteObject = function(p1: HGDIOBJ): Boolean; stdcall;

  TGetOutlineTextMetricsW = function(DC: HDC; p2: LongWord; var OTMetricStructs: TOutlineTextmetricW): LongWord; stdcall;

  TGetLocaleInfoA = function(Locale: DWORD; LCType: DWORD; lpLCData: pAnsiChar; cchData: Integer): Integer; stdcall;

var
  CreateFontIndirectA: TCreateFontIndirectA;
  AddFontResourceA: TAddFontResourceA;
  AddFontResourceExA: TAddFontResourceExA;
  AddFontMemResourceEx: TAddFontMemResourceEx;
  RemoveFontResourceA: TRemoveFontResourceA;
  RemoveFontResourceExA: TRemoveFontResourceExA;
  RemoveFontMemResourceEx: TRemoveFontMemResourceEx;
  GetTextMetricsW: TGetTextMetricsW;
  GetGlyphOutlineA: TGetGlyphOutlineA;
  GetCharacterPlacementW: TGetCharacterPlacementW;
  GetFontData: TGetFontData;
  CreateCompatibleDC: TCreateCompatibleDC;
  DeleteDC: TDeleteDC;
  SelectObject: TSelectObject;
  DeleteObject: TDeleteObject;
  GetOutlineTextMetricsW: TGetOutlineTextMetricsW;

  GetLocaleInfoA: TGetLocaleInfoA;

procedure InitGDI;
procedure QuitGDI;

implementation

uses
  utsTextSuite;

const
  LIB_GDI32    = 'gdi32.dll';
  LIB_KERNEL32 = 'kernel32.dll';

var
  gdiRefCount: Integer;
  gdiCritSec: TCriticalSection;
  gdiInitialized: Boolean;
  gdiLibHandle: TLibHandle = 0;
  kernel32LibHandle: TLibHandle = 0;

procedure InitGDI;

  function GetProcAddr(const aLibHandle: TLibHandle; const aName: String): Pointer;
  begin
    result := GetProcAddress(aLibHandle, aName);
    if not Assigned(result) then
      raise EtsException.Create('unable to load procedure from library: ' + aName);
  end;

begin
  gdiCritSec.Enter;
  try try
    inc(gdiRefCount, 1);
    if gdiInitialized then
      exit;

    if (gdiLibHandle = 0) then begin
      gdiLibHandle := LoadLibrary(LIB_GDI32);
      if (gdiLibHandle = 0) then
        raise EtsException.Create('unable to load gdi lib: ' + LIB_GDI32);
    end;

    if (kernel32LibHandle = 0) then begin
      kernel32LibHandle := LoadLibrary(LIB_KERNEL32);
      if (kernel32LibHandle = 0) then
        raise EtsException.Create('unable to load kernel lib: ' + LIB_KERNEL32);
    end;

    CreateFontIndirectA     := TCreateFontIndirectA(    GetProcAddr(gdiLibHandle, 'CreateFontIndirectA'));
    AddFontResourceA        := TAddFontResourceA(       GetProcAddr(gdiLibHandle, 'AddFontResourceA'));
    AddFontResourceExA      := TAddFontResourceExA(     GetProcAddr(gdiLibHandle, 'AddFontResourceExA'));
    AddFontMemResourceEx    := TAddFontMemResourceEx(   GetProcAddr(gdiLibHandle, 'AddFontMemResourceEx'));
    RemoveFontResourceA     := TRemoveFontResourceA(    GetProcAddr(gdiLibHandle, 'RemoveFontResourceA'));
    RemoveFontResourceExA   := TRemoveFontResourceExA(  GetProcAddr(gdiLibHandle, 'RemoveFontResourceExA'));
    RemoveFontMemResourceEx := TRemoveFontMemResourceEx(GetProcAddr(gdiLibHandle, 'RemoveFontMemResourceEx'));
    GetTextMetricsW         := TGetTextMetricsW(        GetProcAddr(gdiLibHandle, 'GetTextMetricsW'));
    GetGlyphOutlineA        := TGetGlyphOutlineA(       GetProcAddr(gdiLibHandle, 'GetGlyphOutlineA'));
    GetCharacterPlacementW  := TGetCharacterPlacementW( GetProcAddr(gdiLibHandle, 'GetCharacterPlacementW'));
    GetFontData             := TGetFontData(            GetProcAddr(gdiLibHandle, 'GetFontData'));
    CreateCompatibleDC      := TCreateCompatibleDC(     GetProcAddr(gdiLibHandle, 'CreateCompatibleDC'));
    DeleteDC                := TDeleteDC(               GetProcAddr(gdiLibHandle, 'DeleteDC'));
    SelectObject            := TSelectObject(           GetProcAddr(gdiLibHandle, 'SelectObject'));
    DeleteObject            := TDeleteObject(           GetProcAddr(gdiLibHandle, 'DeleteObject'));
    GetOutlineTextMetricsW  := TGetOutlineTextMetricsW( GetProcAddr(gdiLibHandle, 'GetOutlineTextMetricsW'));

    GetLocaleInfoA := TGetLocaleInfoA(GetProcAddr(kernel32LibHandle, 'GetLocaleInfoA'));

    gdiInitialized := true;
  except
    gdiInitialized := false;
    FreeLibrary(gdiLibHandle);
    FreeLibrary(kernel32LibHandle);
  end;
  finally
    gdiCritSec.Leave;
  end;
end;

procedure QuitGDI;
begin
  gdiCritSec.Enter;
  try
    dec(gdiRefCount, 1);
    if (gdiRefCount > 0) then
      exit;

    CreateFontIndirectA := nil;
    AddFontResourceA := nil;
    AddFontResourceExA := nil;
    RemoveFontResourceA := nil;
    RemoveFontResourceExA := nil;
    GetTextMetricsW := nil;
    GetGlyphOutlineA := nil;
    GetCharacterPlacementW := nil;
    GetFontData := nil;
    CreateCompatibleDC := nil;
    DeleteDC := nil;
    SelectObject := nil;
    DeleteObject := nil;

    GetLocaleInfoA := nil;

    if (gdiLibHandle <> 0) then begin
      FreeLibrary(gdiLibHandle);
      gdiLibHandle := 0;
    end;

    if (kernel32LibHandle <> 0) then begin
      FreeLibrary(kernel32LibHandle);
      kernel32LibHandle := 0;
    end;

    gdiInitialized := false;
  finally
    gdiCritSec.Leave;
  end;
end;

initialization
  gdiRefCount    := 0;
  gdiInitialized := false;
  gdiCritSec     := TCriticalSection.Create;

finalization
  if gdiInitialized then
    QuitGDI;
  FreeAndNil(gdiCritSec);

end.