← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/lazutils/lazfreetypefontcollection.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/lazutils/lazfreetypefontcollection.pas
 
1
unit LazFreeTypeFontCollection;
 
2
 
 
3
{$mode objfpc}{$H+}
 
4
 
 
5
interface
 
6
 
 
7
uses
 
8
  Classes, SysUtils, EasyLazFreeType, AvgLvlTree, LazFreeType, TTTypes;
 
9
 
 
10
type
 
11
  { TFontCollectionItem }
 
12
 
 
13
  TFontCollectionItem = class(TCustomFontCollectionItem)
 
14
  private
 
15
    FFilename: string;
 
16
    FInformation: array[TFreeTypeInformation] of string;
 
17
    FVersionNumber: string;
 
18
    FStyleList: array of string;
 
19
    FFace: TT_Face;
 
20
    FFaceUsage: integer;
 
21
    FUsePostscriptStyle: boolean;
 
22
    procedure UpdateStyles;
 
23
    procedure SetInformation(AIndex: TFreeTypeInformation; AValue: string);
 
24
    procedure SetUsePostscriptStyle(AValue: boolean);
 
25
  protected
 
26
    function GetFilename: string; override;
 
27
    function GetBold: boolean; override;
 
28
    function GetInformation(AIndex: TFreeTypeInformation): string; override;
 
29
    function GetItalic: boolean; override;
 
30
    function GetStyleCount: integer; override;
 
31
    function GetStyles: string; override;
 
32
    function GetStyle(AIndex: integer): string; override;
 
33
    function GetVersionNumber: string; override;
 
34
  public
 
35
    constructor Create(AFilename: string);
 
36
    destructor Destroy; override;
 
37
    function HasStyle(AStyle: string): boolean; override;
 
38
    property Information[AIndex: TFreeTypeInformation]: string read GetInformation write SetInformation;
 
39
    property VersionNumber: string read GetVersionNumber write FVersionNumber;
 
40
    function CreateFont: TFreeTypeFont; override;
 
41
    function QueryFace: TT_Face; override;
 
42
    procedure ReleaseFace; override;
 
43
    property UsePostscriptStyle: boolean read FUsePostscriptStyle write SetUsePostscriptStyle;
 
44
  end;
 
45
 
 
46
  { TFamilyCollectionItem }
 
47
 
 
48
  TFamilyCollectionItem = class(TCustomFamilyCollectionItem)
 
49
  private
 
50
    FFamilyName: string;
 
51
    FFonts: array of TFontCollectionItem;
 
52
    FFontCount: integer;
 
53
    FStyles: array of string;
 
54
    FStyleCount: integer;
 
55
    FUsePostscriptStyle: boolean;
 
56
  protected
 
57
    function GetFontByIndex(AIndex: integer): TCustomFontCollectionItem; override;
 
58
    function GetFontByStyles(AStyles: string): TCustomFontCollectionItem;
 
59
    function GetFontIndexByStyles(AStyles: string): integer;
 
60
    function GetStyle(AIndex: integer): string; override;
 
61
    procedure AddStyle(AName: string);
 
62
    function GetStyles: string; override;
 
63
    function GetFamilyName: string; override;
 
64
    function GetFontCount: integer; override;
 
65
    function GetStyleCount: integer; override;
 
66
  public
 
67
    constructor Create(AName: string);
 
68
    procedure AddFont(AFontItem: TFontCollectionItem);
 
69
    function GetFont(const AStyles: array of string; NeedAllStyles: boolean = false; NoMoreStyle: boolean = false): TCustomFontCollectionItem; override;
 
70
    function GetFont(AStyle: string; NeedAllStyles: boolean = false; NoMoreStyle: boolean = false): TCustomFontCollectionItem; override;
 
71
    function GetFontIndex(const AStyles: array of string; NeedAllStyles: boolean = false; NoMoreStyle: boolean = false): integer; override;
 
72
    function GetFontIndex(AStyle: string; NeedAllStyles: boolean = false; NoMoreStyle: boolean = false): integer; override;
 
73
    function HasStyle(AName: string): boolean; override;
 
74
  end;
 
75
 
 
76
  { TFreeTypeFontCollection }
 
77
 
 
78
  TFreeTypeFontCollection = class(TCustomFreeTypeFontCollection)
 
79
  private
 
80
    FFontList: TAvgLvlTree;
 
81
    FTempFont: TFreeTypeFont;
 
82
    FUpdateCount: integer;
 
83
 
 
84
    FFamilyList: TAvgLvlTree;
 
85
 
 
86
    function AddFamily(AName: string): TFamilyCollectionItem;
 
87
    function FindFamily(AName: string): TFamilyCollectionItem;
 
88
    function FindFont(AFileName: string): TFontCollectionItem;
 
89
 
 
90
    function CompareFontFileName({%H-} Tree: TAvgLvlTree; Data1, Data2: Pointer): integer;
 
91
    function CompareFamilyName({%H-} Tree: TAvgLvlTree; Data1, Data2: Pointer): integer;
 
92
 
 
93
  protected
 
94
    function GetFont(AFileName: string): TCustomFontCollectionItem; override;
 
95
    function GetFamily(AName: string): TCustomFamilyCollectionItem; override;
 
96
    function GetFamilyCount: integer; override;
 
97
    function GetFontCount: integer; override;
 
98
 
 
99
  public
 
100
    constructor Create; override;
 
101
    procedure Clear; override;
 
102
    procedure BeginUpdate; override;
 
103
    procedure AddFolder(AFolder: string); override;
 
104
    function AddFile(AFilename: string): boolean; override;
 
105
    procedure EndUpdate; override;
 
106
    destructor Destroy; override;
 
107
    function FontFileEnumerator: IFreeTypeFontEnumerator; override;
 
108
    function FamilyEnumerator: IFreeTypeFamilyEnumerator; override;
 
109
  end;
 
110
 
 
111
implementation
 
112
 
 
113
type
 
114
  { TFamilyEnumerator }
 
115
 
 
116
   TFamilyEnumerator = class(TInterfacedObject,IFreeTypeFamilyEnumerator)
 
117
   private
 
118
     FNodeEnumerator: TAvgLvlTreeNodeEnumerator;
 
119
   public
 
120
     constructor Create(ANodeEnumerator: TAvgLvlTreeNodeEnumerator);
 
121
     destructor Destroy; override;
 
122
     function MoveNext: boolean;
 
123
     function GetCurrent: TCustomFamilyCollectionItem;
 
124
   end;
 
125
 
 
126
  { TFontEnumerator }
 
127
 
 
128
   TFontEnumerator = class(TInterfacedObject,IFreeTypeFontEnumerator)
 
129
   private
 
130
     FNodeEnumerator: TAvgLvlTreeNodeEnumerator;
 
131
   public
 
132
     constructor Create(ANodeEnumerator: TAvgLvlTreeNodeEnumerator);
 
133
     destructor Destroy; override;
 
134
     function MoveNext: boolean;
 
135
     function GetCurrent: TCustomFontCollectionItem;
 
136
   end;
 
137
 
 
138
{ TFontCollectionItem }
 
139
 
 
140
function TFontCollectionItem.GetStyles: string;
 
141
var i: integer;
 
142
begin
 
143
  if StyleCount = 0 then
 
144
    result := 'Regular'
 
145
  else
 
146
  begin
 
147
    result := '';
 
148
    for i := 0 to StyleCount-1 do
 
149
    begin
 
150
      if i > 0 then result += ' ';
 
151
      result += Style[i];
 
152
    end;
 
153
  end;
 
154
end;
 
155
 
 
156
function TFontCollectionItem.GetInformation(AIndex: TFreeTypeInformation): string;
 
157
begin
 
158
  if (AIndex < low(TFreeTypeInformation)) or (AIndex > high(TFreeTypeInformation)) then
 
159
    result := ''
 
160
  else
 
161
    result := FInformation[AIndex];
 
162
end;
 
163
 
 
164
function TFontCollectionItem.GetBold: boolean;
 
165
begin
 
166
  result := HasStyle('Bold');
 
167
end;
 
168
 
 
169
function TFontCollectionItem.GetItalic: boolean;
 
170
begin
 
171
  result := HasStyle('Italic') or HasStyle('Oblique');
 
172
end;
 
173
 
 
174
function TFontCollectionItem.GetStyleCount: integer;
 
175
begin
 
176
  result := length(FStyleList);
 
177
end;
 
178
 
 
179
procedure TFontCollectionItem.SetInformation(AIndex: TFreeTypeInformation;
 
180
  AValue: string);
 
181
begin
 
182
  if (AIndex >= low(TFreeTypeInformation)) and (AIndex <= high(TFreeTypeInformation)) then
 
183
  begin
 
184
    FInformation[AIndex] := AValue;
 
185
    if ((AIndex = ftiStyle) and not FUsePostscriptStyle) or
 
186
       ((AIndex = ftiPostscriptName) and FUsePostscriptStyle) then UpdateStyles;
 
187
  end;
 
188
end;
 
189
 
 
190
procedure TFontCollectionItem.SetUsePostscriptStyle(AValue: boolean);
 
191
begin
 
192
  if AValue <> FUsePostscriptStyle then
 
193
  begin
 
194
    FUsePostscriptStyle:= AValue;
 
195
    UpdateStyles;
 
196
  end;
 
197
end;
 
198
 
 
199
function TFontCollectionItem.GetFilename: string;
 
200
begin
 
201
  result := FFilename;
 
202
end;
 
203
 
 
204
function TFontCollectionItem.GetStyle(AIndex: integer): string;
 
205
begin
 
206
  if (AIndex < 0) or (AIndex > high(FStyleList)) then
 
207
    result := ''
 
208
  else
 
209
    result := FStyleList[AIndex];
 
210
end;
 
211
 
 
212
function TFontCollectionItem.GetVersionNumber: string;
 
213
begin
 
214
  result := FVersionNumber;
 
215
end;
 
216
 
 
217
procedure TFontCollectionItem.UpdateStyles;
 
218
var
 
219
  StyleStr: string;
 
220
  idx,i: integer;
 
221
begin
 
222
  if not FUsePostscriptStyle then
 
223
    StyleStr := Information[ftiStyle]
 
224
  else
 
225
  begin
 
226
    StyleStr := Information[ftiPostscriptName];
 
227
    idx := pos('-',StyleStr);
 
228
    if idx = 0 then StyleStr := 'Regular' else
 
229
    begin
 
230
      StyleStr := copy(StyleStr,idx+1,length(StyleStr)-idx);
 
231
      for i := length(StyleStr) downto 2 do
 
232
        if (StyleStr[i] = UpCase(StyleStr[i])) and
 
233
          (StyleStr[i-1] <> UpCase(StyleStr[i-1])) then
 
234
            Insert(' ',StyleStr,i);
 
235
      if (length(StyleStr) > 2) and (copy(StyleStr, length(StyleStr)-2,3)=' MT') then
 
236
        delete(StyleStr, length(StyleStr)-2,3);
 
237
    end;
 
238
  end;
 
239
  FStyleList := StylesToArray(StyleStr);
 
240
end;
 
241
 
 
242
constructor TFontCollectionItem.Create(AFilename: string);
 
243
begin
 
244
  FFilename:= AFilename;
 
245
  FStyleList := nil;
 
246
  FFaceUsage := 0;
 
247
  FUsePostscriptStyle:= false;
 
248
end;
 
249
 
 
250
destructor TFontCollectionItem.Destroy;
 
251
begin
 
252
  if FFaceUsage <> 0 then
 
253
  begin
 
254
    TT_Close_Face(FFace);
 
255
    FFaceUsage := 0;
 
256
  end;
 
257
  inherited Destroy;
 
258
end;
 
259
 
 
260
function TFontCollectionItem.HasStyle(AStyle: string): boolean;
 
261
var i: integer;
 
262
begin
 
263
  if CompareText(AStyle,'Regular')=0 then
 
264
  begin
 
265
    result := length(FStyleList)=0;
 
266
    exit;
 
267
  end;
 
268
  for i := 0 to high(FStyleList) do
 
269
    if CompareText(FStyleList[i],AStyle)=0 then
 
270
    begin
 
271
      result := true;
 
272
      exit;
 
273
    end;
 
274
  result := false;
 
275
end;
 
276
 
 
277
function TFontCollectionItem.CreateFont: TFreeTypeFont;
 
278
begin
 
279
  result := TFreeTypeFont.Create;
 
280
  result.Name := Filename;
 
281
end;
 
282
 
 
283
function TFontCollectionItem.QueryFace: TT_Face;
 
284
var errorNum: TT_Error;
 
285
begin
 
286
  if FFaceUsage = 0 then
 
287
  begin
 
288
    errorNum := TT_Open_Face(Filename,FFace);
 
289
    if errorNum <> TT_Err_Ok then
 
290
      raise exception.Create('Cannot open font (TT_Error ' + intToStr(errorNum)+')');
 
291
  end;
 
292
  result := FFace;
 
293
  inc(FFaceUsage);
 
294
end;
 
295
 
 
296
procedure TFontCollectionItem.ReleaseFace;
 
297
begin
 
298
  if FFaceUsage > 0 then
 
299
  begin
 
300
    dec(FFaceUsage);
 
301
    if FFaceUsage = 0 then TT_Close_Face(FFace);
 
302
  end;
 
303
end;
 
304
 
 
305
constructor TFontEnumerator.Create(ANodeEnumerator: TAvgLvlTreeNodeEnumerator);
 
306
begin
 
307
  FNodeEnumerator := ANodeEnumerator;
 
308
end;
 
309
 
 
310
destructor TFontEnumerator.Destroy;
 
311
begin
 
312
  FNodeEnumerator.Free;
 
313
end;
 
314
 
 
315
function TFontEnumerator.MoveNext: boolean;
 
316
begin
 
317
  result := FNodeEnumerator.MoveNext;
 
318
end;
 
319
 
 
320
function TFontEnumerator.GetCurrent: TCustomFontCollectionItem;
 
321
begin
 
322
  result := TCustomFontCollectionItem(FNodeEnumerator.Current.Data);
 
323
end;
 
324
 
 
325
{ TFamilyEnumerator }
 
326
 
 
327
function TFamilyEnumerator.GetCurrent: TCustomFamilyCollectionItem;
 
328
begin
 
329
  result := TCustomFamilyCollectionItem(FNodeEnumerator.Current.Data);
 
330
end;
 
331
 
 
332
constructor TFamilyEnumerator.Create(ANodeEnumerator: TAvgLvlTreeNodeEnumerator );
 
333
begin
 
334
  FNodeEnumerator := ANodeEnumerator;
 
335
end;
 
336
 
 
337
destructor TFamilyEnumerator.Destroy;
 
338
begin
 
339
  FNodeEnumerator.Free;
 
340
end;
 
341
 
 
342
function TFamilyEnumerator.MoveNext: boolean;
 
343
begin
 
344
  result := FNodeEnumerator.MoveNext;
 
345
end;
 
346
 
 
347
{ TFamilyCollectionItem }
 
348
 
 
349
function TFamilyCollectionItem.GetFontByIndex(AIndex: integer): TCustomFontCollectionItem;
 
350
begin
 
351
  if AIndex = -1 then
 
352
    result := GetFont('Regular')
 
353
  else
 
354
  if (AIndex < 0) or (AIndex >= FFontCount) then
 
355
    result := nil
 
356
  else
 
357
    result := FFonts[AIndex];
 
358
end;
 
359
 
 
360
function TFamilyCollectionItem.GetFontByStyles(AStyles: string): TCustomFontCollectionItem;
 
361
var i: integer;
 
362
begin
 
363
  for i := 0 to FFontCount-1 do
 
364
    if CompareText(FFonts[i].Styles,AStyles)= 0 then
 
365
    begin
 
366
      result := FFonts[i];
 
367
      exit;
 
368
    end;
 
369
  result := nil;
 
370
end;
 
371
 
 
372
function TFamilyCollectionItem.GetFontIndexByStyles(AStyles: string): integer;
 
373
var i: integer;
 
374
begin
 
375
  for i := 0 to FFontCount-1 do
 
376
    if CompareText(FFonts[i].Styles,AStyles)= 0 then
 
377
    begin
 
378
      result := i;
 
379
      exit;
 
380
    end;
 
381
  result := -1;
 
382
end;
 
383
 
 
384
function TFamilyCollectionItem.GetStyle(AIndex: integer): string;
 
385
begin
 
386
  if (AIndex < 0) or (AIndex >= FStyleCount) then
 
387
    result := ''
 
388
  else
 
389
    result := FStyles[AIndex];
 
390
end;
 
391
 
 
392
procedure TFamilyCollectionItem.AddStyle(AName: string);
 
393
begin
 
394
  if HasStyle(AName) then exit;
 
395
  if FStyleCount = length(FStyles) then
 
396
    setlength(FStyles, length(FStyles)+4);
 
397
  FStyles[FStyleCount] := AName;
 
398
  inc(FStyleCount);
 
399
end;
 
400
 
 
401
function TFamilyCollectionItem.GetStyles: string;
 
402
var i: integer;
 
403
begin
 
404
  result := '';
 
405
  for i := 0 to StyleCount-1 do
 
406
  begin
 
407
    if i <> 0 then result += ' ';
 
408
    result += Style[i];
 
409
  end;
 
410
end;
 
411
 
 
412
function TFamilyCollectionItem.GetFamilyName: string;
 
413
begin
 
414
  result := FFamilyName;
 
415
end;
 
416
 
 
417
function TFamilyCollectionItem.GetFontCount: integer;
 
418
begin
 
419
  result := FFontCount;
 
420
end;
 
421
 
 
422
function TFamilyCollectionItem.GetStyleCount: integer;
 
423
begin
 
424
  result := FStyleCount;
 
425
end;
 
426
 
 
427
constructor TFamilyCollectionItem.Create(AName: string);
 
428
begin
 
429
  FFamilyName:= AName;
 
430
  FFontCount := 0;
 
431
  FFonts := nil;
 
432
  FStyleCount := 0;
 
433
  FStyles := nil;
 
434
  FUsePostscriptStyle:= false;
 
435
end;
 
436
 
 
437
procedure TFamilyCollectionItem.AddFont(AFontItem: TFontCollectionItem);
 
438
var i,j: integer;
 
439
    DuplicateStyle: boolean;
 
440
    StyleNumber: integer;
 
441
    TempStyles,BaseStyle: string;
 
442
begin
 
443
  if FFontCount = length(FFonts) then
 
444
    setlength(FFonts, length(FFonts)+4);
 
445
 
 
446
  FFonts[FFontCount] := AFontItem;
 
447
  inc(FFontCount);
 
448
 
 
449
  if FUsePostscriptStyle then AFontItem.UsePostscriptStyle := true;
 
450
 
 
451
  for i := 0 to AFontItem.StyleCount -1 do
 
452
    AddStyle(AFontItem.Style[i]);
 
453
 
 
454
  DuplicateStyle := false;
 
455
  for i := 0 to FFontCount-2 do
 
456
    if FFonts[i].Styles = AFontItem.Styles then
 
457
    begin
 
458
      DuplicateStyle:= true;
 
459
      break;
 
460
    end;
 
461
 
 
462
  if DuplicateStyle and not FUsePostscriptStyle then
 
463
  begin //try with postscript styles instead
 
464
    FUsePostscriptStyle:= true;
 
465
    FStyleCount := 0;
 
466
    DuplicateStyle := false;
 
467
    for i := 0 to FFontCount-1 do
 
468
    begin
 
469
      FFonts[i].UsePostscriptStyle := true;
 
470
      for j := 0 to FFonts[i].StyleCount -1 do
 
471
       AddStyle(FFonts[i].Style[j]);
 
472
 
 
473
      for j := 0 to i-1 do
 
474
        if FFonts[j].Styles = FFonts[i].Styles then
 
475
        begin
 
476
          DuplicateStyle:= true;
 
477
          break;
 
478
        end;
 
479
    end;
 
480
  end;
 
481
 
 
482
  if DuplicateStyle then
 
483
  begin
 
484
    StyleNumber := 1;
 
485
    BaseStyle := AFontItem.Styles;
 
486
    if BaseStyle = 'Regular' then BaseStyle := 'Unknown';
 
487
    repeat
 
488
      if StyleNumber = 1 then
 
489
        TempStyles := BaseStyle
 
490
      else
 
491
        TempStyles := BaseStyle+' '+IntToStr(StyleNumber);
 
492
      DuplicateStyle := false;
 
493
      for i := 0 to FFontCount-2 do
 
494
        if FFonts[i].Styles = TempStyles then
 
495
        begin
 
496
          DuplicateStyle:= true;
 
497
          break;
 
498
        end;
 
499
    until not DuplicateStyle;
 
500
    AFontItem.Information[ftiStyle] := TempStyles;
 
501
  end;
 
502
 
 
503
  if AFontItem.StyleCount = 0 then AddStyle('Regular');
 
504
end;
 
505
 
 
506
function TFamilyCollectionItem.GetFont(const AStyles: array of string;
 
507
  NeedAllStyles: boolean; NoMoreStyle: boolean): TCustomFontCollectionItem;
 
508
var idx: integer;
 
509
begin
 
510
  idx := GetFontIndex(AStyles,NeedAllStyles,NoMoreStyle);
 
511
  if idx = -1 then result := nil
 
512
  else result := Font[idx];
 
513
end;
 
514
 
 
515
function TFamilyCollectionItem.GetFontIndex(const AStyles: array of string; NeedAllStyles: boolean; NoMoreStyle: boolean): integer;
 
516
var curCount,curMissing,maxStyleCount,minMissingCount: integer;
 
517
    bestMatch: integer;
 
518
    i,j: integer;
 
519
begin
 
520
  maxStyleCount := -1;
 
521
  minMissingCount := 0;
 
522
  bestMatch := -1;
 
523
  for i := 0 to FontCount-1 do
 
524
  begin
 
525
    curCount := 0;
 
526
    curMissing := 0;
 
527
    for j := 0 to high(AStyles) do
 
528
      if Font[i].HasStyle(AStyles[j]) then
 
529
        inc(curCount);
 
530
    curMissing := Font[i].StyleCount-curCount;
 
531
    if NeedAllStyles and (curCount <> length(AStyles)) then continue;
 
532
    if NoMoreStyle and (curMissing > 0) then continue;
 
533
    if (curCount > maxStyleCount) or ((curCount = maxStyleCount) and (curMissing < minMissingCount)) then
 
534
    begin
 
535
      maxStyleCount := curCount;
 
536
      minMissingCount:= curMissing;
 
537
      bestMatch := i;
 
538
    end;
 
539
  end;
 
540
 
 
541
  for i := 0 to FontCount-1 do
 
542
  begin
 
543
    curCount := 0;
 
544
    curMissing := 0;
 
545
    for j := 0 to high(AStyles) do
 
546
      if Font[i].HasStyle(AStyles[j]) or
 
547
         ((CompareText(AStyles[j],'Italic')=0) and Font[i].HasStyle('Oblique')) or
 
548
         ((CompareText(AStyles[j],'Oblique')=0) and Font[i].HasStyle('Italic')) then
 
549
        inc(curCount);
 
550
    curMissing := Font[i].StyleCount-curCount;
 
551
    if NeedAllStyles and (curCount <> length(AStyles)) then continue;
 
552
    if NoMoreStyle and (curMissing > 0) then continue;
 
553
    if (curCount > maxStyleCount) or ((curCount = maxStyleCount) and (curMissing < minMissingCount)) then
 
554
    begin
 
555
      maxStyleCount := curCount;
 
556
      minMissingCount:= curMissing;
 
557
      bestMatch := i;
 
558
    end;
 
559
  end;
 
560
  result := bestMatch;
 
561
end;
 
562
 
 
563
function TFamilyCollectionItem.GetFontIndex(AStyle: string;
 
564
  NeedAllStyles: boolean; NoMoreStyle: boolean): integer;
 
565
begin
 
566
  result := GetFontIndexByStyles(AStyle); //exact match
 
567
  if result = -1 then
 
568
    result := GetFontIndex(StylesToArray(AStyle),NeedAllStyles,NoMoreStyle);
 
569
end;
 
570
 
 
571
function TFamilyCollectionItem.GetFont(AStyle: string; NeedAllStyles: boolean; NoMoreStyle: boolean): TCustomFontCollectionItem;
 
572
begin
 
573
  result := GetFontByStyles(AStyle); //exact match
 
574
  if result = nil then
 
575
    result := GetFont(StylesToArray(AStyle),NeedAllStyles,NoMoreStyle);
 
576
end;
 
577
 
 
578
function TFamilyCollectionItem.HasStyle(AName: string): boolean;
 
579
var i: integer;
 
580
begin
 
581
  for i := 0 to FStyleCount-1 do
 
582
    if CompareText(FStyles[i],AName)=0 then
 
583
    begin
 
584
      result := true;
 
585
      exit;
 
586
    end;
 
587
  result := false;
 
588
end;
 
589
 
 
590
{ TFontCollection }
 
591
 
 
592
function TFreeTypeFontCollection.GetFontCount: integer;
 
593
begin
 
594
  result := FFontList.Count;
 
595
end;
 
596
 
 
597
function TFreeTypeFontCollection.GetFamilyCount: integer;
 
598
begin
 
599
  result := FFamilyList.Count;
 
600
end;
 
601
 
 
602
function TFreeTypeFontCollection.FindFont(AFileName: string): TFontCollectionItem;
 
603
var Comp: integer;
 
604
    node : TAvgLvlTreeNode;
 
605
begin
 
606
  node:= FFontList.Root;
 
607
  while (node<>nil) do begin
 
608
    Comp:=CompareStr(AFileName,TFontCollectionItem(node.Data).Filename);
 
609
    if Comp=0 then break;
 
610
    if Comp<0 then begin
 
611
      node:=node.Left
 
612
    end else begin
 
613
      node:=node.Right
 
614
    end;
 
615
  end;
 
616
  if node = nil then
 
617
    result := nil
 
618
  else
 
619
    result := TFontCollectionItem(node.Data);
 
620
end;
 
621
 
 
622
function TFreeTypeFontCollection.GetFamily(AName: string
 
623
  ): TCustomFamilyCollectionItem;
 
624
begin
 
625
  if AName = '' then
 
626
  begin
 
627
    result := GetFamily('Arial');
 
628
    exit;
 
629
  end;
 
630
  result := FindFamily(AName);
 
631
  if (result = nil) and (CompareText(AName,'Arial')=0) then result := FindFamily('Helvetica');
 
632
  if (result = nil) and (CompareText(AName,'Helvetica')=0) then result := FindFamily('Arial');
 
633
  if (result = nil) and (CompareText(AName,'Courier New')=0) then result := FindFamily('Nimbus Monospace');
 
634
  if (result = nil) and (CompareText(AName,'Courier New')=0) then result := FindFamily('Courier');
 
635
  if (result = nil) and (CompareText(AName,'Nimbus Monospace')=0) then result := FindFamily('Courier New');
 
636
  if (result = nil) and (CompareText(AName,'Nimbus Monospace')=0) then result := FindFamily('Courier');
 
637
  if (result = nil) and (CompareText(AName,'Courier')=0) then result := FindFamily('Courier New');
 
638
  if (result = nil) and (CompareText(AName,'Courier')=0) then result := FindFamily('Nimbus Monospace');
 
639
  if (result = nil) and (CompareText(AName,'Times')=0) then result := FindFamily('Times New Roman');
 
640
  if (result = nil) and (CompareText(AName,'Times')=0) then result := FindFamily('CG Times');
 
641
  if (result = nil) and (CompareText(AName,'Times New Roman')=0) then result := FindFamily('Times');
 
642
  if (result = nil) and (CompareText(AName,'Times New Roman')=0) then result := FindFamily('CG Times');
 
643
  if (result = nil) and (CompareText(AName,'CG Times')=0) then result := FindFamily('Times');
 
644
  if (result = nil) and (CompareText(AName,'CG Times')=0) then result := FindFamily('Times New Roman');
 
645
end;
 
646
 
 
647
function TFreeTypeFontCollection.AddFamily(AName: string): TFamilyCollectionItem;
 
648
var
 
649
  f: TFamilyCollectionItem;
 
650
begin
 
651
  f := FindFamily(AName);
 
652
  if f = nil then
 
653
  begin
 
654
    result := TFamilyCollectionItem.Create(AName);
 
655
    FFamilyList.Add(result);
 
656
  end else
 
657
    result := f;
 
658
end;
 
659
 
 
660
function TFreeTypeFontCollection.FindFamily(AName: string): TFamilyCollectionItem;
 
661
var Comp: integer;
 
662
    node : TAvgLvlTreeNode;
 
663
begin
 
664
  node:= FFamilyList.Root;
 
665
  while (node<>nil) do begin
 
666
    Comp:=CompareText(AName,TFamilyCollectionItem(node.Data).FamilyName);
 
667
    if Comp=0 then break;
 
668
    if Comp<0 then begin
 
669
      node:=node.Left
 
670
    end else begin
 
671
      node:=node.Right
 
672
    end;
 
673
  end;
 
674
  if node = nil then
 
675
    result := nil
 
676
  else
 
677
    result := TFamilyCollectionItem(node.Data);
 
678
end;
 
679
 
 
680
function TFreeTypeFontCollection.CompareFontFileName(Tree: TAvgLvlTree; Data1,
 
681
  Data2: Pointer): integer;
 
682
begin
 
683
  result := CompareStr(TFontCollectionItem(Data1).Filename,TFontCollectionItem(Data2).Filename);
 
684
end;
 
685
 
 
686
function TFreeTypeFontCollection.CompareFamilyName(Tree: TAvgLvlTree; Data1,
 
687
  Data2: Pointer): integer;
 
688
begin
 
689
  result := CompareText(TFamilyCollectionItem(Data1).FamilyName,TFamilyCollectionItem(Data2).FamilyName);
 
690
end;
 
691
 
 
692
function TFreeTypeFontCollection.GetFont(AFileName: string
 
693
  ): TCustomFontCollectionItem;
 
694
begin
 
695
  result := FindFont(AFilename);
 
696
end;
 
697
 
 
698
constructor TFreeTypeFontCollection.Create;
 
699
begin
 
700
  FUpdateCount := 0;
 
701
  FTempFont := nil;
 
702
  FFontList := TAvgLvlTree.CreateObjectCompare(@CompareFontFileName);
 
703
  FFamilyList := TAvgLvlTree.CreateObjectCompare(@CompareFamilyName);
 
704
end;
 
705
 
 
706
procedure TFreeTypeFontCollection.Clear;
 
707
begin
 
708
  FFamilyList.FreeAndClear;
 
709
  FFontList.FreeAndClear;
 
710
end;
 
711
 
 
712
procedure TFreeTypeFontCollection.BeginUpdate;
 
713
begin
 
714
  if (FUpdateCount = 0) and (FTempFont = nil) then
 
715
    FTempFont := TFreeTypeFont.Create;
 
716
  inc(FUpdateCount);
 
717
end;
 
718
 
 
719
procedure TFreeTypeFontCollection.AddFolder(AFolder: string);
 
720
var sr: TSearchRec;
 
721
    files: TStringList;
 
722
    i: integer;
 
723
begin
 
724
  if (length(AFolder) <> 0) and (AFolder[length(AFolder)] <> PathDelim) then
 
725
    AFolder += PathDelim;
 
726
 
 
727
  files := TStringList.Create;
 
728
  BeginUpdate;
 
729
  try
 
730
    if FindFirst(AFolder+'*.ttf',faAnyfile,sr) = 0 then
 
731
    repeat
 
732
      if sr.Attr and (faDirectory+faVolumeId) = 0 then
 
733
        files.Add(AFolder+sr.Name);
 
734
    until FindNext(sr) <> 0;
 
735
 
 
736
    files.Sort;
 
737
    for i := 0 to files.Count-1 do
 
738
      AddFile(files[i]);
 
739
  finally
 
740
    EndUpdate;
 
741
  end;
 
742
  files.Free;
 
743
end;
 
744
 
 
745
function TFreeTypeFontCollection.AddFile(AFilename: string): boolean;
 
746
var info: TFreeTypeInformation;
 
747
    fName: string;
 
748
    item: TFontCollectionItem;
 
749
    f: TFamilyCollectionItem;
 
750
begin
 
751
  result := false;
 
752
  BeginUpdate;
 
753
  try
 
754
    FTempFont.Name := AFilename;
 
755
    fName := FTempFont.Family;
 
756
    if fName <> '' then
 
757
    begin
 
758
      f := AddFamily(fName);
 
759
      item := TFontCollectionItem.Create(AFilename);
 
760
      FFontList.Add(item);
 
761
      with item do
 
762
      begin
 
763
        VersionNumber:= FTempFont.VersionNumber;
 
764
        for info := low(TFreeTypeInformation) to high(TFreeTypeInformation) do
 
765
          Information[info] := FTempFont.Information[info];
 
766
      end;
 
767
      f.AddFont(item);
 
768
      result := true;
 
769
    end;
 
770
  finally
 
771
    EndUpdate;
 
772
  end;
 
773
end;
 
774
 
 
775
procedure TFreeTypeFontCollection.EndUpdate;
 
776
begin
 
777
  if FUpdateCount > 0 then
 
778
  begin
 
779
    dec(FUpdateCount);
 
780
    if FUpdateCount = 0 then FreeAndNil(FTempFont);
 
781
  end;
 
782
end;
 
783
 
 
784
destructor TFreeTypeFontCollection.Destroy;
 
785
begin
 
786
  Clear;
 
787
  FFontList.Free;
 
788
  FFamilyList.Free;
 
789
  FTempFont.Free;
 
790
  inherited Destroy;
 
791
end;
 
792
 
 
793
function TFreeTypeFontCollection.FontFileEnumerator: IFreeTypeFontEnumerator;
 
794
begin
 
795
  result := TFontEnumerator.Create(FFontList.GetEnumerator);
 
796
end;
 
797
 
 
798
function TFreeTypeFontCollection.FamilyEnumerator: IFreeTypeFamilyEnumerator;
 
799
begin
 
800
  result := TFamilyEnumerator.Create(FFamilyList.GetEnumerator);
 
801
end;
 
802
 
 
803
var
 
804
  InternalDefaultFontCollection : TFreeTypeFontCollection;
 
805
 
 
806
initialization
 
807
 
 
808
  InternalDefaultFontCollection := TFreeTypeFontCollection.Create;
 
809
  FontCollection := InternalDefaultFontCollection;
 
810
 
 
811
finalization
 
812
 
 
813
  InternalDefaultFontCollection.Free;
 
814
 
 
815
end.
 
816