/components/synedit/syntextdrawer.pp

   1{==============================================================================
   2  Content:  TheTextDrawer, a helper class for drawing of
   3            fixed-pitched font characters
   4 ==============================================================================
   5  The contents of this file are subject to the Mozilla Public License Ver. 1.0
   6  (the "License"); you may not use this file except in compliance with the
   7  License. You may obtain a copy of the License at http://www.mozilla.org/MPL/
   8
   9  Software distributed under the License is distributed on an "AS IS" basis,
  10  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  11  the specific language governing rights and limitations under the License.
  12 ==============================================================================
  13  The Original Code is HANAI Tohru's private delphi library.
  14 ==============================================================================
  15  The Initial Developer of the Original Code is HANAI Tohru (Japan)
  16  Portions created by HANAI Tohru are Copyright (C) 1999.
  17  All Rights Reserved.
  18 ==============================================================================
  19  Contributor(s):   HANAI Tohru
  20 ==============================================================================
  21  History:  01/19/1999  HANAI Tohru
  22                        Initial Version
  23            02/13/1999  HANAI Tohru
  24                        Changed default intercharacter spacing
  25            09/09/1999  HANAI Tohru
  26                        Redesigned all. Simplified interfaces.
  27                        When drawing text now it uses TextOut + SetTextCharacter-
  28                        Extra insted ExtTextOut since ExtTextOut has a little
  29                        heavy behavior.
  30            09/10/1999  HANAI Tohru
  31                        Added code to call ExtTextOut because there is a problem
  32                        when TextOut called with italicized raster type font.
  33                        After this changing, ExtTextOut is called without the
  34                        last parameter `lpDx' and be with SetTextCharacterExtra.
  35                        This pair performs faster than with `lpDx'.
  36            09/14/1999  HANAI Tohru
  37                        Changed code for saving/restoring DC
  38            09/15/1999  HANAI Tohru
  39                        Added X/Y parameters to ExtTextOut.
  40            09/16/1999  HANAI Tohru
  41                        Redesigned for multi-bytes character drawing.
  42            09/19/1999  HANAI Tohru
  43                        Since TheTextDrawer grew fat it was split into three
  44                        classes - TheFontStock, TheTextDrawer and TheTextDrawerEx.
  45                        Currently it should avoid TheTextDrawer because it is
  46                        slower than TheTextDrawer.
  47            09/25/1999  HANAI Tohru
  48                        Added internally definition of LeadBytes for Delphi 2
  49            10/01/1999  HANAI Tohru
  50                        To save font resources, now all fonts data are shared
  51                        among all of TheFontStock instances. With this changing,
  52                        there added a new class `TheFontsInfoManager' to manage
  53                        those shared data.
  54            10/09/1999  HANAI Tohru
  55                        Added BaseStyle property to TheFontFont class.
  56 ==============================================================================}
  57
  58// $Id$
  59
  60// SynEdit note: The name had to be changed to get SynEdit to install 
  61//   together with mwEdit into the same Delphi installation
  62
  63unit SynTextDrawer;
  64
  65{$mode objfpc}{$H+}
  66
  67interface
  68
  69uses
  70  Classes, Types, SysUtils, LCLProc, LCLType, LCLIntf, Graphics, GraphUtil,
  71  SynEditTypes, SynEditMiscProcs;
  72
  73type
  74  TheStockFontPatterns = 0..(1 shl (1 + Ord(High(TFontStyle))));
  75
  76  PheFontData = ^TheFontData;
  77  TheFontData = record
  78    Style: TFontStyles;
  79    Font: TFont;
  80    Handle: HFont;
  81    CharAdv: Integer;       // char advance of single-byte code
  82    CharHeight: Integer;
  83    NeedETO: Boolean;
  84  end;
  85
  86  PheFontsData = ^TheFontsData;
  87  TheFontsData = array[TheStockFontPatterns] of TheFontData;
  88
  89  PheSharedFontsInfo = ^TheSharedFontsInfo;
  90  TheSharedFontsInfo = record
  91    // reference counters
  92    RefCount: Integer;
  93    LockCount: Integer;
  94    // font information
  95    BaseFont: TFont;
  96    IsDBCSFont: Boolean;
  97    IsTrueType: Boolean;
  98    FontsData: TheFontsData;
  99  end;
 100
 101  { TheFontsInfoManager }
 102
 103  TheFontsInfoManager = class
 104  private
 105    FFontsInfo: TList;
 106    function CreateFontsInfo(ABaseFont: TFont): PheSharedFontsInfo;
 107    function FindFontsInfo(const BFont: TFont): PheSharedFontsInfo;
 108    procedure DestroyFontHandles(pFontsInfo: PheSharedFontsInfo);
 109  public
 110    constructor Create;
 111    destructor Destroy; override;
 112    procedure LockFontsInfo(pFontsInfo: PheSharedFontsInfo);
 113    procedure UnLockFontsInfo(pFontsInfo: PheSharedFontsInfo);
 114    function GetFontsInfo(ABaseFont: TFont): PheSharedFontsInfo;
 115    procedure ReleaseFontsInfo(var pFontsInfo: PheSharedFontsInfo);
 116  end;
 117
 118  { TheFontStock }
 119
 120  TheExtTextOutProc = procedure (X, Y: Integer; fuOptions: UINT;
 121    const ARect: TRect; Text: PChar; Length: Integer) of object;
 122
 123  EheFontStockException = class(Exception);
 124
 125  TheFontStock = class
 126  private
 127    // private DC
 128    FDC: HDC;
 129    FDCRefCount: Integer;
 130
 131    // Shared fonts
 132    FpInfo: PheSharedFontsInfo;
 133    FUsingFontHandles: Boolean;
 134
 135    // Current font
 136    FCrntFont: HFONT;
 137    FCrntStyle: TFontStyles;
 138    FpCrntFontData: PheFontData;
 139    // local font info
 140    function GetBaseFont: TFont;
 141    function GetIsDBCSFont: Boolean;
 142    function GetIsTrueType: Boolean;
 143    function GetNeedETO: Boolean;
 144  protected
 145    function InternalGetDC: HDC; virtual;
 146    procedure InternalReleaseDC(Value: HDC); virtual;
 147    Procedure CalcFontAdvance(DC: HDC; FontData: PheFontData; FontHeight: integer);
 148    function GetCharAdvance: Integer; virtual;
 149    function GetCharHeight: Integer; virtual;
 150    function GetFontData(idx: Integer): PheFontData; virtual;
 151    procedure UseFontHandles;
 152    procedure ReleaseFontsInfo;
 153    procedure SetBaseFont(Value: TFont); virtual;
 154    procedure SetStyle(Value: TFontStyles); virtual;
 155    property FontData[idx: Integer]: PheFontData read GetFontData;
 156    property FontsInfo: PheSharedFontsInfo read FpInfo;
 157  public
 158    constructor Create(InitialFont: TFont); virtual;
 159    destructor Destroy; override;
 160    procedure ReleaseFontHandles; virtual;
 161  public
 162    // Info from the current font (per Style)
 163    function MonoSpace: Boolean;
 164    property Style: TFontStyles read FCrntStyle write SetStyle;
 165    property FontHandle: HFONT read FCrntFont;
 166    property CharAdvance: Integer read GetCharAdvance;
 167    property CharHeight: Integer read GetCharHeight;
 168    property NeedETO: Boolean read GetNeedETO;
 169  public
 170    // Info from the BaseFont
 171    property BaseFont: TFont read GetBaseFont;
 172    property IsDBCSFont: Boolean read GetIsDBCSFont;
 173    property IsTrueType: Boolean read GetIsTrueType;
 174  end;
 175
 176  { TEtoBuffer }
 177
 178  TEtoBuffer = class
 179  public
 180    EtoData: Array of Integer;
 181    function  Eto: PInteger;
 182    function  Len: Integer;
 183    procedure Clear;
 184    procedure SetMinLength(ALen: Integer);
 185  end;
 186  { TheTextDrawer }
 187  EheTextDrawerException = class(Exception);
 188
 189  TheTextDrawer = class(TObject)
 190  private
 191    FDC: HDC;
 192    FSaveDC: Integer;
 193    FSavedFont: HFont;
 194
 195    // Font information
 196    FFontStock: TheFontStock;
 197    FCalcExtentBaseStyle: TFontStyles;
 198    FBaseCharWidth: Integer;
 199    FBaseCharHeight: Integer;
 200
 201    // current font and properties
 202    FCrntFont: HFONT;
 203    FEtoInitLen: Integer;
 204    FEto: TEtoBuffer;
 205
 206    // current font attributes
 207    FColor: TColor;
 208    FBkColor: TColor;
 209    FFrameColor: array[TLazSynBorderSide] of TColor;
 210    FFrameStyle: array[TLazSynBorderSide] of TSynLineStyle;
 211    FCharExtra: Integer;
 212
 213    // Begin/EndDrawing calling count
 214    FDrawingCount: Integer;
 215    ForceEto: Boolean;
 216
 217    FOnFontChangedHandlers: TMethodList;
 218    FOnFontChangedLock: Integer;
 219    function GetCharExtra: Integer;
 220    function GetEto: TEtoBuffer;
 221  protected
 222    procedure ReleaseETODist; virtual;
 223    procedure AfterStyleSet; virtual;
 224    function GetUseUTF8: boolean;
 225    function GetMonoSpace: boolean;
 226    function CreateColorPen(AColor: TColor; AStyle: LongWord = PS_SOLID): HPen;
 227    property DrawingCount: Integer read FDrawingCount;
 228    property FontStock: TheFontStock read FFontStock;
 229    property BaseCharWidth: Integer read FBaseCharWidth;
 230    property BaseCharHeight: Integer read FBaseCharHeight;
 231  public
 232    constructor Create(CalcExtentBaseStyle: TFontStyles; ABaseFont: TFont); virtual;
 233    destructor Destroy; override;
 234    function GetCharWidth: Integer; virtual;
 235    function GetCharHeight: Integer; virtual;
 236    procedure BeginDrawing(DC: HDC); virtual;
 237    procedure EndDrawing; virtual;
 238    procedure TextOut(X, Y: Integer; Text: PChar; Length: Integer); virtual;
 239    procedure ExtTextOut(X, Y: Integer; fuOptions: UINT; const ARect: TRect;
 240      Text: PChar; Length: Integer; FrameBottom: Integer = -1); virtual;
 241    procedure NewTextOut(X, Y: Integer; fuOptions: UINT; const ARect: TRect;
 242      Text: PChar; Length: Integer; AnEto: TEtoBuffer);
 243    procedure DrawFrame(const ARect: TRect);
 244    procedure ForceNextTokenWithEto;
 245    function  NeedsEto: boolean;
 246    procedure DrawLine(X, Y, X2, Y2: Integer; AColor: TColor);
 247    procedure FillRect(const aRect: TRect);
 248    procedure SetBaseFont(Value: TFont); virtual;
 249    procedure SetBaseStyle(const Value: TFontStyles); virtual;
 250    procedure SetStyle(Value: TFontStyles); virtual;
 251    procedure SetForeColor(Value: TColor); virtual;
 252    procedure SetBackColor(Value: TColor); virtual;
 253
 254    procedure SetFrameColor(Side: TLazSynBorderSide; AValue: TColor); virtual; overload;
 255    procedure SetFrameColor(AValue: TColor); virtual; overload; //deprecated;
 256    procedure SetFrameStyle(Side: TLazSynBorderSide; AValue: TSynLineStyle); virtual; overload;
 257    //procedure SetFrameStyle(AValue: TSynLineStyle); virtual; overload;
 258
 259    procedure SetCharExtra(Value: Integer); virtual;
 260    procedure ReleaseTemporaryResources; virtual;
 261
 262    procedure RegisterOnFontChangeHandler(AHandlerProc: TNotifyEvent);
 263    procedure UnRegisterOnFontChangeHandler(AHandlerProc: TNotifyEvent);
 264
 265    property Eto: TEtoBuffer read GetEto;
 266    property CharWidth: Integer read GetCharWidth;
 267    property CharHeight: Integer read GetCharHeight;
 268    property BaseFont: TFont write SetBaseFont;
 269    property BaseStyle: TFontStyles write SetBaseStyle;
 270    property ForeColor: TColor write SetForeColor;
 271    property BackColor: TColor read FBkColor write SetBackColor;
 272    property FrameColor[Side: TLazSynBorderSide]: TColor write SetFrameColor;
 273    property FrameStyle[Side: TLazSynBorderSide]: TSynLineStyle write SetFrameStyle;
 274
 275    property Style: TFontStyles write SetStyle;
 276    property CharExtra: Integer read GetCharExtra write SetCharExtra;
 277    property UseUTF8: boolean read GetUseUTF8;
 278    property MonoSpace: boolean read GetMonoSpace;
 279    property StockDC: HDC read FDC;
 280  end;
 281
 282  { TheTextDrawerEx }
 283
 284  TheTextDrawerEx = class(TheTextDrawer)
 285  private
 286    // current font properties
 287    FCrntDx: Integer;
 288    FCrntDBDx: Integer;               // for a double-byte character
 289    // Text drawing procedure reference for optimization
 290    FExtTextOutProc: TheExtTextOutProc;
 291  protected
 292    procedure AfterStyleSet; override;
 293    procedure TextOutOrExtTextOut(X, Y: Integer; fuOptions: UINT;
 294      const ARect: TRect; Text: PChar; Length: Integer); virtual;
 295    procedure ExtTextOutFixed(X, Y: Integer; fuOptions: UINT;
 296      const ARect: TRect; Text: PChar; Length: Integer); virtual;
 297    procedure ExtTextOutWithETO(X, Y: Integer; fuOptions: UINT;
 298      const ARect: TRect; Text: PChar; Length: Integer); virtual;
 299    procedure ExtTextOutForDBCS(X, Y: Integer; fuOptions: UINT;
 300      const ARect: TRect; Text: PChar; Length: Integer); virtual;
 301  public
 302    procedure ExtTextOut(X, Y: Integer; fuOptions: UINT; const ARect: TRect;
 303      Text: PChar; Length: Integer; FrameBottom: Integer = -1); override;
 304  end;
 305
 306  function GetFontsInfoManager: TheFontsInfoManager;
 307
 308(*
 309{$DEFINE HE_ASSERT}
 310{$DEFINE HE_LEADBYTES}
 311{$DEFINE HE_COMPAREMEM}
 312*)
 313
 314{$IFNDEF HE_LEADBYTES}
 315type
 316  TheLeadByteChars = set of Char;
 317
 318  function SetLeadBytes(const Value: TheLeadByteChars): TheLeadByteChars;
 319{$ENDIF}
 320
 321implementation
 322
 323const
 324  DBCHAR_CALCULATION_FALED  = $7FFFFFFF;
 325
 326var
 327  gFontsInfoManager: TheFontsInfoManager;
 328  SynTextDrawerFinalization: boolean;
 329
 330{$IFNDEF HE_LEADBYTES}
 331  LeadBytes: TheLeadByteChars;
 332{$ENDIF}
 333
 334{ utility routines }
 335
 336function GetFontsInfoManager: TheFontsInfoManager;
 337begin
 338  if (not Assigned(gFontsInfoManager)) 
 339  and (not SynTextDrawerFinalization)
 340  then
 341    gFontsInfoManager := TheFontsInfoManager.Create;
 342  Result := gFontsInfoManager;
 343end;
 344
 345function Min(x, y: integer): integer;
 346begin
 347  if x < y then Result := x else Result := y;
 348end;
 349
 350{$IFNDEF HE_ASSERT}
 351procedure ASSERT(Expression: Boolean);
 352begin
 353  if not Expression then
 354    raise EheTextDrawerException.Create('Assertion failed.');
 355end;
 356{$ENDIF}
 357
 358{$IFNDEF HE_LEADBYTES}
 359function SetLeadBytes(const Value: TheLeadByteChars): TheLeadByteChars;
 360begin
 361  Result := LeadBytes;
 362  LeadBytes := Value;
 363end;
 364{$ENDIF}
 365
 366{$IFNDEF HE_COMPAREMEM}
 367function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;
 368begin
 369  Result := CompareByte(P1^, P2^, Length) = 0;
 370end;
 371{$ENDIF}
 372
 373function GetStyleIndex(Value: TFontStyles): Integer;
 374var
 375  item: TFontStyle;
 376begin
 377  result := 0;
 378  for item := low (TFontStyle) to high(TFontStyle) do
 379    if item in Value then
 380      result := result + 1 shl ord(item);
 381end;
 382
 383{ TEtoBuffer }
 384
 385function TEtoBuffer.Eto: PInteger;
 386begin
 387  if Length(EtoData) > 0 then
 388    Result := PInteger(@EtoData[0])
 389  else
 390    Result := nil;
 391end;
 392
 393function TEtoBuffer.Len: Integer;
 394begin
 395  Result := Length(EtoData);
 396end;
 397
 398procedure TEtoBuffer.Clear;
 399begin
 400  SetLength(EtoData, 0);
 401end;
 402
 403procedure TEtoBuffer.SetMinLength(ALen: Integer);
 404const
 405  EtoBlockSize = $80;
 406begin
 407  if Length(EtoData) >= ALen then exit;
 408  SetLength(EtoData, ((not (EtoBlockSize - 1)) and ALen) + EtoBlockSize);
 409end;
 410
 411{ TheFontsInfoManager }
 412
 413procedure TheFontsInfoManager.LockFontsInfo(
 414  pFontsInfo: PheSharedFontsInfo);
 415begin
 416  Inc(pFontsInfo^.LockCount);
 417end;
 418
 419constructor TheFontsInfoManager.Create;
 420begin
 421  inherited Create;
 422  FFontsInfo := TList.Create;
 423end;
 424
 425procedure TheFontsInfoManager.UnlockFontsInfo(
 426  pFontsInfo: PheSharedFontsInfo);
 427begin
 428  with pFontsInfo^ do
 429  begin
 430    if LockCount>0 then begin
 431      Dec(LockCount);
 432      if 0 = LockCount then
 433        DestroyFontHandles(pFontsInfo);
 434    end;
 435  end;
 436end;
 437
 438destructor TheFontsInfoManager.Destroy;
 439var APheSharedFontsInfo:PheSharedFontsInfo;
 440begin
 441  if Assigned(FFontsInfo) then
 442  begin
 443    while FFontsInfo.Count > 0 do
 444    begin
 445      ASSERT(1 = PheSharedFontsInfo(FFontsInfo[FFontsInfo.Count - 1])^.RefCount);
 446      APheSharedFontsInfo:=PheSharedFontsInfo(FFontsInfo[FFontsInfo.Count - 1]);
 447      ReleaseFontsInfo(APheSharedFontsInfo);
 448    end;
 449    FFontsInfo.Free;
 450    FFontsInfo:=nil;
 451  end;
 452
 453  inherited Destroy;
 454  gFontsInfoManager := nil;
 455end;
 456
 457procedure TheFontsInfoManager.DestroyFontHandles(
 458  pFontsInfo: PheSharedFontsInfo);
 459var
 460  i: Integer;
 461begin
 462  with pFontsInfo^ do
 463    for i := Low(TheStockFontPatterns) to High(TheStockFontPatterns) do
 464      with FontsData[i] do
 465        if Handle <> 0 then
 466        begin
 467          FreeAndNil(Font);
 468          Handle := 0;
 469        end;
 470end;
 471
 472function TheFontsInfoManager.CreateFontsInfo(ABaseFont: TFont): PheSharedFontsInfo;
 473var
 474  DC: HDC;
 475  hOldFont: HFont;
 476begin
 477  New(Result);
 478  FillChar(Result^, SizeOf(TheSharedFontsInfo), 0);
 479  with Result^ do
 480    try
 481      BaseFont := TFont.Create;
 482      BaseFont.Assign(ABaseFont);
 483      IsTrueType := False; // TODO: The old code returned always false too: (0 <> (TRUETYPE_FONTTYPE and LF.lfPitchAndFamily));
 484      // find out whether the font `IsDBCSFont'
 485      DC := GetDC(0);
 486      hOldFont := SelectObject(DC, ABaseFont.Reference.Handle);
 487      IsDBCSFont := (0 <> (GCP_DBCS and GetFontLanguageInfo(DC)));
 488      //debugln('TheFontsInfoManager.CreateFontsInfo IsDBCSFont=',IsDBCSFont);
 489      SelectObject(DC, hOldFont);
 490      ReleaseDC(0, DC);
 491    except
 492      Result^.BaseFont.Free;
 493      Dispose(Result);
 494      raise;
 495    end;
 496end;
 497
 498function TheFontsInfoManager.FindFontsInfo(const BFont: TFont):
 499  PheSharedFontsInfo;
 500var
 501  i: Integer;
 502begin
 503  for i := 0 to FFontsInfo.Count - 1 do
 504  begin
 505    Result := PheSharedFontsInfo(FFontsInfo[i]);
 506    if Result^.BaseFont.IsEqual(BFont) then
 507      Exit;
 508  end;
 509  Result := nil;
 510end;
 511
 512function TheFontsInfoManager.GetFontsInfo(ABaseFont: TFont): PheSharedFontsInfo;
 513begin
 514  ASSERT(Assigned(ABaseFont));
 515
 516  Result := FindFontsInfo(ABaseFont);
 517  if not Assigned(Result) then
 518  begin
 519    Result := CreateFontsInfo(ABaseFont);
 520    FFontsInfo.Add(Result);
 521  end;
 522
 523  if Assigned(Result) then
 524    Inc(Result^.RefCount);
 525end;
 526
 527procedure TheFontsInfoManager.ReleaseFontsInfo(var pFontsInfo: PheSharedFontsInfo);
 528begin
 529  ASSERT(Assigned(pFontsInfo));
 530
 531  with pFontsInfo^ do
 532  begin
 533{$IFDEF HE_ASSERT}
 534    ASSERT(LockCount < RefCount,
 535      'Call DeactivateFontsInfo before calling this.');
 536{$ELSE}
 537    ASSERT(LockCount < RefCount);
 538{$ENDIF}
 539    if RefCount > 1 then
 540      Dec(RefCount)
 541    else
 542    begin
 543      FFontsInfo.Remove(pFontsInfo);
 544      // free all objects
 545      BaseFont.Free;
 546      Dispose(pFontsInfo);
 547    end;
 548  end;
 549  pFontsInfo:=nil;
 550  if SynTextDrawerFinalization and (FFontsInfo.Count=0) then
 551    // the program is in the finalization phase
 552    // and this object is not used anymore -> destroy it
 553    Free;
 554end;
 555
 556{ TheFontStock }
 557
 558// CalcFontAdvance : Calculation a advance of a character of a font.
 559//  [*]hCalcFont will be selected as FDC's font if FDC wouldn't be zero.
 560Procedure TheFontStock.CalcFontAdvance(DC: HDC; FontData: PheFontData;
 561  FontHeight: integer);
 562
 563  Procedure DebugFont(s: String; a: array of const);
 564  begin
 565    if FontData^.Font <> nil then begin
 566      if FontData^.Font.Size = 0 then exit;
 567      s := 'Font=' + FontData^.Font.Name + ' Size=' + IntToStr(FontData^.Font.Size) + ' ' + s;
 568    end;
 569    s := 'TheFontStock.CalcFontAdvance: ' + s;
 570    DebugLn(Format(s, a));
 571  end;
 572
 573  procedure GetWHOForChar(s: char; out w, h ,o : Integer; var eto: Boolean);
 574  var
 575    s1, s2, s3: String;
 576    Size1, Size2, Size3: TSize;
 577    w2, w3: Integer;
 578  begin
 579    s1 := s;
 580    s2 := s1 + s;
 581    s3 := s2 + s;
 582    if not(GetTextExtentPoint(DC, PChar(s1), 1, Size1{%H-}) and
 583           GetTextExtentPoint(DC, PChar(s2), 2, Size2{%H-}) and
 584           GetTextExtentPoint(DC, PChar(s3), 3, Size3{%H-})) then
 585    begin
 586      DebugFont('Failed to get GetTextExtentPoint for %s', [s1]);
 587      w := 0;
 588      h := 0;
 589      o := 0;
 590      eto := True;
 591      exit;
 592    end;
 593    h := Size1.cy;
 594    // Size may contain overhang (italic, bold)
 595    // Size1 contains the size of 1 char + 1 overhang
 596    // Size2 contains the width of 2 chars, with only 1 overhang
 597
 598    // Start simple
 599    w := size1.cx;
 600    o := 0;
 601
 602    w2 := Size2.cx - Size1.cx;
 603    w3 := Size3.cx - Size2.cx;
 604    {$IFDEF SYNFONTDEBUG}
 605    DebugFont('Got TextExtends for %s=%d, %s=%d, %s=%d  Height=%d', [s1, Size1.cx, s2, Size2.cx, s3, Size3.cx, h]);
 606    {$ENDIF}
 607    if (w2 = w) and (w3 = w) then exit;
 608
 609    if (w2 <= w) and (w3 <= w) then begin
 610      // w includes overhang (may be fractional
 611      if w2 <> w3 then begin
 612        {$IFNDEF SYNFONTDEBUG} if abs(w3-w2) > 1 then {$ENDIF}
 613        DebugFont('Variable Overhang w=%d w2=%d w3=%d', [w, w2, w3]);
 614        w2 := Max(w2, w3);
 615      end;
 616      o := w - w2;
 617      w := w2;
 618      eto := True;
 619    end
 620    else
 621    if (w2 >= w) or (w3 >= w) then begin
 622      // Width may be fractional, check sanity and keep w
 623      o := 1;
 624      eto := True;
 625      if Max(w2, w3) > w + 1 then begin
 626        DebugFont('Size diff to bi for fractioanl (greater 1) w=%d w2=%d w3=%d', [w, w2, w3]);
 627        // Take a guess/average
 628        w2 := Max(w2, w3);
 629        o := w2 - w;
 630        w := Max(w, (w+w2-1) div 2);
 631      end;
 632    end
 633    else begin
 634      // broken font? one of w2/w3 is smaller, the other wider than w
 635      w := Max(w, (w+w2+w3-1) div 3);
 636      o := w div 2;
 637      eto := True;
 638    end;
 639    {$IFDEF SYNFONTDEBUG}
 640    DebugFont('Final result for %s  Width=%d  Overhang=%d  eto=%s', [s1, w, o, dbgs(eto)]);
 641    {$ENDIF}
 642  end;
 643
 644  procedure AdjustWHOForChar(s: char; var w, h ,o : Integer; var eto: Boolean);
 645  var
 646    h2, w2, o2: Integer;
 647  begin
 648    GetWHOForChar(s, w2, h2, o2, eto);
 649    h := Max(h, h2);
 650    o := Max(o, o2);
 651    if w <> w2 then begin
 652      w := Max(w, w2);
 653      eto := True;
 654    end;
 655  end;
 656
 657var
 658  TM: TTextMetric;
 659  Height, Width, OverHang: Integer;
 660  ETO: Boolean;
 661  Size1: TSize;
 662  tmw: Integer;
 663begin
 664  // Calculate advance of a character.
 665
 666  // TextMetric may fail, because:
 667  // tmMaxCharWidth may be the width of a single Width (Latin) char, like "M"
 668  //                or a double Width (Chinese) char
 669  // tmAveCharWidth is to small for proprtional fonts, as we need he witdh of the
 670  //                widest Latin char ("M").
 671  //                Even Monospace fonts, may have a smaller tmAveCharWidth (seen with Japanese)
 672
 673  // take several samples
 674  ETO := False;
 675  GetWHOForChar('M', Width, Height, OverHang, ETO);
 676  AdjustWHOForChar('W', Width, Height, OverHang, ETO);
 677  AdjustWHOForChar('@', Width, Height, OverHang, ETO);
 678  AdjustWHOForChar('X', Width, Height, OverHang, ETO);
 679  AdjustWHOForChar('m', Width, Height, OverHang, ETO);
 680  // Small Chars to detect proportional fonts
 681  AdjustWHOForChar('i', Width, Height, OverHang, ETO);
 682  AdjustWHOForChar(':', Width, Height, OverHang, ETO);
 683  AdjustWHOForChar('''', Width, Height, OverHang, ETO);
 684
 685  // Negative Overhang ?
 686  if (not ETO) and GetTextExtentPoint(DC, PChar('Ta'), 2, Size1{%H-}) then
 687    if Size1.cx < 2 * Width then begin
 688      {$IFDEF SYNFONTDEBUG}
 689      DebugFont('Negative Overhang for "Ta" cx=%d  Width=%d Overhang=%d', [Size1.cx, Width, OverHang]);
 690      {$ENDIF}
 691      ETO := True;
 692    end;
 693
 694  // Make sure we get the correct Height
 695  if GetTextExtentPoint(DC, PChar('Tgq[_|^'), 7, Size1) then
 696    Height := Max(Height, Size1.cy);
 697
 698  // DoubleCheck the result with GetTextMetrics
 699  GetTextMetrics(DC, TM{%H-});
 700  {$IFDEF SYNFONTDEBUG}
 701  DebugFont('TextMetrics tmHeight=%d, tmAve=%d, tmMax=%d, tmOver=%d', [TM.tmHeight, TM.tmAveCharWidth, TM.tmMaxCharWidth, TM.tmOverhang]);
 702  {$ENDIF}
 703
 704  tmw := TM.tmMaxCharWidth + Max(TM.tmOverhang,0);
 705  if Width = 0 then begin
 706    DebugFont('No Width from GetTextExtentPoint', []);
 707    Width := tmw;
 708  end
 709  else if (Width > tmw) and (TM.tmMaxCharWidth > 0) then begin
 710    DebugFont('Width(%d) > tmMaxWidth+Over(%d)', [Width, tmw]);
 711    // take a guess, this is probably a broken font
 712    Width := Min(Width, round((TM.tmMaxCharWidth + Max(TM.tmOverhang,0)) * 1.2));
 713    ETO := True;
 714  end;
 715
 716  if Height = 0 then begin
 717    DebugFont('No Height from GetTextExtentPoint, tmHeight=%d', [TM.tmHeight]);
 718    Height := TM.tmHeight;
 719  end
 720  else if Height < TM.tmHeight then begin
 721    DebugFont('Height from GetTextExtentPoint to low Height=%d, tmHeight=%d', [Height, TM.tmHeight]);
 722    Height := TM.tmHeight;
 723  end;
 724  if Height = 0 then begin
 725    DebugFont('SynTextDrawer: Fallback on FontHeight', []);
 726    Height := FontHeight;
 727  end;
 728
 729  // If we have a broken font, make sure we return a positive value
 730  if Width <= 0 then begin
 731    DebugFont('SynTextDrawer: Fallback on Width', []);
 732    Width := 1 + Height * 8 div 10;
 733  end;
 734
 735  //if OverHang >0 then debugln(['SynTextDrawer: Overhang=', OverHang]);;
 736  FontData^.CharAdv := Width;
 737  FontData^.CharHeight := Height;
 738  FontData^.NeedETO := ETO;
 739end;
 740
 741constructor TheFontStock.Create(InitialFont: TFont);
 742begin
 743  inherited Create;
 744
 745  SetBaseFont(InitialFont);
 746end;
 747
 748destructor TheFontStock.Destroy;
 749begin
 750  ReleaseFontsInfo;
 751  ASSERT(FDCRefCount = 0);
 752
 753  inherited;
 754end;
 755
 756function TheFontStock.GetBaseFont: TFont;
 757begin
 758  Result := FpInfo^.BaseFont;
 759end;
 760
 761function TheFontStock.GetCharAdvance: Integer;
 762begin
 763  Result := FpCrntFontData^.CharAdv;
 764end;
 765
 766function TheFontStock.GetCharHeight: Integer;
 767begin
 768  Result := FpCrntFontData^.CharHeight;
 769end;
 770
 771function TheFontStock.GetFontData(idx: Integer): PheFontData;
 772begin
 773  Result := @FpInfo^.FontsData[idx];
 774end;
 775
 776function TheFontStock.GetIsDBCSFont: Boolean;
 777begin
 778  Result := FpInfo^.IsDBCSFont;
 779end;
 780
 781function TheFontStock.GetIsTrueType: Boolean;
 782begin
 783  Result := FpInfo^.IsTrueType
 784end;
 785
 786function TheFontStock.GetNeedETO: Boolean;
 787begin
 788  Result := FpCrntFontData^.NeedETO;
 789end;
 790
 791function TheFontStock.InternalGetDC: HDC;
 792begin
 793  if FDCRefCount = 0 then
 794  begin
 795    ASSERT(FDC = 0);
 796    FDC := GetDC(0);
 797  end;
 798  Inc(FDCRefCount);
 799  Result := FDC;
 800end;
 801
 802procedure TheFontStock.InternalReleaseDC(Value: HDC);
 803begin
 804  Dec(FDCRefCount);
 805  if FDCRefCount <= 0 then
 806  begin
 807    ASSERT((FDC <> 0) and (FDC = Value));
 808    ReleaseDC(0, FDC);
 809    FDC := 0;
 810    ASSERT(FDCRefCount = 0);
 811  end;
 812end;
 813
 814procedure TheFontStock.ReleaseFontHandles;
 815begin
 816  if FUsingFontHandles then
 817    with GetFontsInfoManager do
 818    begin
 819      UnlockFontsInfo(FpInfo);
 820      FUsingFontHandles := False;
 821    end;
 822end;
 823
 824function TheFontStock.MonoSpace: Boolean;
 825begin
 826  FpCrntFontData^.Font.Reference;
 827  Result := FpCrntFontData^.Font.IsMonoSpace;
 828end;
 829
 830procedure TheFontStock.ReleaseFontsInfo;
 831begin
 832  if Assigned(FpInfo) then
 833    with GetFontsInfoManager do
 834    begin
 835      if FUsingFontHandles then
 836      begin
 837        UnlockFontsInfo(FpInfo);
 838        FUsingFontHandles := False;
 839      end;
 840      ReleaseFontsInfo(FpInfo);
 841    end;
 842end;
 843
 844procedure TheFontStock.SetBaseFont(Value: TFont);
 845var
 846  pInfo: PheSharedFontsInfo;
 847begin
 848  if Assigned(Value) then
 849  begin
 850    pInfo := GetFontsInfoManager.GetFontsInfo(Value);
 851    if pInfo = FpInfo then begin
 852      // GetFontsInfo has increased the refcount, but we already have the font
 853      // -> decrease the refcount
 854      GetFontsInfoManager.ReleaseFontsInfo(pInfo);
 855    end else begin
 856      ReleaseFontsInfo;
 857      FpInfo := pInfo;
 858      // clear styles
 859      SetStyle(Value.Style);
 860    end;
 861  end
 862  else
 863    raise EheFontStockException.Create('SetBaseFont: ''Value'' must be specified.');
 864end;
 865
 866procedure TheFontStock.SetStyle(Value: TFontStyles);
 867var
 868  idx: Integer;
 869  DC: HDC;
 870  hOldFont: HFONT;
 871  p: PheFontData;
 872begin
 873  idx := GetStyleIndex(Value);
 874  {$IFDEF HE_ASSERT}
 875  ASSERT(idx <= High(TheStockFontPatterns));
 876  {$ENDIF}
 877
 878  UseFontHandles;
 879  p := FontData[idx];
 880  if FpCrntFontData = p then
 881    Exit;
 882
 883  FpCrntFontData := p;
 884  with p^ do
 885    if Handle <> 0 then
 886    begin
 887      FCrntFont := Handle;
 888      FCrntStyle := Style;
 889      Exit;
 890    end;
 891
 892  // create font
 893  FpCrntFontData^.Font := TFont.Create;
 894  FpCrntFontData^.Font.Assign(BaseFont);
 895  FpCrntFontData^.Font.Style := Value;
 896  FCrntFont := FpCrntFontData^.Font.Reference.Handle;
 897
 898  DC := InternalGetDC;
 899  hOldFont := SelectObject(DC, FCrntFont);
 900
 901  // retrieve height and advances of new font
 902  FpInfo^.IsDBCSFont := (0 <> (GCP_DBCS and GetFontLanguageInfo(DC)));
 903  //debugln('TheFontStock.SetStyle A IsDBCSFont=',IsDBCSFont);
 904  FpCrntFontData^.Handle := FCrntFont;
 905  CalcFontAdvance(DC, FpCrntFontData, Max(BaseFont.Size, BaseFont.Height));
 906  //if FpCrntFontData^.NeedETO then debugln(['Needing ETO fot Font=',BaseFont.Name, ' Height=', BaseFont.Height, ' Style=', integer(Value) ]);
 907
 908  hOldFont:=SelectObject(DC, hOldFont);
 909  if hOldFont<>FCrntFont then
 910    RaiseGDBException('TheFontStock.SetStyle LCL interface lost the font');
 911  InternalReleaseDC(DC);
 912end;
 913
 914procedure TheFontStock.UseFontHandles;
 915begin
 916  if not FUsingFontHandles then
 917    with GetFontsInfoManager do
 918    begin
 919      LockFontsInfo(FpInfo);
 920      FUsingFontHandles := True;
 921    end;
 922end;
 923
 924{ TheTextDrawer }
 925
 926constructor TheTextDrawer.Create(CalcExtentBaseStyle: TFontStyles; ABaseFont: TFont);
 927var
 928  Side: TLazSynBorderSide;
 929begin
 930  inherited Create;
 931
 932  FEto := TEtoBuffer.Create;
 933  FFontStock := TheFontStock.Create(ABaseFont);
 934  FCalcExtentBaseStyle := CalcExtentBaseStyle;
 935  SetBaseFont(ABaseFont);
 936  FColor := clWindowText;
 937  FBkColor := clWindow;
 938
 939  for Side := Low(TLazSynBorderSide) to High(TLazSynBorderSide) do
 940  begin
 941    FFrameColor[Side] := clNone;
 942    FFrameStyle[Side] := slsSolid;
 943  end;
 944
 945  FOnFontChangedHandlers := TMethodList.Create;
 946  FOnFontChangedLock := 0;
 947end;
 948
 949destructor TheTextDrawer.Destroy;
 950begin
 951  FreeANdNil(FOnFontChangedHandlers);
 952  FFontStock.Free;
 953  ReleaseETODist;
 954  FreeAndNil(FEto);
 955
 956  inherited;
 957end;
 958
 959function TheTextDrawer.GetUseUTF8: boolean;
 960begin
 961  FFontStock.BaseFont.Reference;
 962  Result:=FFontStock.BaseFont.CanUTF8;
 963  //debugln('TheTextDrawer.GetUseUTF8 ',FFontStock.BaseFont.Name,' ',dbgs(FFontStock.BaseFont.CanUTF8),' ',dbgs(FFontStock.BaseFont.HandleAllocated));
 964end;
 965
 966function TheTextDrawer.GetMonoSpace: boolean;
 967begin
 968  FFontStock.BaseFont.Reference;
 969  Result:=FFontStock.BaseFont.IsMonoSpace;
 970  //debugln('TheTextDrawer.GetMonoSpace ',FFontStock.BaseFont.Name,' ',dbgs(FFontStock.BaseFont.IsMonoSpace),' ',dbgs(FFontStock.BaseFont.HandleAllocated));
 971end;
 972
 973function TheTextDrawer.CreateColorPen(AColor: TColor; AStyle: LongWord = PS_SOLID): HPen;
 974var
 975  ALogBrush: TLogBrush;
 976begin
 977  AStyle := AStyle + PS_ENDCAP_FLAT + PS_GEOMETRIC + PS_JOIN_MITER;
 978
 979  ALogBrush.lbStyle := BS_SOLID;
 980  ALogBrush.lbColor := ColorToRGB(AColor);
 981  ALogBrush.lbHatch := 0;
 982
 983  Result := ExtCreatePen(AStyle, 1, ALogBrush, 0, nil);
 984end;
 985
 986procedure TheTextDrawer.SetFrameStyle(Side: TLazSynBorderSide; AValue: TSynLineStyle);
 987begin
 988  if FFrameStyle[Side] <> AValue then
 989  begin
 990    FFrameStyle[Side] := AValue;
 991  end;
 992end;
 993
 994//procedure TheTextDrawer.SetFrameStyle(AValue: TSynLineStyle);
 995//var
 996//  Side: TLazSynBorderSide;
 997//begin
 998//  for Side := Low(TLazSynBorderSide) to High(TLazSynBorderSide) do
 999//    SetFrameStyle(Side, AValue);
1000//end;
1001
1002function TheTextDrawer.GetEto: TEtoBuffer;
1003begin
1004  Result := FEto;
1005  FEtoInitLen := 0;
1006end;
1007
1008function TheTextDrawer.GetCharExtra: Integer;
1009begin
1010  Result := Max(FCharExtra, -FBaseCharWidth + 1);
1011end;
1012
1013procedure TheTextDrawer.ReleaseETODist;
1014begin
1015  FEto.Clear;
1016end;
1017
1018procedure TheTextDrawer.BeginDrawing(DC: HDC);
1019begin
1020  if (FDC = DC) then
1021    ASSERT(FDC <> 0)
1022  else
1023  begin
1024    ASSERT((FDC = 0) and (DC <> 0) and (FDrawingCount = 0));
1025    FDC := DC;
1026    FSaveDC := SaveDC(DC);
1027    FSavedFont := SelectObject(DC, FCrntFont);
1028    LCLIntf.SetTextColor(DC, TColorRef(FColor));
1029    LCLIntf.SetBkColor(DC, TColorRef(FBkColor));
1030  end;
1031  Inc(FDrawingCount);
1032end;
1033
1034procedure TheTextDrawer.EndDrawing;
1035begin
1036  ASSERT(FDrawingCount >= 1);
1037  Dec(FDrawingCount);
1038  if FDrawingCount <= 0 then
1039  begin
1040    if FDC <> 0 then
1041    begin
1042      if FSavedFont <> 0 then
1043        SelectObject(FDC, FSavedFont);
1044      RestoreDC(FDC, FSaveDC);
1045    end;
1046    FSaveDC := 0;
1047    FDC := 0;
1048    FDrawingCount := 0;
1049  end;
1050end;
1051
1052function TheTextDrawer.GetCharWidth: Integer;
1053begin
1054  Result := FBaseCharWidth + CharExtra;
1055end;
1056
1057function TheTextDrawer.GetCharHeight: Integer;
1058begin
1059  Result := FBaseCharHeight;
1060end;
1061
1062procedure TheTextDrawer.SetBaseFont(Value: TFont);
1063begin
1064  if Assigned(Value) then
1065  begin
1066    inc(FOnFontChangedLock);
1067    try
1068      {$IFDEF SYNFONTDEBUG}
1069      Debugln(['TheTextDrawer.SetBaseFont Name=', Value.Name, ' Size=', Value.Size, 'Style=', Integer(Value.Style)]);
1070      {$ENDIF}
1071      ReleaseETODist;
1072      with FFontStock do
1073      begin
1074        SetBaseFont(Value);
1075        //debugln('TheTextDrawer.SetBaseFont B ',Value.Name);
1076        FBaseCharWidth := 0;
1077        FBaseCharHeight := 0;
1078      end;
1079      BaseStyle := Value.Style;
1080      SetStyle(Value.Style);
1081    finally
1082      dec(FOnFontChangedLock);
1083    end;
1084    FOnFontChangedHandlers.CallNotifyEvents(Self);
1085  end
1086  else
1087    raise EheTextDrawerException.Create('SetBaseFont: ''Value'' must be specified.');
1088end;
1089
1090procedure TheTextDrawer.SetBaseStyle(const Value: TFontStyles);
1091begin
1092  if (FCalcExtentBaseStyle <> Value) or (FBaseCharWidth = 0) then
1093  begin
1094    FCalcExtentBaseStyle := Value;
1095    ReleaseETODist;
1096    with FFontStock do
1097    begin
1098      Style := Value;
1099      FBaseCharWidth := Max(FBaseCharWidth, CharAdvance);
1100      FBaseCharHeight := Max(FBaseCharHeight, CharHeight);
1101      {$IFDEF SYNFONTDEBUG}
1102      Debugln(['TheTextDrawer.SetBaseStyle =', Integer(Value),
1103               ' CharAdvance=', CharAdvance, ' CharHeight=',CharHeight,
1104               ' FBaseCharWidth=', FBaseCharWidth, ' FBaseCharHeight=',FBaseCharHeight]);
1105      {$ENDIF}
1106    end;
1107    if FOnFontChangedLock = 0 then
1108      FOnFontChangedHandlers.CallNotifyEvents(Self);
1109  end;
1110end;
1111
1112procedure TheTextDrawer.SetStyle(Value: TFontStyles);
1113begin
1114  with FFontStock do
1115  begin
1116    SetStyle(Value);
1117    Self.FCrntFont := FontHandle;
1118  end;
1119  AfterStyleSet;
1120end;
1121
1122procedure TheTextDrawer.AfterStyleSet;
1123begin
1124  if FDC <> 0 then
1125    SelectObject(FDC, FCrntFont);
1126end;
1127
1128procedure TheTextDrawer.SetForeColor(Value: TColor);
1129begin
1130  if FColor <> Value then
1131  begin
1132    FColor := Value;
1133    if FDC <> 0 then
1134      SetTextColor(FDC, TColorRef(Value));
1135  end;
1136end;
1137
1138procedure TheTextDrawer.SetBackColor(Value: TColor);
1139begin
1140  if FBkColor <> Value then
1141  begin
1142    FBkColor := Value;
1143    if FDC <> 0 then
1144      LCLIntf.SetBkColor(FDC, TColorRef(Value));
1145  end;
1146end;
1147
1148procedure TheTextDrawer.SetFrameColor(Side: TLazSynBorderSide; AValue: TColor);
1149begin
1150  if FFrameColor[Side] <> AValue then
1151  begin
1152    FFrameColor[Side] := AValue;
1153  end;
1154end;
1155
1156procedure TheTextDrawer.SetFrameColor(AValue: TColor);
1157var
1158  Side: TLazSynBorderSide;
1159begin
1160  for Side := Low(TLazSynBorderSide) to High(TLazSynBorderSide) do
1161    SetFrameColor(Side, AValue);
1162end;
1163
1164procedure TheTextDrawer.SetCharExtra(Value: Integer);
1165begin
1166  if FCharExtra <> Value then
1167  begin
1168    FCharExtra := Value;
1169    FEtoInitLen := 0;
1170  end;
1171end;
1172
1173procedure TheTextDrawer.TextOut(X, Y: Integer; Text: PChar;
1174  Length: Integer);
1175begin
1176  LCLIntf.TextOut(FDC, X, Y, Text, Length);
1177end;
1178
1179procedure TheTextDrawer.ExtTextOut(X, Y: Integer; fuOptions: UINT;
1180  const ARect: TRect; Text: PChar; Length: Integer; FrameBottom: Integer = -1);
1181
1182  procedure InitETODist(InitValue: Integer);
1183  var
1184    i: Integer;
1185  begin
1186    FEto.SetMinLength(Length);
1187    for i := FEtoInitLen to FEto.Len-1 do
1188      FEto.EtoData[i] := InitValue;
1189    FEtoInitLen := FEto.Len;
1190  end;
1191
1192  function HasFrame: Boolean;
1193  var
1194    Side: TLazSynBorderSide;
1195  begin
1196    for Side := Low(TLazSynBorderSide) to High(TLazSynBorderSide) do
1197      if FFrameColor[Side] <> clNone then
1198        Exit(True);
1199    Result := False;
1200  end;
1201
1202var
1203  NeedDistArray: Boolean;
1204  DistArray: PInteger;
1205  RectFrame: TRect;
1206begin
1207  if HasFrame then // draw background // TODO: only if not default bg color
1208  begin
1209    InternalFillRect(FDC, ARect);
1210    if (fuOptions and ETO_OPAQUE) > 0 then
1211      fuOptions := fuOptions - ETO_OPAQUE;
1212    fuOptions := 0;
1213
1214    RectFrame := ARect;
1215    if FrameBottom >= 0 then
1216      RectFrame.Bottom := FrameBottom;
1217    DrawFrame(RectFrame);
1218  end;
1219
1220  NeedDistArray:= ForceEto or (CharExtra <> 0) or
1221    (FBaseCharWidth <> FFontStock.CharAdvance) or FFontStock.NeedETO;
1222  ForceEto := False;
1223  //DebugLn(['TheTextDrawer.ExtTextOut NeedDistArray=',NeedDistArray]);
1224  if NeedDistArray then begin
1225    if (FEtoInitLen < Length) then
1226     InitETODist(GetCharWidth);
1227    DistArray := FEto.Eto;
1228  end else begin
1229    DistArray:=nil;
1230  end;
1231  if UseUTF8 then
1232    LCLIntf.ExtUTF8Out(FDC, X, Y, fuOptions, @ARect, Text, Length, DistArray)
1233  else
1234    LCLIntf.ExtTextOut(FDC, X, Y, fuOptions, @ARect, Text, Length, DistArray);
1235end;
1236
1237procedure TheTextDrawer.NewTextOut(X, Y: Integer; fuOptions: UINT; const ARect: TRect;
1238  Text: PChar; Length: Integer; AnEto: TEtoBuffer);
1239var
1240  EtoArray: PInteger;
1241begin
1242  if AnEto <> nil then
1243    EtoArray := AnEto.Eto
1244  else
1245    EtoArray := nil;
1246
1247  if UseUTF8 then
1248    LCLIntf.ExtUTF8Out(FDC, X, Y, fuOptions, @ARect, Text, Length, EtoArray)
1249  else
1250    LCLIntf.ExtTextOut(FDC, X, Y, fuOptions, @ARect, Text, Length, EtoArray);
1251
1252end;
1253
1254procedure TheTextDrawer.DrawFrame(const ARect: TRect);
1255const
1256  WaveRadius = 3;
1257  PenStyle: array[TSynLineStyle] of LongWord = (
1258 { slsSolid  } PS_SOLID,
1259 { slsDashed } PS_DASH,
1260 { slsDotted } PS_DOT,
1261 { slsWaved  } PS_SOLID // we draw a wave using solid pen
1262  );
1263var
1264  Pen, OldPen: HPen;
1265  old: TPoint;
1266  Side: TLazSynBorderSide;
1267  LastColor: TColor;
1268  LastStyle: LongWord;
1269begin
1270  OldPen := 0;
1271  LastColor := clNone;
1272  LastStyle := PS_NULL;
1273  for Side := Low(TLazSynBorderSide) to High(TLazSynBorderSide) do
1274  begin
1275    if FFrameColor[Side] <> clNone then
1276    begin
1277      if (OldPen = 0) or (FFrameColor[Side] <> LastColor) or
1278         (PenStyle[FFrameStyle[Side]] <> LastStyle) then
1279      begin
1280        LastColor := FFrameColor[Side];
1281        LastStyle := PenStyle[FFrameStyle[Side]];
1282        if OldPen <> 0 then
1283          DeleteObject(SelectObject(FDC, OldPen));
1284        Pen := CreateColorPen(LastColor, LastStyle);
1285        OldPen := SelectObject(FDC, Pen);
1286      end;
1287
1288      case Side of
1289        bsLeft:
1290          begin
1291            MoveToEx(FDC, ARect.Left, ARect.Top, @old);
1292            if FFrameStyle[Side] = slsWaved then
1293              WaveTo(FDC, ARect.Left, ARect.Bottom, WaveRadius)
1294            else
1295              LineTo(FDC, ARect.Left, ARect.Bottom);
1296          end;
1297        bsTop:
1298          begin
1299            MoveToEx(FDC, ARect.Left, ARect.Top, @old);
1300            if FFrameStyle[Side] = slsWaved then
1301              WaveTo(FDC, ARect.Right, ARect.Top, WaveRadius)
1302            else
1303              LineTo(FDC, ARect.Right, ARect.Top);
1304          end;
1305        bsRight:
1306          begin
1307            if FFrameStyle[Side] = slsWaved then
1308            begin
1309              MoveToEx(FDC, ARect.Right - WaveRadius, ARect.Top, @old);
1310              WaveTo(FDC, ARect.Right - WaveRadius, ARect.Bottom, WaveRadius)
1311            end
1312            else
1313            begin
1314              MoveToEx(FDC, ARect.Right - 1, ARect.Top, @old);
1315              LineTo(FDC, ARect.Right - 1, ARect.Bottom);
1316            end;
1317          end;
1318        bsBottom:
1319          begin
1320            if FFrameStyle[Side] = slsWaved then
1321            begin
1322              MoveToEx(FDC, ARect.Left, ARect.Bottom - WaveRadius, @old);
1323              WaveTo(FDC, ARect.Right, ARect.Bottom - WaveRadius, WaveRadius)
1324            end
1325            else
1326            begin
1327              MoveToEx(FDC, ARect.Left, ARect.Bottom - 1, @old);
1328              LineTo(FDC, ARect.Right, ARect.Bottom - 1);
1329            end;
1330          end;
1331      end;
1332      MoveToEx(FDC, ARect.Left, ARect.Top, @old);
1333    end;
1334  end;
1335  DeleteObject(SelectObject(FDC, OldPen));
1336end;
1337
1338procedure TheTextDrawer.ForceNextTokenWithEto;
1339begin
1340  ForceEto := True;
1341end;
1342
1343function TheTextDrawer.NeedsEto: boolean;
1344begin
1345  Result := (CharExtra <> 0) or (FBaseCharWidth <> FFontStock.CharAdvance) or FFontStock.NeedETO;
1346end;
1347
1348procedure TheTextDrawer.DrawLine(X, Y, X2, Y2: Integer; AColor: TColor);
1349var
1350  Pen, OldPen: HPen;
1351  old : TPoint;
1352begin
1353  Pen := CreateColorPen(AColor);
1354  OldPen := SelectObject(FDC, Pen);
1355  MoveToEx(FDC, X, Y, @old);
1356  LineTo(FDC, X2, Y2);
1357  DeleteObject(SelectObject(FDC, OldPen));
1358end;
1359
1360procedure TheTextDrawer.FillRect(const aRect: TRect);
1361begin
1362  InternalFillRect(FDC, aRect);
1363end;
1364
1365procedure TheTextDrawer.ReleaseTemporaryResources;
1366begin
1367  FFontStock.ReleaseFontHandles;
1368end;
1369
1370procedure TheTextDrawer.RegisterOnFontChangeHandler(AHandlerProc: TNotifyEvent);
1371begin
1372  FOnFontChangedHandlers.Add(TMethod(AHandlerProc));
1373end;
1374
1375procedure TheTextDrawer.UnRegisterOnFontChangeHandler(AHandlerProc: TNotifyEvent);
1376begin
1377  FOnFontChangedHandlers.Remove(TMethod(AHandlerProc));
1378end;
1379
1380{ TheTextDrawerEx }
1381
1382procedure TheTextDrawerEx.AfterStyleSet;
1383begin
1384  inherited;
1385  with FontStock do
1386  begin
1387    FCrntDx := BaseCharWidth - CharAdvance;
1388    case IsDBCSFont of
1389      False:
1390        begin
1391          if StockDC <> 0 then
1392            SetTextCharacterExtra(StockDC, CharExtra + FCrntDx);
1393          if IsTrueType or (not (fsItalic in Style)) then
1394            FExtTextOutProc :=
1395              @TextOutOrExtTextOut
1396          else
1397            FExtTextOutProc :=
1398              @ExtTextOutFixed;
1399        end;
1400      True:
1401        begin
1402          FCrntDBDx := DBCHAR_CALCULATION_FALED;
1403          FExtTextOutProc :=
1404            @ExtTextOutWithETO;
1405        end;
1406    end;
1407  end;
1408end;
1409
1410procedure TheTextDrawerEx.ExtTextOut(X, Y: Integer; fuOptions: UINT;
1411  const ARect: TRect; Text: PChar; Length: Integer; FrameBottom: Integer = -1);
1412begin
1413  FExtTextOutProc(X, Y, fuOptions, ARect, Text, Length);
1414end;
1415
1416procedure TheTextDrawerEx.ExtTextOutFixed(X, Y: Integer; fuOptions: UINT;
1417  const ARect: TRect; Text: PChar; Length: Integer);
1418begin
1419  LCLIntf.ExtTextOut(StockDC, X, Y, fuOptions, @ARect, Text, Length, nil);
1420end;
1421
1422procedure TheTextDrawerEx.ExtTextOutForDBCS(X, Y: Integer; fuOptions: UINT;
1423  const ARect: TRect; Text: PChar; Length: Integer);
1424var
1425  pCrnt: PChar;
1426  pTail: PChar;
1427  pRun: PChar;
1428
1429  procedure GetSBCharRange;
1430  begin
1431    while (pRun <> pTail) and (not (pRun^ in LeadBytes)) do
1432      Inc(pRun);
1433  end;
1434
1435  procedure GetDBCharRange;
1436  begin
1437    while (pRun <> pTail) and (pRun^ in LeadBytes) do
1438      Inc(pRun, 2);
1439  end;
1440
1441var
1442  TmpRect: TRect;
1443  Len: Integer;
1444  n: Integer;
1445begin
1446  pCrnt := Text;
1447  pRun := Text;
1448  pTail := PChar(Pointer(Text) + Length);
1449  TmpRect := ARect;
1450  while pCrnt < pTail do
1451  begin
1452    GetSBCharRange;
1453    if pRun <> pCrnt then
1454    begin
1455      SetTextCharacterExtra(StockDC, CharExtra + FCrntDx);
1456      Len := PtrUInt(pRun) - PtrUInt(pCrnt);
1457      with TmpRect do
1458      begin
1459        n := GetCharWidth * Len;
1460        Right := Min(Left + n + GetCharWidth, ARect.Right);
1461        LCLIntf.ExtTextOut(StockDC, X, Y, fuOptions, @TmpRect, pCrnt, Len, nil);
1462        Inc(X, n);
1463        Inc(Left, n);
1464      end;
1465    end;
1466    pCrnt := pRun;
1467    if pRun = pTail then
1468      break;
1469
1470    GetDBCharRange;
1471    SetTextCharacterExtra(StockDC, CharExtra + FCrntDBDx);
1472    Len := PtrUInt(pRun) - PtrUInt(pCrnt);
1473    with TmpRect do
1474    begin
1475      n := GetCharWidth * Len;
1476      Right := Min(Left + n + GetCharWidth, ARect.Right);
1477      LCLIntf.ExtTextOut(StockDC, X, Y, fuOptions, @TmpRect, pCrnt, Len, nil);
1478      Inc(X, n);
1479      Inc(Left, n);
1480    end;
1481    pCrnt := pRun;
1482  end;
1483
1484  if (pCrnt = Text) or // maybe Text is not assigned or Length is 0
1485     (TmpRect.Right < ARect.Right) then
1486  begin
1487    SetTextCharacterExtra(StockDC, CharExtra + FCrntDx);
1488    LCLIntf.ExtTextOut(StockDC, X, Y, fuOptions, @TmpRect, nil, 0, nil);
1489  end;
1490end;
1491
1492procedure TheTextDrawerEx.ExtTextOutWithETO(X, Y: Integer; fuOptions: UINT;
1493  const ARect: TRect; Text: PChar; Length: Integer);
1494begin
1495  inherited ExtTextOut(X, Y, fuOptions, ARect, Text, Length);
1496end;
1497
1498procedure TheTextDrawerEx.TextOutOrExtTextOut(X, Y: Integer;
1499  fuOptions: UINT; const ARect: TRect; Text: PChar; Length: Integer);
1500begin
1501  // this function may be used when:
1502  //  a. the text does not containing any multi-byte characters
1503  // AND
1504  //   a-1. current font is TrueType.
1505  //   a-2. current font is RasterType and it is not italic.
1506  with ARect do
1507    if Assigned(Text) and (Length > 0)
1508    and (Left = X) and (Top = Y)
1509    and ((Bottom - Top) = GetCharHeight)
1510      and
1511       (Left + GetCharWidth * (Length + 1) > Right)
1512    then
1513      LCLIntf.TextOut(StockDC, X, Y, Text, Length)
1514    else
1515      LCLIntf.ExtTextOut(StockDC, X, Y, fuOptions, @ARect, Text, Length, nil)
1516end;
1517
1518{$IFNDEF HE_LEADBYTES}
1519procedure InitializeLeadBytes;
1520var
1521  c: Char;
1522begin
1523  for c := Low(Char) to High(Char) do
1524    if IsDBCSLeadByte(Byte(c)) then
1525      Include(LeadBytes, c);
1526end;
1527{$ENDIF} // HE_LEADBYTES
1528
1529initialization
1530  SynTextDrawerFinalization:=false;
1531{$IFNDEF HE_LEADBYTES}
1532  InitializeLeadBytes;
1533{$ENDIF} 
1534
1535finalization
1536  // MG: We can't free the gFontsInfoManager here, because the synedit
1537  //     components need it and will be destroyed with the Application object in
1538  //     the lcl after this finalization section.
1539  //     So, the flag SynTextDrawerFinalization is set and the gFontsInfoManager
1540  //     will destroy itself, as soon, as it is not used anymore.
1541  SynTextDrawerFinalization:=true;
1542  if Assigned(gFontsInfoManager) and (gFontsInfoManager.FFontsInfo.Count=0)
1543  then
1544    FreeAndNil(gFontsInfoManager);
1545
1546end.
1547