/components/synedit/syntextdrawer.pp

http://github.com/graemeg/lazarus · Puppet · 1547 lines · 1483 code · 64 blank · 0 comment · 24 complexity · e12dccabca84c9883315abbe0e71c254 MD5 · raw file

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