{************************************************************}
{                   Delphi VCL Extensions                    }
{                                                            }
{                           Font                             }
{                                                            }
{      Copyright (c) 2002-2013 SoftGold software company     }
{                                                            }
{************************************************************}
unit MVFont;

interface

{$INCLUDE SGDXF.INC}
uses SysUtils, Windows, Classes, Graphics, sgConsts
{$IFDEF SGDEL_XE2}
  ,System.UITypes, System.Types
{$ENDIF};
{$R-}

type

  PPointer = ^Pointer;
  PExtFontData = ^TExtFontData;
  TExtFontData = packed record
    D: array [0..3] of Word;
  end;
  TmvFontStyle =  (fmBold, fmItalic, fmUnderline, fmStrikeOut, fmCondensed, fmUpward, fmDownward);
  TmvFontStyles = set of TmvFontStyle;

 TmvFont = class(TFont)
  private
  {$IFDEF SGFPC}
    FOwnerLock: PRTLCriticalSection;
  {$ENDIF}
  protected
    function GetHandle: HFont;
    procedure GetLogFont(var LogFont: TLogFont); virtual;
    function GetStyle: TmvFontStyles;
    procedure SetHandle(Value: HFont);
    procedure SetStyle(Value: TmvFontStyles);
    {$IFDEF SGFPC}
    property OwnerCriticalSection: PRTLCriticalSection read FOwnerLock write FOwnerLock;
    {$ENDIF}

  public
    function HandleAllocated: Boolean;
    procedure HandleNeeded;
    property Handle: HFont read GetHandle write SetHandle;
  published
    property Style: TmvFontStyles read GetStyle write SetStyle default [];
    property Charset default DEFAULT_CHARSET;
    property Color default clWindowText;
  end;

  TmvExtFont = class(TmvFont)
  private
    function IsOrientStored: Boolean;
  protected
    function GetEscapement: Smallint;
    procedure GetLogFont(var LogFont: TLogFont); override;
    function GetExtData: TExtFontData;
    function GetExtValue(Index: Integer): Word;
    function GetName: TFontName;
    function GetOrient: Smallint;
    function GetWeight: Word;
    function GetWidth: Word;
    procedure SetEscapement(Value: Smallint);
    procedure SetExtData(AExtFontData: TExtFontData);
    procedure SetExtValue(Index: Integer; Value: Word);
    procedure SetName(Value: TFontName);
    procedure SetOrient(Value: Smallint);
    procedure SetWeight(Value: Word);
    procedure SetWidth(Value: Word);
  published
    property Width: Word read GetWidth write SetWidth default 0;
    property Weight: Word read GetWeight write SetWeight default 0;
    property Escapement: Smallint read GetEscapement write SetEscapement default 0;
    property Orientation: Smallint read GetOrient write SetOrient stored IsOrientStored;
    property Name: TFontName read GetName write SetName;
  end;

  TClipboardStream = class(TMemoryStream)
  protected
    FHandle: THandle;
    function Realloc(var NewCapacity: Longint): Pointer; override;
  public
    constructor Create(AHandle: THandle);
    function Handle: THandle;
  end;

  TFileMapStream = class(TMemoryStream)
  private
    FFileHandle: Integer;
    FMapHandle: Integer;
    FFileSize: Integer;
    FDelta: Integer;
    FReadOnly: Boolean;
    procedure FreeMapping;
    procedure SetDelta(Value: Integer);
  protected
    function Realloc(var NewCapacity: Longint): Pointer; override;
  public
    constructor Create(const FileName: String; Mode: Word);
    destructor Destroy; override;
    procedure Flush;
    property Capacity;
    property ReadOnly: Boolean read FReadOnly;
    property Delta: Integer read FDelta write SetDelta;
  end;

function RoundToPowerOf2(Value: Integer): Integer;
function ImgRect(G: TGraphic): TRect;
procedure NormRect(var Rect: TRect);
procedure ExpandRect(var Rect: TRect; const P: TPoint);
procedure AssignToBitmap(Src: TGraphic; BM: TBitmap);
{$IFNDEF SGFPC}
procedure AssignToMetafile(Src: TGraphic; MF: TMetafile);
{$ENDIF}

{$IFDEF SGFPC}
function CopyPalette(Palette: HPALETTE): HPALETTE;
{$ENDIF}

function IntegerToFontStyles(const AMask : Integer) : TmvFontStyles;
function FontStylesToInteger(const AFontStyles : TmvFontStyles) : Integer;


implementation

type

  TFontPad = class(TPersistent)
  private
  {$HINTS OFF}
    FOnChange: TNotifyEvent;
  {$HINTS ON}
    FResource: PResource;
  end;

const
  Pitches: array[TFontPitch] of Byte = (DEFAULT_PITCH, VARIABLE_PITCH,
    FIXED_PITCH);
var
  FontLock: TRTLCriticalSection;

function FontProc(const LF: TLogFont; P2,P3: Pointer; var P: TPoint): Integer; stdcall;
begin
  Inc(P.X, LF.lfWidth);
  Inc(P.Y, LF.lfHeight);
  Result := 1;
end;

function CondWidth(Font: TFont): Integer;
var
  vDC: HDC;
  vP: TPoint;
begin
  vP := Point(0, 0);
  vDC := GetDC(0);
  try EnumFonts(vDC, PChar(Font.Name), @FontProc, @vP)
  finally
    ReleaseDC(0, vDC)
  end;
  if vP.Y = 0 then
    Result := 0
  else
  begin
    vP.Y := vP.Y * 3;
    Result := (vP.X * Abs(Font.Height) shl 1 + vP.Y shr 1) div vP.Y;
  end;
end;

function RoundToPowerOf2(Value: Integer): Integer;
asm
	MOV	EDX,EAX
	MOV	EAX,1
@@1:	CMP	EAX,EDX
	JAE	@@2
	SHL	EAX,1
	JNC	@@1
@@2:
end;

function IntegerToFontStyles(const AMask : Integer) : TmvFontStyles;
const
  cnstFontStylesMask: TmvFontStyles = [fmBold, fmItalic, fmUnderline,
    fmStrikeOut, fmCondensed, fmUpward, fmDownward];
var
  vStyles: TmvFontStyles absolute AMask;
begin
  Result := vStyles * cnstFontStylesMask;
end;

function FontStylesToInteger(const AFontStyles : TmvFontStyles) : Integer;
var
  vStyles: Integer absolute AFontStyles;
begin
  Result := vStyles;
end;

procedure NormRect(var Rect: TRect);
begin
  if Rect.Right < Rect.Left then
    SwapInts(Rect.Left, Rect.Right);
  if Rect.Bottom < Rect.Top then
    SwapInts(Rect.Top, Rect.Bottom);
end;

procedure ExpandRect(var Rect: TRect; const P: TPoint);
begin
  if Rect.Left > P.X then
    Rect.Left := P.X;
  if Rect.Top > P.Y then
    Rect.Top := P.Y;
  if Rect.Right < P.X then
    Rect.Right := P.X;
  if Rect.Bottom < P.Y then
    Rect.Bottom := P.Y;
end;

procedure Angle(var Value: Smallint);
begin
  if Abs(Value) >= 3600 then Value := Value mod 3600;
end;

function PreAssign(Src,Dst: TGraphic): Boolean;
var
  vW, vH: Integer;
begin
  Result := Src.Empty or (Src.Width = 0) or (Src.Height = 0);
  if Result then
  begin
    Dst.Assign(nil);
    Exit;
  end;
  vW := Dst.Width;
  vH := Dst.Height;
  if vW or vH = 0 then
  begin
    vW := Src.Width;
    vH := Src.Height;
  end;
  if vW = 0 then
    vW := MulDiv(vH, Src.Width, Src.Height);
  if vH = 0 then
    vH := MulDiv(vW, Src.Height, Src.Width);
  if Src.Palette <> 0 then
    Dst.Palette := CopyPalette(Src.Palette);
  Dst.Width := vW;
  Dst.Height := vH;
end;

function ImgRect(G: TGraphic): TRect;
begin
  Result := Rect(0, 0, G.Width, G.Height);
end;

procedure AssignToBitmap(Src: TGraphic; BM: TBitmap);
begin
  if (not PreAssign(Src, BM)) then
    BM.Canvas.StretchDraw(ImgRect(BM), Src);
end;

{$IFDEF SGFPC}
function CopyPalette(Palette: HPALETTE): HPALETTE;
var
  PaletteSize: Integer;
  LogPal: TMaxLogPalette;
begin
  Result := 0;
  if Palette = 0 then
    Exit;
  PaletteSize := 0;
  if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then
    Exit;
  if PaletteSize = 0 then
    Exit;
  with LogPal do
  begin
    palVersion := $0300;
    palNumEntries := PaletteSize;
    GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
  end;
  //Result := CreatePalette(LogPal);
  Result := CreatePalette(PLogPalette(@LogPal)^);
end;
{$ENDIF}

{$IFNDEF SGFPC}
procedure AssignToMetafile(Src: TGraphic; MF: TMetafile);
var
  vMC: TMetafileCanvas;
begin
  if PreAssign(Src, MF) then
    Exit;
  vMC := TMetafileCanvas.Create(MF, 0);
  try
    vMC.StretchDraw(ImgRect(MF), Src)
  finally
    vMC.Free
  end;
end;
{$ENDIF}

{ TmvFont }

function TmvFont.HandleAllocated: Boolean;
var
  vPResource: PResource;
begin
  vPResource := TFontPad(Self).FResource;
  Result := vPResource^.Handle <> 0;
end;

procedure TmvFont.HandleNeeded;
begin
  GetHandle;
end;
function TmvFont.GetStyle: TmvFontStyles;
begin
  Result := TmvFontStyles(inherited Style);
end;

procedure TmvFont.SetStyle(Value: TmvFontStyles);
const
  NotUse = [fmUpward, fmDownward];
begin
  if Value * NotUse = NotUse then
    Value := Value - Style * NotUse;
  if Value * NotUse = NotUse then
    Value := Value - NotUse;
  if Value <> Style then
    inherited Style := TFontStyles(Value);
end;

procedure TmvFont.GetLogFont(var LogFont: TLogFont);
const
  Weights: array [Boolean] of Integer = (FW_NORMAL, FW_BOLD);
var
  vPResource: PResource;
  vFontName: string;
begin
  vPResource := TFontPad(Self).FResource;
  LogFont.lfHeight := vPResource^.Font.Height;
  LogFont.lfQuality := DEFAULT_QUALITY;
  LogFont.lfOutPrecision := OUT_DEFAULT_PRECIS;
  LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
  LogFont.lfPitchAndFamily := Pitches[vPResource^.Font.Pitch];
  LogFont.lfCharSet := Byte(Charset);
  LogFont.lfItalic := Byte(fsItalic in vPResource^.Font.Style);
  LogFont.lfUnderline := Byte(fsUnderline in vPResource^.Font.Style);
  LogFont.lfStrikeOut := Byte(fsStrikeOut in vPResource^.Font.Style);
  LogFont.lfWeight := Weights[fsBold in vPResource^.Font.Style];
  if fmCondensed in TmvFontStyles(vPResource^.Font.Style) then
    LogFont.lfWidth := CondWidth(Self)
  else
    LogFont.lfWidth := 0;
  if fmUpward in TmvFontStyles(vPResource^.Font.Style) then
    LogFont.lfEscapement := 900
  else
    if fmDownward in TmvFontStyles(vPResource^.Font.Style) then
      LogFont.lfEscapement := 2700
    else
      LogFont.lfEscapement := 0;
  LogFont.lfOrientation := LogFont.lfEscapement;
{$IFDEF SGDEL_2009}
  vFontName := GetName;
{$ELSE}
  vFontName := vPResource^.Font.Name;
{$ENDIF}
  StrPLCopy(LogFont.lfFaceName, vFontName, High(LogFont.lfFaceName) - 1);
end;

function TmvFont.GetHandle: HFont;
var
  vLogFont: TLogFont;
  vPResource: PResource;
begin
  vPResource := TFontPad(Self).FResource;
  if vPResource^.Handle = 0 then
  begin
    if OwnerCriticalSection = nil then
      OwnerCriticalSection := @FontLock;
    Lock;
    try
      GetLogFont(vLogFont);
      PResource(vPResource)^.Handle := CreateFontIndirect(vLogFont);
    finally
      Unlock;
    end;
  end;
  Result := vPResource^.Handle;
end;

procedure TmvFont.SetHandle(Value: HFont);
begin
  {$IFDEF SGFPC}
  inherited Handle := Value;
  {$ELSE}
  inherited SetHandle(Value);
  {$ENDIF}
end;

{ TmvExtFont }

function TmvExtFont.GetExtData: TExtFontData;
var
  ExData: PExtFontData;
  S: string;
  vOffset: TsgNativeUInt;
begin
  S := inherited GetName;
  if S <> '' then
  begin
    vOffset := Length(S) * SizeOf(S[1]) - SizeOf(TExtFontData);
    Pointer(ExData) := Pointer(TsgNativeUInt(Pointer(S)) + vOffset);
    Result := ExData^;
  end
  else
    FillChar(Result, SizeOf(Result), 0);
end;

function TmvExtFont.GetEscapement: Smallint;
begin
  Result := Smallint(GetExtValue(2));
end;

procedure TmvExtFont.GetLogFont(var LogFont: TLogFont);
var
  ExData: TExtFontData;
  vFS: TmvFontStyles;
  vPResource: PResource;
begin
  vPResource := TFontPad(Self).FResource;
  ExData := GetExtData;
  TFontStyles(vFS) := vPResource^.Font.Style;
  if ExData.D[0] <> 0 then
    TmvFontStyles(vPResource^.Font.Style) := vFS - [fmCondensed];
  inherited GetLogFont(LogFont);
  vPResource^.Font.Style := TFontStyles(vFS);
  if ExData.D[0] <> 0 then
    LogFont.lfWidth := ExData.D[0];
  if ExData.D[1] <> 0 then
    LogFont.lfWeight := ExData.D[1];
  if ExData.D[2] <> 0 then
    LogFont.lfEscapement := Smallint(ExData.D[2]);
  if ExData.D[3] <> 0 then
    LogFont.lfOrientation := Smallint(ExData.D[3]);
  if LogFont.lfEscapement < 0 then
    Inc(LogFont.lfEscapement, 3600);
  if LogFont.lfOrientation < 0 then
    Inc(LogFont.lfOrientation, 3600);
end;

function TmvExtFont.GetOrient: Smallint;
begin
  Result := Smallint(GetExtValue(3));
end;

function TmvExtFont.GetName: TFontName;
begin
  Result := inherited GetName;
  SetLength(Result, StrLen(PChar(Result)));
end;

function TmvExtFont.GetWeight: Word;
begin
  Result := GetExtValue(1);
end;

function TmvExtFont.GetWidth: Word;
begin
  Result := GetExtValue(0);
end;

procedure TmvExtFont.SetEscapement(Value: Smallint);
begin
  Angle(Value);
  SetExtValue(2, Value);
end;

procedure TmvExtFont.SetName(Value: TFontName);
const
//  MaxNameLen = LF_FACESIZE - 1 - SizeOf(TExtFontData) - 1;
  MaxNameLen = High(TFontDataName) - SizeOf(TExtFontData) - 1; // one byte reserved to saving #0
  MapExtDataCharCount = SizeOf(TExtFontData) div SizeOf(Char);
begin
  if Value = '' then
    Exit;
  if Length(Value) > MaxNameLen then
    SetLength(Value, MaxNameLen);
  Value := Value +  // Value[MaxNameLen + 1] = #0 and ExData structure must be zero
    StringOfChar(Char(#0), MaxNameLen - Length(Value) + 1 + MapExtDataCharCount);
  inherited SetName(Value);
end;

procedure TmvExtFont.SetOrient(Value: Smallint);
begin
  Angle(Value);
  SetExtValue(3, Value);
end;

procedure TmvExtFont.SetWeight(Value: Word);
begin
  SetExtValue(1, Value);
end;

procedure TmvExtFont.SetWidth(Value: Word);
begin
  SetExtValue(0, Value);
end;

function TmvExtFont.IsOrientStored: Boolean;
begin
  Result := Orientation <> Escapement;
end;

function TmvExtFont.GetExtValue(Index: Integer): Word;
begin
  Result := GetExtData.D[Index];
end;

procedure TmvExtFont.SetExtData(AExtFontData: TExtFontData);
var
  ExData: PExtFontData;
  S: string;
  vOffset: TsgNativeUInt;
begin
  S := inherited GetName;
  if S = '' then
    Exit;
  vOffset := Length(S) * SizeOf(S[1]) - SizeOf(TExtFontData);
  Pointer(ExData) := Pointer(TsgNativeUInt(Pointer(S)) + vOffset);
  ExData^ := AExtFontData;
  S := S {$IFDEF SGDEL_2009}+ #0#0 {$ENDIF}; // UTF-8 convertion trim one #0 symbol
  inherited SetName(string(S));
end;

procedure TmvExtFont.SetExtValue(Index: Integer; Value: Word);
var
  ExData: TExtFontData;
begin
  if Value = GetExtValue(Index) then
    Exit;
  ExData := GetExtData;
  if (Index = 2) and (ExData.D[2] = ExData.D[3]) then
    ExData.D[3] := Value;
  ExData.D[Index] := Value;
  SetExtData(ExData);
end;


{ TClipboardStream }

constructor TClipboardStream.Create(AHandle: THandle);
begin
  FHandle := AHandle;
  if AHandle <> 0 then
    SetPointer(GlobalLock(AHandle), GlobalSize(AHandle));
end;

function TClipboardStream.Handle: THandle;
begin
  if FHandle = 0 then
  begin
    FHandle := GlobalHandle(Memory);
    GlobalUnlock(FHandle);
    SetPointer(nil, Size);
  end;
  Result := FHandle;
end;

function TClipboardStream.Realloc(var NewCapacity: Longint): Pointer;
begin
  if FHandle = 0 then
    Result := inherited Realloc(NewCapacity)
  else
  begin
    Result := Memory;
    if NewCapacity = 0
      then GlobalUnlock(FHandle);
  end;
end;

{ TFileMapStream }

constructor TFileMapStream.Create(const FileName: string; Mode: Word);
const
  Excepts: array[Boolean] of ExceptClass = (EFOpenError, EFCreateError);
  Modes: array[Boolean] of string = ('open','creat');
var Created: Boolean;
begin
  Created := Mode=fmCreate;
  FDelta := $10000;
  FReadOnly := (Mode and 3) = fmOpenRead;
  if Created then
    FFileHandle := FileCreate(FileName)
  else
    FFileHandle := FileOpen(FileName,Mode);
  if FFileHandle < 0 then
    raise Excepts[Created].CreateFmt('"%s" file %sing failure', [FileName, Modes[Created]]);
  FFileSize := GetFileSize(FFileHandle,nil);
  if not Created then Size := FFileSize;
end;

destructor TFileMapStream.Destroy;
begin
  FreeMapping;
  if FFileHandle >= 0 then
  begin
    if Size <> FFileSize then
    begin
      FileSeek(FFileHandle,Size,0);
      SetEndOfFile(FFileHandle);
    end;
    FileClose(FFileHandle);
  end;
  inherited Destroy;
end;

procedure TFileMapStream.FreeMapping;
begin
  if Memory <> nil then UnmapViewOfFile(Memory);
  if FMapHandle <> 0 then CloseHandle(FMapHandle);
end;

procedure TFileMapStream.Flush;
begin
  if Memory <> nil then FlushViewOfFile(Memory,0);
end;

procedure TFileMapStream.SetDelta(Value: Integer);
begin
  FDelta := RoundToPowerOf2(Value);
end;

function TFileMapStream.Realloc(var NewCapacity: Longint): Pointer;
  procedure Error;
  begin
    raise EStreamError.Create('Failure of mapping file in memory');
  end;
const
  Protects: array[Boolean] of Integer = (PAGE_READWRITE,PAGE_READONLY);
  Accesses: array[Boolean] of Integer = (FILE_MAP_WRITE,FILE_MAP_READ);
begin
  if NewCapacity <= Capacity then begin
    NewCapacity := Capacity;
    Result := Memory;
    Exit;
  end;
  FreeMapping;
  if not FReadOnly then NewCapacity := (NewCapacity+Delta-1) and not (Delta-1);
  FMapHandle := CreateFileMapping(FFileHandle, nil, Protects[FReadOnly], 0, NewCapacity, nil);
  if FMapHandle=0 then Error;
  Result := MapViewOfFile(FMapHandle, Accesses[FReadOnly], 0, 0, 0);
  if Result=nil then Error;
end;

initialization
  InitializeCriticalSection(FontLock);

finalization
  DeleteCriticalSection(FontLock);

end.
