paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-21 22:59:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

fixed brush handle cache size

Browse Source 
git-svn-id: trunk@5771 -
This commit is contained in:
mattias 2004-08-11 22:05:07 +00:00
parent 5d3ed6859c
commit 4340c26a6e
6 changed files with 169 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
lcl/graphics.pp
View File

@ -42,6 +42,7 @@ uses
{$IFNDEF DisableFPImage}
FPImage, FPReadPNG, FPWritePNG, FPReadBMP, FPWriteBMP, IntfGraphics,
{$ENDIF}
AvgLvlTree,
LCLStrConsts, vclGlobals, LCLType, LCLProc, LMessages, LCLIntf, LResources,
LCLResCache, GraphType, GraphMath;
@ -385,6 +386,31 @@ type
end;
{ TFontHandleCacheDescriptor }
TFontHandleCacheDescriptor = class(TResourceCacheDescriptor)
public
LogFont: TLogFont;
LongFontName: string;
end;
{ TFontHandleCache }
TFontHandleCache = class(TResourceCache)
protected
procedure RemoveItem(Item: TResourceCacheItem); override;
public
constructor Create;
function CompareDescriptors(Tree: TAvgLvlTree; Desc1, Desc2: Pointer): integer; override;
function FindFont(TheFont: HFONT): TResourceCacheItem;
function FindFontDesc(const LogFont: TLogFont;
const LongFontName: string): TFontHandleCacheDescriptor;
function Add(TheFont: HFONT; const LogFont: TLogFont;
const LongFontName: string): TFontHandleCacheDescriptor;
end;
{ TFont }
TFont = class(TGraphicsObject)
@ -395,6 +421,7 @@ type
FFontName: string;
FUpdateCount: integer;
FChanged: boolean;
FFontHandleCached: boolean;
procedure FreeHandle;
procedure GetData(var FontData: TFontData);
function IsNameStored: boolean;
@ -511,10 +538,10 @@ type
procedure FreeHandle;
protected
function GetHandle: HBRUSH;
Procedure SetBitmap(Value: TBitmap);
Procedure SetColor(Value: TColor);
procedure SetBitmap(Value: TBitmap);
procedure SetColor(Value: TColor);
procedure SetHandle(const Value: HBRUSH);
Procedure SetStyle(value: TBrushStyle);
Procedure SetStyle(Value: TBrushStyle);
public
procedure Assign(Source: TPersistent); override;
constructor Create;
@ -1225,6 +1252,7 @@ var
{ Stores information about the current screen }
ScreenInfo: TLMScreenInit;
FontResourceCache: TFontHandleCache;
PenResourceCache: TPenHandleCache;
BrushResourceCache: TBrushHandleCache;
@ -1687,6 +1715,7 @@ end;
procedure InterfaceFinal;
begin
//debugln('Graphics.InterfaceFinal');
FreeAndNil(FontResourceCache);
FreeAndNil(PenResourceCache);
FreeAndNil(BrushResourceCache);
end;
@ -1696,6 +1725,7 @@ initialization
PicFileFormats:=nil;
OnLoadGraphicFromClipboardFormat:=nil;
OnSaveGraphicToClipboardFormat:=nil;
FontResourceCache:=TFontHandleCache.Create;
PenResourceCache:=TPenHandleCache.Create;
BrushResourceCache:=TBrushHandleCache.Create;
RegisterIntegerConsts(TypeInfo(TColor), @IdentToColor, @ColorToIdent);
@ -1715,6 +1745,9 @@ end.
{ =============================================================================
$Log$
Revision 1.142 2004/08/11 22:05:07 mattias
fixed brush handle cache size
Revision 1.141 2004/08/11 21:10:30 mattias
implemented TBrushHandleCache

5
lcl/include/brush.inc
View File

@ -28,7 +28,7 @@ end;
constructor TBrushHandleCache.Create;
begin
inherited Create(SizeOf(TBrushData));
inherited Create(SizeOf(TLogBrush));
end;
@ -227,6 +227,9 @@ end;
{ =============================================================================
$Log$
Revision 1.10 2004/08/11 22:05:07 mattias
fixed brush handle cache size
Revision 1.9 2004/08/11 21:10:30 mattias
implemented TBrushHandleCache

124
lcl/include/font.inc
View File

@ -17,6 +17,109 @@
*****************************************************************************
}
{ TFontHandleCache }
type
TLogFontAndName = record
LogFont: TLogFont;
LongFontName: string;
end;
PLogFontAndName = ^TLogFontAndName;
function CompareLogFontAndNameWithResDesc(Key: PLogFontAndName;
Desc: TFontHandleCacheDescriptor): integer;
begin
Result:=CompareStr(Key^.LongFontName,Desc.LongFontName);
//writeln('CompareLogFontAndNameWithResDesc A ',Key^.LongFontName,' ',Desc.LongFontName,' ',HexStr(Cardinal(Desc),8),' Result=',Result);
if Result=0 then
Result:=CompareMemRange(@Key^.LogFont,@Desc.LogFont,SizeOf(Desc.LogFont));
//writeln('CompareLogFontAndNameWithResDesc END Result=',Result);
end;
procedure TFontHandleCache.RemoveItem(Item: TResourceCacheItem);
begin
DeleteObject(Item.Handle);
inherited RemoveItem(Item);
end;
constructor TFontHandleCache.Create;
begin
inherited Create;
FResourceCacheDescriptorClass:=TFontHandleCacheDescriptor;
end;
function TFontHandleCache.CompareDescriptors(Tree: TAvgLvlTree; Desc1,
Desc2: Pointer): integer;
var
Descriptor1: TFontHandleCacheDescriptor;
Descriptor2: TFontHandleCacheDescriptor;
begin
Descriptor1:=TFontHandleCacheDescriptor(Desc1);
Descriptor2:=TFontHandleCacheDescriptor(Desc2);
Result:=CompareStr(Descriptor1.LongFontName,Descriptor2.LongFontName);
if Result<>0 then exit;
Result:=CompareMemRange(@Descriptor1.LogFont,@Descriptor2.LogFont,
SizeOf(Descriptor1.LogFont));
end;
function TFontHandleCache.FindFont(TheFont: HFONT): TResourceCacheItem;
var
ANode: TAvgLvlTreeNode;
begin
ANode:=FItems.FindKey(@THandle(TheFont),@ComparePHandleWithResourceCacheItem);
if ANode<>nil then
Result:=TResourceCacheItem(ANode.Data)
else
Result:=nil;
end;
function TFontHandleCache.FindFontDesc(const LogFont: TLogFont;
const LongFontName: string): TFontHandleCacheDescriptor;
var
LogFontAndName: TLogFontAndName;
ANode: TAvgLvlTreeNode;
begin
LogFontAndName.LogFont:=LogFont;
LogFontAndName.LongFontName:=LongFontName;
ANode:=FDescriptors.Findkey(@LogFontAndName,
@CompareLogFontAndNameWithResDesc);
if ANode<>nil then
Result:=TFontHandleCacheDescriptor(ANode.Data)
else
Result:=nil;
end;
function TFontHandleCache.Add(TheFont: HFONT; const LogFont: TLogFont;
const LongFontName: string): TFontHandleCacheDescriptor;
var
Item: TResourceCacheItem;
begin
if FindFontDesc(LogFont,LongFontName)<>nil then
RaiseGDBException('TFontHandleCache.Add font desc added twice');
// find cache item with TheFont
Item:=FindFont(TheFont);
if Item=nil then begin
// create new item
Item:=TResourceCacheItem.Create(Self,TheFont);
FItems.Add(Item);
end;
// create descriptor
Result:=TFontHandleCacheDescriptor.Create(Self,Item);
Result.LongFontName:=LongFontName;
Result.LogFont:=LogFont;
FDescriptors.Add(Result);
if FindFontDesc(LogFont,LongFontName)=nil then begin
debugln('TFontHandleCache.Add Added: ',HexStr(Cardinal(Result),8),' LongFontName=',Result.LongFontName);
RaiseGDBException('');
end;
end;
{ TFont }
procedure GetCharsetValues(Proc: TGetStrProc);
var
I: Integer;
@ -693,6 +796,7 @@ const
LF_WEIGHT: array[Boolean] of Integer = (FW_NORMAL, FW_BOLD);
var
ALogFont: TLogFont;
CachedFont: TFontHandleCacheDescriptor;
procedure SetLogFontName(const NewName: string);
var l: integer;
@ -735,8 +839,15 @@ begin
end;
// ask the interface for the nearest font
// TODO: cache the result for other fonts
FFontData.Handle := CreateFontIndirectEx(ALogFont,Name);
CachedFont:=FontResourceCache.FindFontDesc(ALogFont,Name);
if CachedFont<>nil then begin
CachedFont.Item.IncreaseRefCount;
FFontData.Handle := CachedFont.Item.Handle;
end else begin
FFontData.Handle := CreateFontIndirectEx(ALogFont,Name);
FontResourceCache.Add(FFontData.Handle,ALogFont,Name);
end;
FFontHandleCached:=true;
end;
Result := FFontData.Handle;
@ -753,7 +864,11 @@ procedure TFont.FreeHandle;
begin
if FFontData.Handle <> 0
then begin
DeleteObject(FFontData.Handle);
if FFontHandleCached then begin
FontResourceCache.FindFont(FFontData.Handle).DecreaseRefCount;
FFontHandleCached:=false;
end else
DeleteObject(FFontData.Handle);
FFontData.Handle := 0;
end;
end;
@ -834,6 +949,9 @@ end;
{ =============================================================================
$Log$
Revision 1.15 2004/08/11 22:05:07 mattias
fixed brush handle cache size
Revision 1.14 2004/08/10 17:34:13 mattias
implemented font cache for gtk, which accelerates switching fonts

5
lcl/include/pen.inc
View File

@ -28,7 +28,7 @@ end;
constructor TPenHandleCache.Create;
begin
inherited Create(SizeOf(TPenData));
inherited Create(SizeOf(TLogPen));
end;
{ TPen }
@ -233,6 +233,9 @@ end;
{ =============================================================================
$Log$
Revision 1.11 2004/08/11 22:05:07 mattias
fixed brush handle cache size
Revision 1.10 2004/08/11 20:57:09 mattias
moved intfstrconsts.pp to lclstrconsts.pas, implemented TPenHandleCache

10
lcl/interfaces/gtk/gtkfontcache.pas
View File

@ -58,7 +58,6 @@ type
procedure RemoveItem(Item: TResourceCacheItem); override;
public
constructor Create;
destructor Destroy; override;
function CompareItems(Tree: TAvgLvlTree; Item1, Item2: Pointer): integer; override;
function CompareDescriptors(Tree: TAvgLvlTree; Desc1, Desc2: Pointer): integer; override;
function FindGDKFont(TheGdkFont: PGDKFont): TGdkFontCacheItem;
@ -142,11 +141,6 @@ begin
FResourceCacheDescriptorClass:=TGdkFontCacheDescriptor;
end;
destructor TGdkFontCache.Destroy;
begin
inherited Destroy;
end;
function TGdkFontCache.CompareItems(Tree: TAvgLvlTree; Item1, Item2: Pointer
): integer;
begin
@ -212,9 +206,7 @@ begin
gdk_font_ref(TheGdkFont);
FItems.Add(Item);
end;
if FindGDKFont(TheGdkFont)=nil then
RaiseGDBException('');
// create descriptor
Result:=TGdkFontCacheDescriptor.Create(Self,Item);
Result.LongFontName:=LongFontName;

6
lcl/lclrescache.pas
View File

@ -182,7 +182,7 @@ begin
inc(FReferenceCount);
if FReferenceCount=1 then
Cache.ItemUsed(Self);
if (FReferenceCount=100) or (FReferenceCount=1000) then
if (FReferenceCount=1000) or (FReferenceCount=10000) then
WarnReferenceHigh;
end;
@ -218,7 +218,7 @@ end;
procedure TResourceCacheItem.WarnReferenceHigh;
begin
debugln('WARNING: TResourceCacheItem.IncreaseRefCount ',dbgs(FReferenceCount));
debugln('WARNING: TResourceCacheItem.IncreaseRefCount ',dbgs(FReferenceCount),' ',Cache.ClassName);
end;
{ TResourceCacheDescriptor }
@ -433,8 +433,8 @@ end;
destructor TBlockResourceCacheDescriptor.Destroy;
begin
ReAllocMem(Data,0);
inherited Destroy;
ReAllocMem(Data,0);
end;
end.