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