1 {
2 *****************************************************************************
3 This file is part of the Lazarus Component Library (LCL)
4
5 See the file COPYING.modifiedLGPL.txt, included in this distribution,
6 for details about the license.
7 *****************************************************************************
8 }
9 unit Gtk2FontCache;
10
11 {$mode objfpc}{$H+}
12
13 interface
14
15 uses
16 // RTL
17 Classes, SysUtils, glib2, pango, Laz_AVL_Tree,
18 // LazUtils
19 LazUtilities, LazLoggerBase, LazTracer,
20 // LCL
21 LCLType, Gtk2Def, LCLResCache;
22
23 type
24 TGtkFontCacheDescriptor = class;
25
26 { TGtkFontCacheItem }
27
28 TGtkFontCacheItem = class(TResourceCacheItem)
29 public
30 GtkFont: TGtkIntfFont;
31
32 // metrics
33 MetricsValid: boolean;
34 lBearing: LongInt;
35 rBearing: LongInt;
36 TextMetric: TTextMetric;
37 IsDoubleByteChar: boolean;
38 IsMonoSpace: boolean;
39 procedure WarnReferenceHigh; override;
40 end;
41
42
43 { TGtkFontCacheDescriptor }
44
45 TGtkFontCacheDescriptor = class(TResourceCacheDescriptor)
46 public
47 LogFont: TLogFont;
48 LongFontName: string;
49 PangoFontDescription: PPangoFontDescription;
50 destructor Destroy; override;
51 end;
52
53
54 { TGtkFontCache
55 Notes:
56 Each font can be used by several Device Contexts.
57 Each font can have several font descriptors.
58 A font descriptor has one font.
59 }
60
61 TGtkFontCache = class(TResourceCache)
62 protected
63 procedure RemoveItem(Item: TResourceCacheItem); override;
64 public
65 constructor Create;
CompareItemsnull66 function CompareItems({%H-}Tree: TAvlTree; Item1, Item2: Pointer): integer; override;
CompareDescriptorsnull67 function CompareDescriptors({%H-}Tree: TAvlTree; Desc1, Desc2: Pointer): integer; override;
FindGtkFontnull68 function FindGtkFont(TheGtkFont: TGtkIntfFont): TGtkFontCacheItem;
FindGtkFontDescnull69 function FindGtkFontDesc(const LogFont: TLogFont;
70 const LongFontName: string): TGtkFontCacheDescriptor;
FindADescriptornull71 function FindADescriptor(TheGtkFont: TGtkIntfFont): TGtkFontCacheDescriptor;
Addnull72 function Add(TheGtkFont: TGtkIntfFont; const LogFont: TLogFont;
73 const LongFontName: string): TGtkFontCacheDescriptor;
AddWithoutNamenull74 function AddWithoutName(TheGtkFont: TGtkIntfFont): TGtkFontCacheDescriptor;
75 procedure Reference(TheGtkFont: TGtkIntfFont);
76 procedure Unreference(TheGtkFont: TGtkIntfFont);
77 procedure DumpDescriptors;
78 end;
79
LogFontToStringnull80 function LogFontToString(const LogFont: TLogFont): string;
81
82 procedure ReferenceGtkIntfFont(AFont: TGtkIntfFont);
83 procedure UnreferenceGtkIntfFont(AFont: TGtkIntfFont);
84
85 var
86 FontCache: TGtkFontCache;
87
88 implementation
89
90 type
91 TLogFontAndName = record
92 LogFont: TLogFont;
93 LongFontName: string;
94 end;
95 PLogFontAndName = ^TLogFontAndName;
96
LogFontToStringnull97 function LogFontToString(const LogFont: TLogFont): string;
98 var
99 i: Integer;
100 begin
101 Result:=''
102 +' lfFaceName="'+LogFont.lfFaceName+'" '
103 +' CharSet='+dbgs(LogFont.lfCharSet)
104 +' ClipPrecision='+dbgs(LogFont.lfClipPrecision)
105 +' Escapement='+dbgs(LogFont.lfEscapement)
106 +' Height='+dbgs(LogFont.lfHeight)
107 +' Italic='+dbgs(LogFont.lfItalic)
108 +' Orientation='+dbgs(LogFont.lfOrientation)
109 +' OutPrecision='+dbgs(LogFont.lfOutPrecision)
110 +' PitchAndFamily='+dbgs(LogFont.lfPitchAndFamily)
111 +' Quality='+dbgs(LogFont.lfQuality)
112 +' StrikeOut='+dbgs(LogFont.lfStrikeOut)
113 +' Underline='+dbgs(LogFont.lfUnderline)
114 +' Weight='+dbgs(LogFont.lfWeight)
115 +' Width='+dbgs(LogFont.lfWidth)
116 +#13#10;
117 for i:=0 to SizeOf(LogFont)-1 do
118 Result:=Result+HexStr(ord(PChar(@LogFont)[i]),2);
119 Result:=Result+#13#10;
120 end;
121
122 procedure ReferenceGtkIntfFont(AFont: TGtkIntfFont);
123 begin
124 //DebugLn(['ReferenceGtkIntfFont ',dbgs(AFont)]);
125 g_object_ref(AFont);
126 end;
127
128 procedure UnreferenceGtkIntfFont(AFont: TGtkIntfFont);
129 begin
130 //DebugLn(['UnreferenceGtkIntfFont ',dbgs(AFont)]);
131 g_object_unref(AFont);
132 end;
133
134 { TGtkFontCache }
135
CompareGtkFontWithResItemnull136 function CompareGtkFontWithResItem(Font: TGtkIntfFont;
137 Item: TGtkFontCacheItem): integer;
138 begin
139 Result := ComparePointers(Font, Item.GtkFont);
140 end;
141
CompareLogFontAndNameWithResDescnull142 function CompareLogFontAndNameWithResDesc(Key: PLogFontAndName;
143 Desc: TGtkFontCacheDescriptor): integer;
144 begin
145 Result:=CompareStr(Key^.LongFontName,Desc.LongFontName);
146 //debugln('CompareLogFontAndNameWithResDesc A ',Key^.LongFontName,' ',Desc.LongFontName,' ',DbgS(Desc),' Result=',Result);
147 if Result=0 then
148 Result:=CompareMemRange(@Key^.LogFont,@Desc.LogFont,SizeOf(Desc.LogFont));
149 //debugln('CompareLogFontAndNameWithResDesc END Result=',Result);
150 end;
151
152 procedure TGtkFontCache.RemoveItem(Item: TResourceCacheItem);
153 begin
154 UnreferenceGtkIntfFont(TGtkFontCacheItem(Item).GtkFont);
155 inherited RemoveItem(Item);
156 end;
157
158 constructor TGtkFontCache.Create;
159 begin
160 inherited Create;
161 FResourceCacheItemClass:=TGtkFontCacheItem;
162 FResourceCacheDescriptorClass:=TGtkFontCacheDescriptor;
163 end;
164
CompareItemsnull165 function TGtkFontCache.CompareItems(Tree: TAvlTree; Item1, Item2: Pointer): integer;
166 begin
167 Result:=ComparePointers(TGtkFontCacheItem(Item1).GtkFont,
168 TGtkFontCacheItem(Item2).GtkFont);
169 end;
170
TGtkFontCache.CompareDescriptorsnull171 function TGtkFontCache.CompareDescriptors(Tree: TAvlTree; Desc1, Desc2: Pointer): integer;
172 var
173 Descriptor1: TGtkFontCacheDescriptor;
174 Descriptor2: TGtkFontCacheDescriptor;
175 begin
176 Descriptor1:=TGtkFontCacheDescriptor(Desc1);
177 Descriptor2:=TGtkFontCacheDescriptor(Desc2);
178 Result:=CompareStr(Descriptor1.LongFontName,Descriptor2.LongFontName);
179 if Result<>0 then exit;
180 Result:=CompareMemRange(@Descriptor1.LogFont,@Descriptor2.LogFont,
181 SizeOf(Descriptor1.LogFont));
182 end;
183
FindGtkFontnull184 function TGtkFontCache.FindGtkFont(TheGtkFont: TGtkIntfFont): TGtkFontCacheItem;
185 var
186 ANode: TAvlTreeNode;
187 begin
188 ANode:=FItems.Findkey(TheGtkFont,TListSortCompare(@CompareGtkFontWithResItem));
189 if ANode<>nil then
190 Result:=TGtkFontCacheItem(ANode.Data)
191 else
192 Result:=nil;
193 end;
194
FindGtkFontDescnull195 function TGtkFontCache.FindGtkFontDesc(const LogFont: TLogFont;
196 const LongFontName: string): TGtkFontCacheDescriptor;
197 var
198 LogFontAndName: TLogFontAndName;
199 ANode: TAvlTreeNode;
200 begin
201 LogFontAndName.LogFont:=LogFont;
202 LogFontAndName.LongFontName:=LongFontName;
203 ANode:=FDescriptors.Findkey(@LogFontAndName,
204 TListSortCompare(@CompareLogFontAndNameWithResDesc));
205 if ANode<>nil then
206 Result:=TGtkFontCacheDescriptor(ANode.Data)
207 else
208 Result:=nil;
209 end;
210
FindADescriptornull211 function TGtkFontCache.FindADescriptor(TheGtkFont: TGtkIntfFont): TGtkFontCacheDescriptor;
212 var
213 Item: TGtkFontCacheItem;
214 begin
215 Item:=FindGtkFont(TheGtkFont);
216 if Item=nil then
217 Result:=nil
218 else
219 Result:=TGtkFontCacheDescriptor(Item.FirstDescriptor);
220 end;
221
Addnull222 function TGtkFontCache.Add(TheGtkFont: TGtkIntfFont; const LogFont: TLogFont;
223 const LongFontName: string): TGtkFontCacheDescriptor;
224 var
225 Item: TGtkFontCacheItem;
226 begin
227 if TheGtkFont=nil then
228 RaiseGDBException('TGtkFontCache.Add TheGtkFont=nil');
229 if FindGtkFontDesc(LogFont,LongFontName)<>nil then
230 RaiseGDBException('TGtkFontCache.Add font desc added twice');
231
232 // find cache item with TheGtkFont
233 Item:=FindGtkFont(TheGtkFont);
234 if Item=nil then begin
235 // create new item
236 Item:=TGtkFontCacheItem.Create(Self,0);
237 Item.GtkFont:=TheGtkFont;
238 ReferenceGtkIntfFont(TheGtkFont);
239 FItems.Add(Item);
240 end;
241
242 // create descriptor
243 Result:=TGtkFontCacheDescriptor.Create(Self,Item);
244 Result.LongFontName:=LongFontName;
245 Result.LogFont:=LogFont;
246 FDescriptors.Add(Result);
247 if FindGtkFontDesc(LogFont,LongFontName)=nil then begin
248 DebugLn('TGtkFontCache.Add Added: %p LongFontName=%s LogFont=%s', [Pointer(Result), Result.LongFontName, LogFontToString(Result.LogFont)]);
249 DumpDescriptors;
250 RaiseGDBException('');
251 end;
252 end;
253
AddWithoutNamenull254 function TGtkFontCache.AddWithoutName(TheGtkFont: TGtkIntfFont): TGtkFontCacheDescriptor;
255 var
256 LogFont: TLogFont;
257 LongFontName: string;
258 begin
259 FillChar(LogFont{%H-},SizeOf(LogFont),0);
260 LongFontName:=dbghex({%H-}PtrUInt(TheGtkFont));
261 Result:=Add(TheGtkFont,LogFont,LongFontName);
262 end;
263
264 procedure TGtkFontCache.Reference(TheGtkFont: TGtkIntfFont);
265 var
266 Item: TGtkFontCacheItem;
267 begin
268 Item:=FindGtkFont(TheGtkFont);
269 if Item=nil then
270 ReferenceGtkIntfFont(TheGtkFont)
271 else
272 Item.IncreaseRefCount;
273 end;
274
275 procedure TGtkFontCache.Unreference(TheGtkFont: TGtkIntfFont);
276 var
277 Item: TGtkFontCacheItem;
278 begin
279 Item:=FindGtkFont(TheGtkFont);
280 if Item=nil then
281 UnreferenceGtkIntfFont(TheGtkFont)
282 else
283 Item.DecreaseRefCount;
284 end;
285
286 procedure TGtkFontCache.DumpDescriptors;
287 var
288 ANode: TAvlTreeNode;
289 Desc: TGtkFontCacheDescriptor;
290 i: Integer;
291 begin
292 ANode:=FDescriptors.FindLowest;
293 i:=1;
294 while ANode<>nil do begin
295 Desc:=TGtkFontCacheDescriptor(ANode.Data);
296 DebugLn('TGtkFontCache.DumpDescriptors %d %p %s %s', [i, Pointer(Desc), Desc.LongFontName, LogFontToString(Desc.LogFont)]);
297 ANode:=FDescriptors.FindSuccessor(ANode);
298 inc(i);
299 end;
300 end;
301
302 { TGtkFontCacheItem }
303
304 procedure TGtkFontCacheItem.WarnReferenceHigh;
305 begin
306 inherited WarnReferenceHigh;
307 debugln(' GtkFont='+DbgS(GtkFont));
308 if FirstDescriptor<>nil then
309 debugln(' '+TGtkFontCacheDescriptor(FirstDescriptor).LongFontName
310 +' '+LogFontToString(TGtkFontCacheDescriptor(FirstDescriptor).LogFont));
311 end;
312
313 { TGtkFontCacheDescriptor }
314
315 destructor TGtkFontCacheDescriptor.Destroy;
316 begin
317 if PangoFontDescription<>nil then begin
318 pango_font_description_free(PangoFontDescription);
319 PangoFontDescription:=nil;
320 end;
321 inherited Destroy;
322 end;
323
324 initialization
325 FontCache:=TGtkFontCache.Create;
326
327 finalization
328 FontCache.Free;
329 FontCache:=nil;
330
331 end.
332