-
Notifications
You must be signed in to change notification settings - Fork 7
/
uFontInfo.pas
311 lines (276 loc) · 8.91 KB
/
uFontInfo.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
unit uFontInfo;
{$mode objfpc}
{$H+}
{$inline on}
interface
uses
Classes, SysUtils;
type
{ TFontInfo }
TFontInfo = class
FileName : string;
Copyright : string;
FamilyName : string;
SubFamilyName : string;
MajorVersion, MinorVersion : Word;
Stream : TMemoryStream;
constructor Create;
destructor Destroy; override;
end;
PFontInfo = ^TFontInfo;
procedure CollectFonts (PreLoad : boolean = false);
function GetFont (byDesc : string; var Size : integer) : TFontInfo;
function FontInfo (fn : string; var Info : TFontInfo) : boolean;
function GetFontByName (byName : string; Load : boolean) : TFontInfo;
var
Fonts : TList = nil;
implementation
uses ulog;
var
i : integer;
type
(* 0 Copyright notice.
1 Font Family name.
2 Font Subfamily name. Font style (italic, oblique) and weight (light, bold, black, etc.). A font with no particular differences in weight or style (e.g. medium weight, not italic) should have the string "Regular" stored in this position.
3 Unique font identifier. Usually similar to 4 but with enough additional information to be globally unique. Often includes information from Id 8 and Id 0.
4 Full font name. This should be a combination of strings 1 and 2. Exception: if the font is “Regular” as indicated in string 2, then use only the family name contained in string 1. This is the font name that Windows will expose to users.
5 Version string. Must begin with the syntax ‘Version n.nn ‘ (upper case, lower case, or mixed, with a space following the number).
6 Postscript name for the font. *)
TT_OFFSET_TABLE = record
uMajorVersion,
uMinorVersion,
uNumOfTables,
uSearchRange,
uEntrySelector,
uRangeShift : Word;
end;
// Tables in TTF file and theit placement and name (tag)
TT_TABLE_DIRECTORY = record
szTag : array [0..3] of Char; // table name
uCheckSum, // Check sum
uOffset, // Offset from beginning of file
uLength : Cardinal; // length of the table in bytes
end;
// Header of names table
TT_NAME_TABLE_HEADER = record
uFSelector, // format selector. Always 0
uNRCount, // Name Records count
uStorageOffset : Word; // Offset for strings storage,
end; // from start of the table
// Record in names table
TT_NAME_RECORD = record
uPlatformID,
uEncodingID,
uLanguageID,
uNameID,
uStringLength,
uStringOffset : Word; // from start of storage area
end;
function ByteSwap (const a : cardinal): cardinal; inline;
begin
Result := ((a and $ff) shl 24) + ((a and $ff00) shl 8) +
((a and $ff0000) shr 8) + ((a and $ff000000) shr 24);
end;
function ByteSwap16 (w : Word): Word; inline;
begin
Result := ((w and $ff) shl 8) + ((w and $ff00) shr 8);
end;
function FontInfo (fn : string; var Info : TFontInfo) : boolean;
var
f : TFileStream;
ot : TT_OFFSET_TABLE;
tb : TT_TABLE_DIRECTORY;
nth : TT_NAME_TABLE_HEADER;
nr : TT_NAME_RECORD;
i, j : integer;
p : int64;
a : string;
begin
Result := false;
Info.Copyright := '';
Info.FamilyName := '';
Info.FileName := '';
Info.SubFamilyName := '';
Info.MajorVersion := 0;
Info.MinorVersion := 0;
ot.uNumOfTables := 0; // prevent not initialised warning
tb.uCheckSum := 0; // prevent not initialised warning
nth.uNRCount := 0; // prevent not initialised warning
nr.uNameID := 0; // prevent not initialised warning
if ExtractFileExt (fn) = '' then fn := fn + '.ttf';
if not FileExists (fn) then exit;
Info.FileName := fn;
try
f := TFileStream.Create (fn, fmOpenRead);
try
f.Seek (0, soFromBeginning);
f.Read (ot, SizeOf (TT_OFFSET_TABLE));
ot.uNumOfTables := ByteSwap16 (ot.uNumOfTables);
Info.MajorVersion := ByteSwap16 (ot.uMajorVersion);
Info.MinorVersion := ByteSwap16 (ot.uMinorVersion);
for i := 1 to ot.uNumOfTables do
begin
f.Read (tb, SizeOf (TT_TABLE_DIRECTORY));
if CompareText (string (tb.szTag), 'name')= 0 then
begin
tb.uLength := ByteSwap (tb.uLength);
tb.uOffset := ByteSwap (tb.uOffset);
f.Seek (tb.uOffset, soFromBeginning);
f.Read (nth, SizeOf (TT_NAME_TABLE_HEADER));
nth.uNRCount := ByteSwap16 (nth.uNRCount);
nth.uStorageOffset := ByteSwap16 (nth.uStorageOffset);
for j := 1 to nth.uNRCount do
begin
f.Read (nr, SizeOf (TT_NAME_RECORD));
nr.uNameID := ByteSwap16 (nr.uNameID);
nr.uStringLength := ByteSwap16 (nr.uStringLength);
nr.uStringOffset := ByteSwap16 (nr.uStringOffset);
nr.uEncodingID := ByteSwap16 (nr.uEncodingID);
nr.uLanguageID := ByteSwap16 (nr.uLanguageID);
p := f.Position;
f.Seek (tb.uOffset + nth.uStorageOffset + nr.uStringOffset, soFromBeginning);
SetLength (a, nr.uStringLength);
f.Read (a[1], nr.uStringLength);
if nr.uEncodingID = 0 then
case nr.uNameID of
0 : Info.Copyright := a;
1 : Info.FamilyName := a;
2 : Info.SubFamilyName := a;
end;
f.Seek (p, soFromBeginning);
end;
Result := true;
break;
end;
end;
finally
f.Free;
end;
except
end;
end;
procedure CollectFonts (PreLoad : boolean);
var
sr : TSearchRec;
err : integer;
fi : TFontInfo;
i : integer;
f : TFileStream;
begin
if Fonts = nil then exit;
for i := 0 to Fonts.Count - 1 do TFontInfo (Fonts[i]).Free;
Fonts.Clear;
err := FindFirst ('*.ttf', faArchive, sr);
while err = 0 do
begin
fi := TFontInfo.Create;
if FontInfo (sr.Name, fi) then
begin
Fonts.Add (fi);
if Preload then
try
f := TFileStream.Create (sr.Name, fmOpenRead);
fi.Stream := TMemoryStream.Create;
fi.Stream.CopyFrom (f, 0);
f.Free;
except
end;
end
else
fi.Free;
err := FindNext (sr);
end;
FindClose (sr);
end;
const
ny : array [boolean] of string = ('NO', 'YES');
function GetFont (byDesc : string; var Size : integer) : TFontInfo;
var
i, j, k : integer;
bd, it : boolean;
fn : string;
begin
Result := nil;
i := Pos ('-', byDesc);
if i = 0 then exit;
fn := '';
bd := false;
it := false;
try
fn := Copy (byDesc, i + 1, length (byDesc) - i);
// log ('family name ' + fn);
k := 0;
for j := 1 to i - 1 do
case byDesc[j] of
'B', 'b' : bd := true;
'I', 'i' : it := true;
// 'U', 'u' : ul := true; // underline is a rendering function
'0'..'9' : k := (k * 10) + (ord (byDesc[j]) - 48);
end;
if k > 0 then Size := k;
except
end;
for i := 0 to Fonts.Count - 1 do
with TFontInfo (Fonts[i]) do
if (CompareText (FamilyName, fn) = 0) and
((Pos ('Bold', SubFamilyName) > 0) = bd) and
((Pos ('Italic', SubFamilyName) > 0) = it) then
begin
Result := TFontInfo (Fonts[i]);
exit
end;
end;
function GetFontByName (byName : string; Load : boolean) : TFontInfo;
var
i : integer;
f : TFilestream;
begin
Result := nil;
for i := 0 to Fonts.Count - 1 do
begin
if TFontInfo (Fonts[i]).FileName = byName then
begin
Result := TFontInfo (Fonts[i]);
break;
end;
end;
if (Result = nil) and FileExists (byName) then
begin
Result := TFontInfo.Create;
if FontInfo (byName, Result) then
Fonts.Add (Result)
else
begin
Result.Free;
Result := nil;
end;
end;
if (Result = nil) or (not Load) then exit;
if Result.Stream <> nil then exit; // already loaded
Result.Stream := TMemoryStream.Create;
try
f := TFileStream.Create (byName, fmOpenRead);
Result.Stream.CopyFrom (f, f.Size);
f.Free;
except
// Log ('Error loading font.');
Result.Stream.Free;
Result.Stream := nil;
end;
end;
{ TFontInfo }
constructor TFontInfo.Create;
begin
Stream := nil;
end;
destructor TFontInfo.Destroy;
begin
if Assigned (Stream) then Stream.Free;
inherited Destroy;
end;
initialization
Fonts := TList.Create;
finalization
for i := 0 to Fonts.Count - 1 do TFontInfo (Fonts[i]).Free;
Fonts.Free;
end.