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