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