mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-16 10:39:30 +02:00
moved intfstrconsts.pp to lclstrconsts.pas, implemented TPenHandleCache
git-svn-id: trunk@5769 -
This commit is contained in:
mattias
parent
b884614dd5
commit
581bef95fc
2
.gitattributes
vendored
2
.gitattributes
vendored
@ -1366,7 +1366,6 @@ lcl/interfaces/win32/win32wsstdctrls.pp svneol=native#text/pascal
|
|||||||
lcl/interfaces/win32/win32wstoolwin.pp svneol=native#text/pascal
|
lcl/interfaces/win32/win32wstoolwin.pp svneol=native#text/pascal
|
||||||
lcl/interfaces/win32/winext.pas svneol=native#text/pascal
|
lcl/interfaces/win32/winext.pas svneol=native#text/pascal
|
||||||
lcl/intfgraphics.pas svneol=native#text/pascal
|
lcl/intfgraphics.pas svneol=native#text/pascal
|
||||||
lcl/intfstrconsts.pas svneol=native#text/pascal
|
|
||||||
lcl/languages/lcl.ca.po svneol=native#text/plain
|
lcl/languages/lcl.ca.po svneol=native#text/plain
|
||||||
lcl/languages/lcl.de.po svneol=native#text/plain
|
lcl/languages/lcl.de.po svneol=native#text/plain
|
||||||
lcl/languages/lcl.es.po svneol=native#text/plain
|
lcl/languages/lcl.es.po svneol=native#text/plain
|
||||||
@ -1387,6 +1386,7 @@ lcl/lclicons.lrs svneol=native#text/pascal
|
|||||||
lcl/lclintf.pas svneol=native#text/pascal
|
lcl/lclintf.pas svneol=native#text/pascal
|
||||||
lcl/lclmemmanager.pas svneol=native#text/pascal
|
lcl/lclmemmanager.pas svneol=native#text/pascal
|
||||||
lcl/lclproc.pas svneol=native#text/pascal
|
lcl/lclproc.pas svneol=native#text/pascal
|
||||||
|
lcl/lclrescache.pas svneol=native#text/pascal
|
||||||
lcl/lclstrconsts.pas svneol=native#text/pascal
|
lcl/lclstrconsts.pas svneol=native#text/pascal
|
||||||
lcl/lcltype.pp svneol=native#text/pascal
|
lcl/lcltype.pp svneol=native#text/pascal
|
||||||
lcl/lmessages.pp svneol=native#text/pascal
|
lcl/lmessages.pp svneol=native#text/pascal
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
#
|
#
|
||||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/07/25]
|
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/08/08]
|
||||||
#
|
#
|
||||||
default: all
|
default: all
|
||||||
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom morphos
|
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom morphos
|
||||||
@ -263,7 +263,7 @@ endif
|
|||||||
endif
|
endif
|
||||||
override TARGET_DIRS+=interfaces
|
override TARGET_DIRS+=interfaces
|
||||||
override TARGET_UNITS+=alllclunits
|
override TARGET_UNITS+=alllclunits
|
||||||
override TARGET_IMPLICITUNITS+=actnlist arrow avglvltree buttons calendar checklst clipbrd clistbox comctrls commctrl controls dbctrls dbgrids dialogs dynamicarray dynhasharray editbtn extctrls extdlgs extendedstrings extgraphics filectrl forms fpcadds graphics graphmath graphtype grids imglist inipropstorage interfacebase lazlinkedlist lclintf lclmemmanager lclproc lclstrconsts lcltype lmessages lresources maskedit menus pairsplitter postscriptprinter printers propertystorage spin stdactns stdctrls stringhashlist textstrings toolwin utrace xmlpropstorage vclglobals
|
override TARGET_IMPLICITUNITS+=actnlist arrow avglvltree buttons calendar checklst clipbrd clistbox comctrls commctrl controls dbactns dbctrls dbgrids dialogs dynamicarray dynhasharray editbtn extctrls extdlgs extendedstrings extgraphics filectrl forms fpcadds graphics graphmath graphtype grids imglist inipropstorage interfacebase lazlinkedlist lclintf lclmemmanager lclproc lclreschache lclstrconsts lcltype lmessages lresources maskedit menus pairsplitter postscriptprinter printers propertystorage spin stdactns stdctrls stringhashlist textstrings toolwin utrace xmlpropstorage vclglobals
|
||||||
override TARGET_RSTS+=lclstrconsts
|
override TARGET_RSTS+=lclstrconsts
|
||||||
override CLEAN_FILES+=$(wildcard $(COMPILER_UNITTARGETDIR)/*$(OEXT)) $(wildcard $(COMPILER_UNITTARGETDIR)/*$(PPUEXT)) $(wildcard $(COMPILER_UNITTARGETDIR)/*$(RSTEXT)) $(wildcard ./units/*$(OEXT)) $(wildcard ./units/*$(PPUEXT)) $(wildcard ./units/*$(RSTEXT)) $(wildcard *$(OEXT)) $(wildcard *$(PPUEXT)) $(wildcard *$(RSTEXT))
|
override CLEAN_FILES+=$(wildcard $(COMPILER_UNITTARGETDIR)/*$(OEXT)) $(wildcard $(COMPILER_UNITTARGETDIR)/*$(PPUEXT)) $(wildcard $(COMPILER_UNITTARGETDIR)/*$(RSTEXT)) $(wildcard ./units/*$(OEXT)) $(wildcard ./units/*$(PPUEXT)) $(wildcard ./units/*$(RSTEXT)) $(wildcard *$(OEXT)) $(wildcard *$(PPUEXT)) $(wildcard *$(RSTEXT))
|
||||||
override COMPILER_OPTIONS+=-gl
|
override COMPILER_OPTIONS+=-gl
|
||||||
|
|||||||
@ -48,6 +48,7 @@ implicitunits= \
|
|||||||
lclintf \
|
lclintf \
|
||||||
lclmemmanager \
|
lclmemmanager \
|
||||||
lclproc \
|
lclproc \
|
||||||
|
lclreschache \
|
||||||
lclstrconsts \
|
lclstrconsts \
|
||||||
lcltype \
|
lcltype \
|
||||||
lmessages \
|
lmessages \
|
||||||
|
|||||||
@ -35,7 +35,7 @@ uses
|
|||||||
FPCAdds, LazLinkedList, DynHashArray, LCLMemManager, AvgLvlTree,
|
FPCAdds, LazLinkedList, DynHashArray, LCLMemManager, AvgLvlTree,
|
||||||
StringHashList, ExtendedStrings, DynamicArray, UTrace, TextStrings,
|
StringHashList, ExtendedStrings, DynamicArray, UTrace, TextStrings,
|
||||||
// base types and base functions
|
// base types and base functions
|
||||||
LCLProc, LCLType, GraphMath, VCLGlobals, FileCtrl, LMessages,
|
LCLProc, LCLType, LCLResCache, GraphMath, VCLGlobals, FileCtrl, LMessages,
|
||||||
// the interface base
|
// the interface base
|
||||||
InterfaceBase,
|
InterfaceBase,
|
||||||
{$IFNDEF DisableFPImage}IntfGraphics,{$ENDIF}
|
{$IFNDEF DisableFPImage}IntfGraphics,{$ENDIF}
|
||||||
@ -63,6 +63,9 @@ end.
|
|||||||
{ =============================================================================
|
{ =============================================================================
|
||||||
|
|
||||||
$Log$
|
$Log$
|
||||||
|
Revision 1.18 2004/08/11 20:57:09 mattias
|
||||||
|
moved intfstrconsts.pp to lclstrconsts.pas, implemented TPenHandleCache
|
||||||
|
|
||||||
Revision 1.17 2004/08/03 10:01:22 mattias
|
Revision 1.17 2004/08/03 10:01:22 mattias
|
||||||
added DBActns from Michael VC
|
added DBActns from Michael VC
|
||||||
|
|
||||||
|
|||||||
@ -1330,6 +1330,7 @@ begin
|
|||||||
Application.Free;
|
Application.Free;
|
||||||
Application:=nil;
|
Application:=nil;
|
||||||
FreeAllClipBoards;
|
FreeAllClipBoards;
|
||||||
|
CallInterfaceFinalizationHandlers;
|
||||||
InterfaceObject.Free;
|
InterfaceObject.Free;
|
||||||
InterfaceObject:=nil;
|
InterfaceObject:=nil;
|
||||||
end;
|
end;
|
||||||
|
|||||||
@ -42,11 +42,8 @@ uses
|
|||||||
{$IFNDEF DisableFPImage}
|
{$IFNDEF DisableFPImage}
|
||||||
FPImage, FPReadPNG, FPWritePNG, FPReadBMP, FPWriteBMP, IntfGraphics,
|
FPImage, FPReadPNG, FPWritePNG, FPReadBMP, FPWriteBMP, IntfGraphics,
|
||||||
{$ENDIF}
|
{$ENDIF}
|
||||||
{$IFDEF UseSimpleJpeg}
|
LCLStrConsts, vclGlobals, LCLType, LCLProc, LMessages, LCLIntf, LResources,
|
||||||
FPReadJpeg,FPWriteJpeg,
|
LCLResCache, GraphType, GraphMath;
|
||||||
{$ENDIF}
|
|
||||||
LCLStrConsts, vclGlobals, LMessages, LCLType, LCLProc, LCLIntf, LResources,
|
|
||||||
GraphType, GraphMath;
|
|
||||||
|
|
||||||
type
|
type
|
||||||
PColor = ^TColor;
|
PColor = ^TColor;
|
||||||
@ -106,13 +103,6 @@ type
|
|||||||
pmNotMask, pmXor, pmNotXor
|
pmNotMask, pmXor, pmNotXor
|
||||||
);
|
);
|
||||||
|
|
||||||
TPenData = record
|
|
||||||
Handle: HPen;
|
|
||||||
Color: TColor;
|
|
||||||
Width: Integer;
|
|
||||||
Style: TPenStyle;
|
|
||||||
end;
|
|
||||||
|
|
||||||
TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical, bsFDiagonal,
|
TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical, bsFDiagonal,
|
||||||
bsBDiagonal, bsCross, bsDiagCross);
|
bsBDiagonal, bsCross, bsDiagCross);
|
||||||
|
|
||||||
@ -371,9 +361,9 @@ type
|
|||||||
TIcon = class; // ico
|
TIcon = class; // ico
|
||||||
TPortableNetworkGraphic = class; // png
|
TPortableNetworkGraphic = class; // png
|
||||||
{$IFDEF UseSimpleJpeg}
|
{$IFDEF UseSimpleJpeg}
|
||||||
|
{$error will be added to the LCL, when fpc 2.0 is released. Use the jpeg package in the components/jpeg directory instead. }
|
||||||
// MG: will be added to the LCL, when fpc 2.0 is released
|
// MG: will be added to the LCL, when fpc 2.0 is released
|
||||||
// but then with the advanced features of the existing package
|
// but then with the advanced features of the existing package
|
||||||
TJpegImage = class; // jpg
|
|
||||||
{$ENDIF}
|
{$ENDIF}
|
||||||
|
|
||||||
|
|
||||||
@ -458,10 +448,25 @@ type
|
|||||||
|
|
||||||
{ TPen }
|
{ TPen }
|
||||||
|
|
||||||
|
TPenData = record
|
||||||
|
Handle: HPen;
|
||||||
|
Color: TColor;
|
||||||
|
Width: Integer;
|
||||||
|
Style: TPenStyle;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TPenHandleCache = class(TBlockResourceCache)
|
||||||
|
protected
|
||||||
|
procedure RemoveItem(Item: TResourceCacheItem); override;
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
end;
|
||||||
|
|
||||||
TPen = class(TGraphicsObject)
|
TPen = class(TGraphicsObject)
|
||||||
private
|
private
|
||||||
FPenData: TPenData;
|
FPenData: TPenData;
|
||||||
FMode: TPenMode;
|
FMode: TPenMode;
|
||||||
|
FPenHandleCached: boolean;
|
||||||
procedure FreeHandle;
|
procedure FreeHandle;
|
||||||
protected
|
protected
|
||||||
function GetHandle: HPEN;
|
function GetHandle: HPEN;
|
||||||
@ -469,7 +474,7 @@ type
|
|||||||
procedure SetColor(Value: TColor);
|
procedure SetColor(Value: TColor);
|
||||||
procedure SetMode(Value: TPenMode);
|
procedure SetMode(Value: TPenMode);
|
||||||
procedure SetStyle(Value: TPenStyle);
|
procedure SetStyle(Value: TPenStyle);
|
||||||
procedure Setwidth(value: Integer);
|
procedure SetWidth(value: Integer);
|
||||||
public
|
public
|
||||||
constructor Create;
|
constructor Create;
|
||||||
destructor Destroy; override;
|
destructor Destroy; override;
|
||||||
@ -1115,18 +1120,6 @@ type
|
|||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
||||||
{$IFDEF UseSimpleJpeg}
|
|
||||||
{ TJpegImage }
|
|
||||||
|
|
||||||
TJpegImage = class(TFPImageBitmap)
|
|
||||||
public
|
|
||||||
class function GetFileExtensions: string; override;
|
|
||||||
class function GetDefaultFPReader: TFPCustomImageReaderClass; override;
|
|
||||||
class function GetDefaultFPWriter: TFPCustomImageWriterClass; override;
|
|
||||||
end;
|
|
||||||
{$ENDIF}
|
|
||||||
|
|
||||||
|
|
||||||
{ TIcon }
|
{ TIcon }
|
||||||
{
|
{
|
||||||
TIcon reads and writes .ICO file format.
|
TIcon reads and writes .ICO file format.
|
||||||
@ -1224,6 +1217,8 @@ var
|
|||||||
{ Stores information about the current screen }
|
{ Stores information about the current screen }
|
||||||
ScreenInfo: TLMScreenInit;
|
ScreenInfo: TLMScreenInit;
|
||||||
|
|
||||||
|
PenResourceCache: TPenHandleCache;
|
||||||
|
|
||||||
const
|
const
|
||||||
FontCharsets: array[0..18] of TIdentMapEntry = (
|
FontCharsets: array[0..18] of TIdentMapEntry = (
|
||||||
(Value: ANSI_CHARSET; Name: 'ANSI_CHARSET'),
|
(Value: ANSI_CHARSET; Name: 'ANSI_CHARSET'),
|
||||||
@ -1680,13 +1675,21 @@ begin
|
|||||||
end;
|
end;
|
||||||
{$ENDIF}
|
{$ENDIF}
|
||||||
|
|
||||||
|
procedure InterfaceFinal;
|
||||||
|
begin
|
||||||
|
//debugln('Graphics.InterfaceFinal');
|
||||||
|
FreeAndNil(PenResourceCache);
|
||||||
|
end;
|
||||||
|
|
||||||
initialization
|
initialization
|
||||||
PicClipboardFormats:=nil;
|
PicClipboardFormats:=nil;
|
||||||
PicFileFormats:=nil;
|
PicFileFormats:=nil;
|
||||||
OnLoadGraphicFromClipboardFormat:=nil;
|
OnLoadGraphicFromClipboardFormat:=nil;
|
||||||
OnSaveGraphicToClipboardFormat:=nil;
|
OnSaveGraphicToClipboardFormat:=nil;
|
||||||
|
PenResourceCache:=TPenHandleCache.Create;
|
||||||
RegisterIntegerConsts(TypeInfo(TColor), @IdentToColor, @ColorToIdent);
|
RegisterIntegerConsts(TypeInfo(TColor), @IdentToColor, @ColorToIdent);
|
||||||
RegisterIntegerConsts(TypeInfo(TFontCharset), @IdentToCharset, @CharsetToIdent);
|
RegisterIntegerConsts(TypeInfo(TFontCharset), @IdentToCharset, @CharsetToIdent);
|
||||||
|
RegisterInterfaceFinalizationHandler(@InterfaceFinal);
|
||||||
|
|
||||||
finalization
|
finalization
|
||||||
GraphicsFinalized:=true;
|
GraphicsFinalized:=true;
|
||||||
@ -1701,6 +1704,9 @@ end.
|
|||||||
{ =============================================================================
|
{ =============================================================================
|
||||||
|
|
||||||
$Log$
|
$Log$
|
||||||
|
Revision 1.140 2004/08/11 20:57:09 mattias
|
||||||
|
moved intfstrconsts.pp to lclstrconsts.pas, implemented TPenHandleCache
|
||||||
|
|
||||||
Revision 1.139 2004/05/25 21:50:32 mattias
|
Revision 1.139 2004/05/25 21:50:32 mattias
|
||||||
TCustomNotebook now allows pageclass descendents
|
TCustomNotebook now allows pageclass descendents
|
||||||
|
|
||||||
|
|||||||
@ -149,6 +149,7 @@ var
|
|||||||
begin
|
begin
|
||||||
if FBrushData.Handle = 0
|
if FBrushData.Handle = 0
|
||||||
then begin
|
then begin
|
||||||
|
FillChar(LogBrush,SizeOf(LogBrush),0);
|
||||||
with LogBrush do
|
with LogBrush do
|
||||||
begin
|
begin
|
||||||
if FBrushData.Bitmap <> nil
|
if FBrushData.Bitmap <> nil
|
||||||
@ -195,6 +196,9 @@ end;
|
|||||||
{ =============================================================================
|
{ =============================================================================
|
||||||
|
|
||||||
$Log$
|
$Log$
|
||||||
|
Revision 1.8 2004/08/11 20:57:09 mattias
|
||||||
|
moved intfstrconsts.pp to lclstrconsts.pas, implemented TPenHandleCache
|
||||||
|
|
||||||
Revision 1.7 2004/04/10 17:58:56 mattias
|
Revision 1.7 2004/04/10 17:58:56 mattias
|
||||||
implemented mainunit hints for include files
|
implemented mainunit hints for include files
|
||||||
|
|
||||||
|
|||||||
@ -16,6 +16,23 @@
|
|||||||
* *
|
* *
|
||||||
*****************************************************************************
|
*****************************************************************************
|
||||||
}
|
}
|
||||||
|
|
||||||
|
{ TPenHandleCache }
|
||||||
|
|
||||||
|
procedure TPenHandleCache.RemoveItem(Item: TResourceCacheItem);
|
||||||
|
begin
|
||||||
|
//debugln('TPenHandleCache.RemoveItem ',HexStr(Cardinal(Item.Handle),8));
|
||||||
|
DeleteObject(Item.Handle);
|
||||||
|
inherited RemoveItem(Item);
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TPenHandleCache.Create;
|
||||||
|
begin
|
||||||
|
inherited Create(SizeOf(TPenData));
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TPen }
|
||||||
|
|
||||||
{------------------------------------------------------------------------------
|
{------------------------------------------------------------------------------
|
||||||
Method: TPen.SetColor
|
Method: TPen.SetColor
|
||||||
Params: Value: the new value
|
Params: Value: the new value
|
||||||
@ -166,16 +183,26 @@ const
|
|||||||
PS_SOLID,PS_DASH,PS_DOT,PS_DASHDOT,PS_DASHDOTDOT,PS_NULL,PS_INSIDEFRAME);
|
PS_SOLID,PS_DASH,PS_DOT,PS_DASHDOT,PS_DASHDOTDOT,PS_NULL,PS_INSIDEFRAME);
|
||||||
var
|
var
|
||||||
LogPen: TLogPen;
|
LogPen: TLogPen;
|
||||||
|
CachedPen: TBlockResourceCacheDescriptor;
|
||||||
begin
|
begin
|
||||||
if FPenData.Handle = 0
|
if FPenData.Handle = 0
|
||||||
then begin
|
then begin
|
||||||
|
FillChar(LogPen,SizeOf(LogPen),0);
|
||||||
with LogPen do
|
with LogPen do
|
||||||
begin
|
begin
|
||||||
lopnStyle := PEN_STYLES[FPenData.Style];
|
lopnStyle := PEN_STYLES[FPenData.Style];
|
||||||
lopnWidth.X := FPenData.Width;
|
lopnWidth.X := FPenData.Width;
|
||||||
lopnColor := FPenData.Color;
|
lopnColor := FPenData.Color;
|
||||||
end;
|
end;
|
||||||
|
CachedPen:=PenResourceCache.FindDescriptor(@LogPen);
|
||||||
|
if CachedPen<>nil then begin
|
||||||
|
CachedPen.Item.IncreaseRefCount;
|
||||||
|
FPenData.Handle := CachedPen.Item.Handle;
|
||||||
|
end else begin
|
||||||
FPenData.Handle := CreatePenIndirect(LogPen);
|
FPenData.Handle := CreatePenIndirect(LogPen);
|
||||||
|
PenResourceCache.AddResource(FPenData.Handle,@LogPen);
|
||||||
|
end;
|
||||||
|
FPenHandleCached:=true;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
Result := FPenData.Handle;
|
Result := FPenData.Handle;
|
||||||
@ -194,6 +221,10 @@ begin
|
|||||||
then begin
|
then begin
|
||||||
// Changing triggers deselecting the current handle
|
// Changing triggers deselecting the current handle
|
||||||
Changing;
|
Changing;
|
||||||
|
if FPenHandleCached then begin
|
||||||
|
PenResourceCache.FindItem(FPenData.Handle).DecreaseRefCount;
|
||||||
|
FPenHandleCached:=false;
|
||||||
|
end else
|
||||||
DeleteObject(FPenData.Handle);
|
DeleteObject(FPenData.Handle);
|
||||||
FPenData.Handle := 0;
|
FPenData.Handle := 0;
|
||||||
end;
|
end;
|
||||||
@ -202,6 +233,9 @@ end;
|
|||||||
{ =============================================================================
|
{ =============================================================================
|
||||||
|
|
||||||
$Log$
|
$Log$
|
||||||
|
Revision 1.10 2004/08/11 20:57:09 mattias
|
||||||
|
moved intfstrconsts.pp to lclstrconsts.pas, implemented TPenHandleCache
|
||||||
|
|
||||||
Revision 1.9 2004/04/10 17:58:57 mattias
|
Revision 1.9 2004/04/10 17:58:57 mattias
|
||||||
implemented mainunit hints for include files
|
implemented mainunit hints for include files
|
||||||
|
|
||||||
|
|||||||
@ -33,8 +33,8 @@ interface
|
|||||||
{$endif}
|
{$endif}
|
||||||
|
|
||||||
uses
|
uses
|
||||||
Classes, SysUtils, Math, FPCAdds, LCLType, LCLProc, VCLGlobals, LMessages,
|
Classes, SysUtils, Math, FPCAdds, LCLStrConsts, LCLType, LCLProc, VCLGlobals,
|
||||||
GraphType, GraphMath, IntfStrConsts;
|
LMessages, GraphType, GraphMath;
|
||||||
|
|
||||||
type
|
type
|
||||||
|
|
||||||
@ -51,7 +51,8 @@ type
|
|||||||
procedure AppInit; virtual; abstract;
|
procedure AppInit; virtual; abstract;
|
||||||
procedure AppTerminate; virtual; abstract;
|
procedure AppTerminate; virtual; abstract;
|
||||||
function InitHintFont(HintFont: TObject): Boolean; virtual;
|
function InitHintFont(HintFont: TObject): Boolean; virtual;
|
||||||
function IntSendMessage3(LM_Message: Integer; Sender: TObject; Data: pointer): integer; virtual; abstract;
|
function IntSendMessage3(LM_Message: Integer; Sender: TObject;
|
||||||
|
Data: pointer): integer; virtual; abstract;
|
||||||
|
|
||||||
// create and destroy
|
// create and destroy
|
||||||
function CreateComponent(Sender : TObject): THandle; virtual; abstract;
|
function CreateComponent(Sender : TObject): THandle; virtual; abstract;
|
||||||
@ -113,6 +114,9 @@ end.
|
|||||||
|
|
||||||
{
|
{
|
||||||
$Log$
|
$Log$
|
||||||
|
Revision 1.47 2004/08/11 20:57:09 mattias
|
||||||
|
moved intfstrconsts.pp to lclstrconsts.pas, implemented TPenHandleCache
|
||||||
|
|
||||||
Revision 1.46 2004/03/19 00:53:34 marc
|
Revision 1.46 2004/03/19 00:53:34 marc
|
||||||
* Removed all ComponentCreateHandle routines
|
* Removed all ComponentCreateHandle routines
|
||||||
|
|
||||||
|
|||||||
@ -19,125 +19,8 @@ unit GtkFontCache;
|
|||||||
interface
|
interface
|
||||||
|
|
||||||
uses
|
uses
|
||||||
Classes, SysUtils, FPCAdds, LCLProc, LCLType, AvgLvlTree, gdk, gtkdef;
|
Classes, SysUtils, FPCAdds, LCLProc, LCLType, AvgLvlTree, gdk, gtkdef,
|
||||||
|
LCLResCache;
|
||||||
type
|
|
||||||
TResourceCache = class;
|
|
||||||
TResourceCacheDescriptor = class;
|
|
||||||
|
|
||||||
{ TResourceCacheItem }
|
|
||||||
|
|
||||||
TResourceCacheItem = class
|
|
||||||
private
|
|
||||||
FReferenceCount: integer;
|
|
||||||
public
|
|
||||||
Handle: THandle;
|
|
||||||
Cache: TResourceCache;
|
|
||||||
FirstDescriptor, LastDescriptor: TResourceCacheDescriptor;
|
|
||||||
Next, Prev: TResourceCacheItem;
|
|
||||||
constructor Create(TheCache: TResourceCache; TheHandle: THandle);
|
|
||||||
destructor Destroy; override;
|
|
||||||
procedure IncreaseRefCount;
|
|
||||||
procedure DecreaseRefCount;
|
|
||||||
procedure AddToList(var First, Last: TResourceCacheItem);
|
|
||||||
procedure RemoveFromList(var First, Last: TResourceCacheItem);
|
|
||||||
procedure WarnReferenceHigh; virtual;
|
|
||||||
public
|
|
||||||
property ReferenceCount: integer read FReferenceCount;
|
|
||||||
end;
|
|
||||||
TResourceCacheItemClass = class of TResourceCacheItem;
|
|
||||||
|
|
||||||
|
|
||||||
{ TResourceCacheDescriptor }
|
|
||||||
|
|
||||||
TResourceCacheDescriptor = class
|
|
||||||
public
|
|
||||||
Item: TResourceCacheItem;
|
|
||||||
Cache: TResourceCache;
|
|
||||||
Next, Prev: TResourceCacheDescriptor;
|
|
||||||
constructor Create(TheCache: TResourceCache; TheItem: TResourceCacheItem);
|
|
||||||
destructor Destroy; override;
|
|
||||||
procedure AddToList(var First, Last: TResourceCacheDescriptor);
|
|
||||||
procedure RemoveFromList(var First, Last: TResourceCacheDescriptor);
|
|
||||||
end;
|
|
||||||
TResourceCacheDescriptorClass = class of TResourceCacheDescriptor;
|
|
||||||
|
|
||||||
|
|
||||||
{ TResourceCache }
|
|
||||||
|
|
||||||
TResourceCache = class
|
|
||||||
protected
|
|
||||||
FItems: TAvgLvlTree;
|
|
||||||
FDescriptors: TAvgLvlTree;
|
|
||||||
FDestroying: boolean;
|
|
||||||
FResourceCacheDescriptorClass: TResourceCacheDescriptorClass;
|
|
||||||
FResourceCacheItemClass: TResourceCacheItemClass;
|
|
||||||
FMaxUnusedItem: integer; // how many freed resources to keep
|
|
||||||
FFirstUnusedItem, FLastUnusedItem: TResourceCacheItem;
|
|
||||||
FUnUsedItemCount: integer;
|
|
||||||
procedure RemoveItem(Item: TResourceCacheItem); virtual;
|
|
||||||
procedure RemoveDescriptor(Desc: TResourceCacheDescriptor); virtual;
|
|
||||||
procedure ItemUsed(Item: TResourceCacheItem);
|
|
||||||
procedure ItemUnused(Item: TResourceCacheItem);
|
|
||||||
function ItemIsUsed(Item: TResourceCacheItem): boolean;
|
|
||||||
public
|
|
||||||
constructor Create;
|
|
||||||
destructor Destroy; override;
|
|
||||||
function CompareItems(Tree: TAvgLvlTree; Item1, Item2: Pointer): integer; virtual;
|
|
||||||
function CompareDescriptors(Tree: TAvgLvlTree; Desc1, Desc2: Pointer): integer; virtual; abstract;
|
|
||||||
procedure ConsistencyCheck;
|
|
||||||
public
|
|
||||||
property MaxUnusedItem: integer read FMaxUnusedItem
|
|
||||||
write FMaxUnusedItem;
|
|
||||||
property ResourceCacheItemClass: TResourceCacheItemClass
|
|
||||||
read FResourceCacheItemClass;
|
|
||||||
property ResourceCacheDescriptorClass: TResourceCacheDescriptorClass
|
|
||||||
read FResourceCacheDescriptorClass;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
{ THandleResourceCache }
|
|
||||||
|
|
||||||
THandleResourceCache = class(TResourceCache)
|
|
||||||
public
|
|
||||||
function FindItem(Handle: THandle): TResourceCacheItem;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
{ TBlockResourceCacheDescriptor }
|
|
||||||
|
|
||||||
TBlockResourceCacheDescriptor = class(TResourceCacheDescriptor)
|
|
||||||
public
|
|
||||||
Data: Pointer;
|
|
||||||
destructor Destroy; override;
|
|
||||||
end;
|
|
||||||
|
|
||||||
|
|
||||||
{ TBlockResourceCache }
|
|
||||||
|
|
||||||
TBlockResourceCache = class(THandleResourceCache)
|
|
||||||
private
|
|
||||||
FDataSize: integer;
|
|
||||||
protected
|
|
||||||
FOnCompareDescPtrWithDescriptor: TListSortCompare;
|
|
||||||
public
|
|
||||||
constructor Create(TheDataSize: integer);
|
|
||||||
function FindDescriptor(DescPtr: Pointer): TBlockResourceCacheDescriptor;
|
|
||||||
function AddResource(Handle: THandle; DescPtr: Pointer
|
|
||||||
): TBlockResourceCacheDescriptor;
|
|
||||||
function CompareDescriptors(Tree: TAvgLvlTree;
|
|
||||||
Desc1, Desc2: Pointer): integer; override;
|
|
||||||
public
|
|
||||||
property DataSize: integer read FDataSize;
|
|
||||||
property OnCompareDescPtrWithDescriptor: TListSortCompare
|
|
||||||
read FOnCompareDescPtrWithDescriptor;
|
|
||||||
end;
|
|
||||||
|
|
||||||
function ComparePHandleWithResourceCacheItem(HandlePtr: PHandle;
|
|
||||||
Item: TResourceCacheItem): integer;
|
|
||||||
function CompareDescPtrWithBlockResDesc(DescPtr: Pointer;
|
|
||||||
Item: TBlockResourceCacheDescriptor): integer;
|
|
||||||
|
|
||||||
|
|
||||||
type
|
type
|
||||||
TGdkFontCacheDescriptor = class;
|
TGdkFontCacheDescriptor = class;
|
||||||
@ -202,19 +85,6 @@ type
|
|||||||
end;
|
end;
|
||||||
PLogFontAndName = ^TLogFontAndName;
|
PLogFontAndName = ^TLogFontAndName;
|
||||||
|
|
||||||
function ComparePHandleWithResourceCacheItem(HandlePtr: PHandle;
|
|
||||||
Item: TResourceCacheItem): integer;
|
|
||||||
begin
|
|
||||||
Result:=CompareHandles(HandlePtr^,Item.Handle);
|
|
||||||
end;
|
|
||||||
|
|
||||||
function CompareDescPtrWithBlockResDesc(DescPtr: Pointer;
|
|
||||||
Item: TBlockResourceCacheDescriptor): integer;
|
|
||||||
begin
|
|
||||||
Result:=CompareMemRange(DescPtr,Item.Data,
|
|
||||||
TBlockResourceCache(Item.Cache).DataSize);
|
|
||||||
end;
|
|
||||||
|
|
||||||
function LogFontToString(const LogFont: TLogFont): string;
|
function LogFontToString(const LogFont: TLogFont): string;
|
||||||
var
|
var
|
||||||
i: Integer;
|
i: Integer;
|
||||||
@ -241,281 +111,6 @@ begin
|
|||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
||||||
{ TResourceCacheItem }
|
|
||||||
|
|
||||||
constructor TResourceCacheItem.Create(TheCache: TResourceCache;
|
|
||||||
TheHandle: THandle);
|
|
||||||
begin
|
|
||||||
Cache:=TheCache;
|
|
||||||
Handle:=TheHandle;
|
|
||||||
end;
|
|
||||||
|
|
||||||
destructor TResourceCacheItem.Destroy;
|
|
||||||
begin
|
|
||||||
Cache.RemoveItem(Self);
|
|
||||||
inherited Destroy;
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TResourceCacheItem.IncreaseRefCount;
|
|
||||||
begin
|
|
||||||
inc(FReferenceCount);
|
|
||||||
if FReferenceCount=1 then
|
|
||||||
Cache.ItemUsed(Self);
|
|
||||||
if (FReferenceCount=100) or (FReferenceCount=1000) then
|
|
||||||
WarnReferenceHigh;
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TResourceCacheItem.DecreaseRefCount;
|
|
||||||
begin
|
|
||||||
if FReferenceCount=0 then
|
|
||||||
RaiseGDBException('TResourceCacheItem.DecreaseRefCount=0');
|
|
||||||
dec(FReferenceCount);
|
|
||||||
if FReferenceCount=0 then
|
|
||||||
Cache.ItemUnused(Self);
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TResourceCacheItem.AddToList(var First, Last: TResourceCacheItem
|
|
||||||
);
|
|
||||||
// add as last
|
|
||||||
begin
|
|
||||||
Next:=nil;
|
|
||||||
Prev:=Last;
|
|
||||||
Last:=Self;
|
|
||||||
if First=nil then First:=Self;
|
|
||||||
if Prev<>nil then Prev.Next:=Self;
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TResourceCacheItem.RemoveFromList(var First,Last: TResourceCacheItem);
|
|
||||||
begin
|
|
||||||
if First=Self then First:=Next;
|
|
||||||
if Last=Self then Last:=Prev;
|
|
||||||
if Next<>nil then Next.Prev:=Prev;
|
|
||||||
if Prev<>nil then Prev.Next:=Next;
|
|
||||||
Next:=nil;
|
|
||||||
Prev:=nil;
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TResourceCacheItem.WarnReferenceHigh;
|
|
||||||
begin
|
|
||||||
debugln('WARNING: TResourceCacheItem.IncreaseRefCount ',dbgs(FReferenceCount));
|
|
||||||
end;
|
|
||||||
|
|
||||||
{ TResourceCacheDescriptor }
|
|
||||||
|
|
||||||
constructor TResourceCacheDescriptor.Create(TheCache: TResourceCache;
|
|
||||||
TheItem: TResourceCacheItem);
|
|
||||||
begin
|
|
||||||
Cache:=TheCache;
|
|
||||||
Item:=TheItem;
|
|
||||||
Item.IncreaseRefCount;
|
|
||||||
AddToList(Item.FirstDescriptor,Item.LastDescriptor);
|
|
||||||
end;
|
|
||||||
|
|
||||||
destructor TResourceCacheDescriptor.Destroy;
|
|
||||||
begin
|
|
||||||
Cache.RemoveDescriptor(Self);
|
|
||||||
inherited Destroy;
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TResourceCacheDescriptor.AddToList(
|
|
||||||
var First, Last: TResourceCacheDescriptor);
|
|
||||||
// add as last
|
|
||||||
begin
|
|
||||||
Next:=nil;
|
|
||||||
Prev:=Last;
|
|
||||||
Last:=Self;
|
|
||||||
if First=nil then First:=Self;
|
|
||||||
if Prev<>nil then Prev.Next:=Self;
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TResourceCacheDescriptor.RemoveFromList(
|
|
||||||
var First, Last: TResourceCacheDescriptor);
|
|
||||||
begin
|
|
||||||
if First=Self then First:=Next;
|
|
||||||
if Last=Self then Last:=Prev;
|
|
||||||
if Next<>nil then Next.Prev:=Prev;
|
|
||||||
if Prev<>nil then Prev.Next:=Next;
|
|
||||||
Next:=nil;
|
|
||||||
Prev:=nil;
|
|
||||||
end;
|
|
||||||
|
|
||||||
{ TResourceCache }
|
|
||||||
|
|
||||||
procedure TResourceCache.RemoveItem(Item: TResourceCacheItem);
|
|
||||||
begin
|
|
||||||
if FDestroying then exit;
|
|
||||||
while Item.FirstDescriptor<>nil do Item.FirstDescriptor.Free;
|
|
||||||
FItems.Remove(Item);
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TResourceCache.RemoveDescriptor(Desc: TResourceCacheDescriptor);
|
|
||||||
begin
|
|
||||||
if FDestroying then exit;
|
|
||||||
Desc.RemoveFromList(Desc.Item.FirstDescriptor,Desc.Item.LastDescriptor);
|
|
||||||
FDescriptors.Remove(Desc);
|
|
||||||
if Desc.Item.FirstDescriptor=nil then
|
|
||||||
Desc.Item.Free;
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TResourceCache.ItemUsed(Item: TResourceCacheItem);
|
|
||||||
// called after creation or when Item is used again
|
|
||||||
begin
|
|
||||||
if not ItemIsUsed(Item) then begin
|
|
||||||
Item.RemoveFromList(FFirstUnusedItem,FLastUnusedItem);
|
|
||||||
dec(FUnUsedItemCount);
|
|
||||||
end;
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TResourceCache.ItemUnused(Item: TResourceCacheItem);
|
|
||||||
// called when Item is not used any more
|
|
||||||
begin
|
|
||||||
if not ItemIsUsed(Item) then
|
|
||||||
raise Exception.Create('TResourceCache.ItemUnused');
|
|
||||||
Item.AddToList(FFirstUnusedItem,FLastUnusedItem);
|
|
||||||
inc(FUnUsedItemCount);
|
|
||||||
if FUnUsedItemCount>FMaxUnusedItem then
|
|
||||||
// maximum unused resources reached -> free the oldest
|
|
||||||
FFirstUnusedItem.Free;
|
|
||||||
end;
|
|
||||||
|
|
||||||
function TResourceCache.ItemIsUsed(Item: TResourceCacheItem): boolean;
|
|
||||||
begin
|
|
||||||
Result:=(FFirstUnusedItem<>Item) and (Item.Next=nil)
|
|
||||||
and (Item.Prev=nil)
|
|
||||||
end;
|
|
||||||
|
|
||||||
constructor TResourceCache.Create;
|
|
||||||
begin
|
|
||||||
FMaxUnusedItem:=100;
|
|
||||||
FItems:=TAvgLvlTree.CreateObjectCompare(@CompareItems);
|
|
||||||
FDescriptors:=TAvgLvlTree.CreateObjectCompare(@CompareDescriptors);
|
|
||||||
FResourceCacheItemClass:=TResourceCacheItem;
|
|
||||||
FResourceCacheDescriptorClass:=TResourceCacheDescriptor;
|
|
||||||
end;
|
|
||||||
|
|
||||||
destructor TResourceCache.Destroy;
|
|
||||||
begin
|
|
||||||
FDestroying:=true;
|
|
||||||
FItems.FreeAndClear;
|
|
||||||
FItems.Free;
|
|
||||||
FItems:=nil;
|
|
||||||
FDescriptors.FreeAndClear;
|
|
||||||
FDescriptors.Free;
|
|
||||||
FDescriptors:=nil;
|
|
||||||
inherited Destroy;
|
|
||||||
end;
|
|
||||||
|
|
||||||
function TResourceCache.CompareItems(Tree: TAvgLvlTree; Item1, Item2: Pointer
|
|
||||||
): integer;
|
|
||||||
begin
|
|
||||||
Result:=CompareHandles(TResourceCacheItem(Item1).Handle,
|
|
||||||
TResourceCacheItem(Item2).Handle);
|
|
||||||
end;
|
|
||||||
|
|
||||||
procedure TResourceCache.ConsistencyCheck;
|
|
||||||
var
|
|
||||||
ANode: TAvgLvlTreeNode;
|
|
||||||
Item: TResourceCacheItem;
|
|
||||||
begin
|
|
||||||
if (FFirstUnusedItem=nil) xor (FLastUnusedItem=nil) then
|
|
||||||
RaiseGDBException('');
|
|
||||||
|
|
||||||
// check items
|
|
||||||
ANode:=FItems.FindLowest;
|
|
||||||
while ANode<>nil do begin
|
|
||||||
Item:=TResourceCacheItem(ANode.Data);
|
|
||||||
if Item.FirstDescriptor=nil then
|
|
||||||
RaiseGDBException('');
|
|
||||||
if Item.LastDescriptor=nil then
|
|
||||||
RaiseGDBException('');
|
|
||||||
ANode:=FItems.FindSuccessor(ANode);
|
|
||||||
end;
|
|
||||||
end;
|
|
||||||
|
|
||||||
{ THandleResourceCache }
|
|
||||||
|
|
||||||
function THandleResourceCache.FindItem(Handle: THandle): TResourceCacheItem;
|
|
||||||
var
|
|
||||||
ANode: TAvgLvlTreeNode;
|
|
||||||
begin
|
|
||||||
ANode:=FItems.FindKey(@Handle,@ComparePHandleWithResourceCacheItem);
|
|
||||||
if ANode<>nil then
|
|
||||||
Result:=TResourceCacheItem(ANode.Data)
|
|
||||||
else
|
|
||||||
Result:=nil;
|
|
||||||
end;
|
|
||||||
|
|
||||||
{ TBlockResourceCache }
|
|
||||||
|
|
||||||
constructor TBlockResourceCache.Create(TheDataSize: integer);
|
|
||||||
begin
|
|
||||||
inherited Create;
|
|
||||||
FDataSize:=DataSize;
|
|
||||||
FResourceCacheDescriptorClass:=TBlockResourceCacheDescriptor;
|
|
||||||
FOnCompareDescPtrWithDescriptor:=@CompareDescPtrWithBlockResDesc;
|
|
||||||
end;
|
|
||||||
|
|
||||||
function TBlockResourceCache.FindDescriptor(DescPtr: Pointer
|
|
||||||
): TBlockResourceCacheDescriptor;
|
|
||||||
var
|
|
||||||
ANode: TAvgLvlTreeNode;
|
|
||||||
begin
|
|
||||||
ANode:=FDescriptors.FindKey(DescPtr,FOnCompareDescPtrWithDescriptor);
|
|
||||||
if ANode<>nil then
|
|
||||||
Result:=TBlockResourceCacheDescriptor(ANode.Data)
|
|
||||||
else
|
|
||||||
Result:=nil;
|
|
||||||
end;
|
|
||||||
|
|
||||||
function TBlockResourceCache.AddResource(Handle: THandle; DescPtr: Pointer
|
|
||||||
): TBlockResourceCacheDescriptor;
|
|
||||||
var
|
|
||||||
Item: TResourceCacheItem;
|
|
||||||
|
|
||||||
procedure RaiseDescriptorAlreadyAdded;
|
|
||||||
var
|
|
||||||
Msg: String;
|
|
||||||
i: Integer;
|
|
||||||
begin
|
|
||||||
Msg:='TBlockResourceCache.AddResource Descriptor Already Added '#13;
|
|
||||||
for i:=0 to DataSize-1 do
|
|
||||||
Msg:=Msg+hexstr(ord(PChar(DescPtr)[i]),2);
|
|
||||||
raise Exception.Create(Msg);
|
|
||||||
end;
|
|
||||||
|
|
||||||
begin
|
|
||||||
Result:=FindDescriptor(DescPtr);
|
|
||||||
if Result<>nil then
|
|
||||||
RaiseDescriptorAlreadyAdded;
|
|
||||||
|
|
||||||
Item:=FindItem(Handle);
|
|
||||||
if Item=nil then begin
|
|
||||||
Item:=FResourceCacheItemClass.Create(Self,Handle);
|
|
||||||
FItems.Add(Item);
|
|
||||||
end;
|
|
||||||
Result:=TBlockResourceCacheDescriptor(
|
|
||||||
FResourceCacheDescriptorClass.Create(Self,Item));
|
|
||||||
ReAllocMem(Result.Data,DataSize);
|
|
||||||
System.Move(DescPtr^,Result.Data^,DataSize);
|
|
||||||
FDescriptors.Add(Result);
|
|
||||||
end;
|
|
||||||
|
|
||||||
function TBlockResourceCache.CompareDescriptors(Tree: TAvgLvlTree; Desc1,
|
|
||||||
Desc2: Pointer): integer;
|
|
||||||
begin
|
|
||||||
Result:=CompareMemRange(TBlockResourceCacheDescriptor(Desc1).Data,
|
|
||||||
TBlockResourceCacheDescriptor(Desc2).Data,
|
|
||||||
DataSize);
|
|
||||||
end;
|
|
||||||
|
|
||||||
{ TBlockResourceCacheDescriptor }
|
|
||||||
|
|
||||||
destructor TBlockResourceCacheDescriptor.Destroy;
|
|
||||||
begin
|
|
||||||
ReAllocMem(Data,0);
|
|
||||||
inherited Destroy;
|
|
||||||
end;
|
|
||||||
|
|
||||||
{ TGdkFontCache }
|
{ TGdkFontCache }
|
||||||
|
|
||||||
function CompareGdkFontWithResItem(Font: PGDKFont;
|
function CompareGdkFontWithResItem(Font: PGDKFont;
|
||||||
|
|||||||
@ -1,94 +0,0 @@
|
|||||||
{ $Id$ }
|
|
||||||
{
|
|
||||||
/***************************************************************************
|
|
||||||
intfstrconsts.pas
|
|
||||||
-----------------------
|
|
||||||
This unit contains all resource strings of the interface
|
|
||||||
|
|
||||||
|
|
||||||
***************************************************************************/
|
|
||||||
|
|
||||||
***************************************************************************
|
|
||||||
* *
|
|
||||||
* This source is free software; you can redistribute it and/or modify *
|
|
||||||
* it under the terms of the GNU General Public License as published by *
|
|
||||||
* the Free Software Foundation; either version 2 of the License, or *
|
|
||||||
* (at your option) any later version. *
|
|
||||||
* *
|
|
||||||
* This code is distributed in the hope that it will be useful, but *
|
|
||||||
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
||||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
|
||||||
* General Public License for more details. *
|
|
||||||
* *
|
|
||||||
* A copy of the GNU General Public License is available on the World *
|
|
||||||
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
|
||||||
* obtain it by writing to the Free Software Foundation, *
|
|
||||||
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
|
|
||||||
* *
|
|
||||||
***************************************************************************
|
|
||||||
}
|
|
||||||
{
|
|
||||||
Note: All resource strings should be prefixed with 'ifs' (InterFace String)
|
|
||||||
|
|
||||||
}
|
|
||||||
unit IntfStrConsts;
|
|
||||||
|
|
||||||
{$mode objfpc}{$H+}
|
|
||||||
|
|
||||||
interface
|
|
||||||
|
|
||||||
resourcestring
|
|
||||||
|
|
||||||
// I'm not sure if in all languages the Dialog texts for a button
|
|
||||||
// have the same meaning as a key
|
|
||||||
// So every VK gets its own constant
|
|
||||||
ifsVK_UNKNOWN = 'Unknown';
|
|
||||||
ifsVK_LBUTTON = 'Mouse Button Left';
|
|
||||||
ifsVK_RBUTTON = 'Mouse Button Right';
|
|
||||||
ifsVK_CANCEL = 'Cancel'; //= dlgCancel
|
|
||||||
ifsVK_MBUTTON = 'Mouse Button Middle';
|
|
||||||
ifsVK_BACK = 'Backspace';
|
|
||||||
ifsVK_TAB = 'Tab';
|
|
||||||
ifsVK_CLEAR = 'Clear';
|
|
||||||
ifsVK_RETURN = 'Return';
|
|
||||||
ifsVK_SHIFT = 'Shift';
|
|
||||||
ifsVK_CONTROL = 'Control';
|
|
||||||
ifsVK_MENU = 'Menu';
|
|
||||||
ifsVK_PAUSE = 'Pause key';
|
|
||||||
ifsVK_CAPITAL = 'Capital';
|
|
||||||
ifsVK_KANA = 'Kana';
|
|
||||||
ifsVK_JUNJA = 'Junja';
|
|
||||||
ifsVK_FINAL = 'Final';
|
|
||||||
ifsVK_HANJA = 'Hanja';
|
|
||||||
ifsVK_ESCAPE = 'Escape';
|
|
||||||
ifsVK_CONVERT = 'Convert';
|
|
||||||
ifsVK_NONCONVERT = 'Nonconvert';
|
|
||||||
ifsVK_ACCEPT = 'Accept';
|
|
||||||
ifsVK_MODECHANGE = 'Mode Change';
|
|
||||||
ifsVK_SPACE = 'Space key';
|
|
||||||
ifsVK_PRIOR = 'Prior';
|
|
||||||
ifsVK_NEXT = 'Next';
|
|
||||||
ifsVK_END = 'End';
|
|
||||||
ifsVK_HOME = 'Home';
|
|
||||||
ifsVK_LEFT = 'Left';
|
|
||||||
ifsVK_UP = 'Up';
|
|
||||||
ifsVK_RIGHT = 'Right';
|
|
||||||
ifsVK_DOWN = 'Down'; //= dlgdownword
|
|
||||||
ifsVK_SELECT = 'Select'; //= lismenuselect
|
|
||||||
ifsVK_PRINT = 'Print';
|
|
||||||
ifsVK_EXECUTE = 'Execute';
|
|
||||||
ifsVK_SNAPSHOT = 'Snapshot';
|
|
||||||
ifsVK_INSERT = 'Insert';
|
|
||||||
ifsVK_DELETE = 'Delete'; //= dlgeddelete
|
|
||||||
ifsVK_HELP = 'Help';
|
|
||||||
ifsVK_LWIN = 'left windows key';
|
|
||||||
ifsVK_RWIN = 'right windows key';
|
|
||||||
ifsVK_APPS = 'application key';
|
|
||||||
ifsVK_NUMPAD = 'Numpad %d';
|
|
||||||
ifsVK_NUMLOCK = 'Numlock';
|
|
||||||
ifsVK_SCROLL = 'Scroll';
|
|
||||||
|
|
||||||
implementation
|
|
||||||
|
|
||||||
end.
|
|
||||||
|
|
||||||
@ -70,6 +70,7 @@ type
|
|||||||
function(LM_Message: Integer; Sender: TObject; data: pointer): integer
|
function(LM_Message: Integer; Sender: TObject; data: pointer): integer
|
||||||
of object;
|
of object;
|
||||||
|
|
||||||
|
|
||||||
var
|
var
|
||||||
SendApplicationMessageFunction: TSendApplicationMessageFunction;
|
SendApplicationMessageFunction: TSendApplicationMessageFunction;
|
||||||
OwnerFormDesignerModifiedProc: TOwnerFormDesignerModifiedProc;
|
OwnerFormDesignerModifiedProc: TOwnerFormDesignerModifiedProc;
|
||||||
@ -78,9 +79,12 @@ var
|
|||||||
|
|
||||||
function SendApplicationMessage(Msg: Cardinal; WParam: WParam; LParam: LParam):Longint;
|
function SendApplicationMessage(Msg: Cardinal; WParam: WParam; LParam: LParam):Longint;
|
||||||
procedure OwnerFormDesignerModified(AComponent: TComponent);
|
procedure OwnerFormDesignerModified(AComponent: TComponent);
|
||||||
function OffsetRect(var ARect: TRect; dx,dy: Integer): Boolean;
|
|
||||||
procedure FreeThenNil(var AnObject: TObject);
|
procedure FreeThenNil(var AnObject: TObject);
|
||||||
|
|
||||||
|
procedure RegisterInterfaceFinalizationHandler(p: TProcedure);
|
||||||
|
procedure CallInterfaceFinalizationHandlers;
|
||||||
|
|
||||||
|
function OffsetRect(var ARect: TRect; dx,dy: Integer): Boolean;
|
||||||
procedure MakeMinMax(var i1, i2: integer);
|
procedure MakeMinMax(var i1, i2: integer);
|
||||||
procedure CalculateLeftTopWidthHeight(X1,Y1,X2,Y2: integer;
|
procedure CalculateLeftTopWidthHeight(X1,Y1,X2,Y2: integer;
|
||||||
var Left,Top,Width,Height: integer);
|
var Left,Top,Width,Height: integer);
|
||||||
@ -134,6 +138,9 @@ function DbgS(const i1,i2,i3,i4: integer): string;
|
|||||||
|
|
||||||
implementation
|
implementation
|
||||||
|
|
||||||
|
var
|
||||||
|
InterfaceFinalizationHandlers: TList;
|
||||||
|
|
||||||
|
|
||||||
Function DeleteAmpersands(var Str : String) : Longint;
|
Function DeleteAmpersands(var Str : String) : Longint;
|
||||||
// Replace all &x with x
|
// Replace all &x with x
|
||||||
@ -332,6 +339,19 @@ begin
|
|||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure RegisterInterfaceFinalizationHandler(p: TProcedure);
|
||||||
|
begin
|
||||||
|
InterfaceFinalizationHandlers.Add(p);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure CallInterfaceFinalizationHandlers;
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
begin
|
||||||
|
for i:=0 to InterfaceFinalizationHandlers.Count-1 do
|
||||||
|
TProcedure(InterfaceFinalizationHandlers[i])();
|
||||||
|
end;
|
||||||
|
|
||||||
{ TMethodList }
|
{ TMethodList }
|
||||||
|
|
||||||
function TMethodList.GetItems(Index: integer): TMethod;
|
function TMethodList.GetItems(Index: integer): TMethod;
|
||||||
@ -770,6 +790,10 @@ end;
|
|||||||
initialization
|
initialization
|
||||||
SendApplicationMessageFunction:=nil;
|
SendApplicationMessageFunction:=nil;
|
||||||
OwnerFormDesignerModifiedProc:=nil;
|
OwnerFormDesignerModifiedProc:=nil;
|
||||||
|
InterfaceFinalizationHandlers:=TList.Create;
|
||||||
|
finalization
|
||||||
|
InterfaceFinalizationHandlers.Free;
|
||||||
|
InterfaceFinalizationHandlers:=nil;
|
||||||
|
|
||||||
end.
|
end.
|
||||||
|
|
||||||
|
|||||||
441
lcl/lclrescache.pas
Normal file
441
lcl/lclrescache.pas
Normal file
@ -0,0 +1,441 @@
|
|||||||
|
{
|
||||||
|
*****************************************************************************
|
||||||
|
* *
|
||||||
|
* This file is part of the Lazarus Component Library (LCL) *
|
||||||
|
* *
|
||||||
|
* See the file COPYING.LCL, included in this distribution, *
|
||||||
|
* for details about the copyright. *
|
||||||
|
* *
|
||||||
|
* This program is distributed in the hope that it will be useful, *
|
||||||
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
|
||||||
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
|
||||||
|
* *
|
||||||
|
*****************************************************************************
|
||||||
|
|
||||||
|
Author: Mattias Gaertner
|
||||||
|
|
||||||
|
Abstract:
|
||||||
|
Types and methods to cache interface resources.
|
||||||
|
See graphics.pp for examples.
|
||||||
|
}
|
||||||
|
unit LCLResCache;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, FPCAdds, LCLProc, AvgLvlTree;
|
||||||
|
|
||||||
|
type
|
||||||
|
TResourceCache = class;
|
||||||
|
TResourceCacheDescriptor = class;
|
||||||
|
|
||||||
|
{ TResourceCacheItem }
|
||||||
|
|
||||||
|
TResourceCacheItem = class
|
||||||
|
private
|
||||||
|
FReferenceCount: integer;
|
||||||
|
public
|
||||||
|
Handle: THandle;
|
||||||
|
Cache: TResourceCache;
|
||||||
|
FirstDescriptor, LastDescriptor: TResourceCacheDescriptor;
|
||||||
|
Next, Prev: TResourceCacheItem;
|
||||||
|
constructor Create(TheCache: TResourceCache; TheHandle: THandle);
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure IncreaseRefCount;
|
||||||
|
procedure DecreaseRefCount;
|
||||||
|
procedure AddToList(var First, Last: TResourceCacheItem);
|
||||||
|
procedure RemoveFromList(var First, Last: TResourceCacheItem);
|
||||||
|
procedure WarnReferenceHigh; virtual;
|
||||||
|
public
|
||||||
|
property ReferenceCount: integer read FReferenceCount;
|
||||||
|
end;
|
||||||
|
TResourceCacheItemClass = class of TResourceCacheItem;
|
||||||
|
|
||||||
|
|
||||||
|
{ TResourceCacheDescriptor }
|
||||||
|
|
||||||
|
TResourceCacheDescriptor = class
|
||||||
|
public
|
||||||
|
Item: TResourceCacheItem;
|
||||||
|
Cache: TResourceCache;
|
||||||
|
Next, Prev: TResourceCacheDescriptor;
|
||||||
|
constructor Create(TheCache: TResourceCache; TheItem: TResourceCacheItem);
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure AddToList(var First, Last: TResourceCacheDescriptor);
|
||||||
|
procedure RemoveFromList(var First, Last: TResourceCacheDescriptor);
|
||||||
|
end;
|
||||||
|
TResourceCacheDescriptorClass = class of TResourceCacheDescriptor;
|
||||||
|
|
||||||
|
|
||||||
|
{ TResourceCache }
|
||||||
|
|
||||||
|
TResourceCache = class
|
||||||
|
protected
|
||||||
|
FItems: TAvgLvlTree;
|
||||||
|
FDescriptors: TAvgLvlTree;
|
||||||
|
FDestroying: boolean;
|
||||||
|
FResourceCacheDescriptorClass: TResourceCacheDescriptorClass;
|
||||||
|
FResourceCacheItemClass: TResourceCacheItemClass;
|
||||||
|
FMaxUnusedItem: integer; // how many freed resources to keep
|
||||||
|
FFirstUnusedItem, FLastUnusedItem: TResourceCacheItem;
|
||||||
|
FUnUsedItemCount: integer;
|
||||||
|
procedure RemoveItem(Item: TResourceCacheItem); virtual;
|
||||||
|
procedure RemoveDescriptor(Desc: TResourceCacheDescriptor); virtual;
|
||||||
|
procedure ItemUsed(Item: TResourceCacheItem);
|
||||||
|
procedure ItemUnused(Item: TResourceCacheItem);
|
||||||
|
function ItemIsUsed(Item: TResourceCacheItem): boolean;
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
|
function CompareItems(Tree: TAvgLvlTree; Item1, Item2: Pointer): integer; virtual;
|
||||||
|
function CompareDescriptors(Tree: TAvgLvlTree; Desc1, Desc2: Pointer): integer; virtual; abstract;
|
||||||
|
procedure ConsistencyCheck;
|
||||||
|
public
|
||||||
|
property MaxUnusedItem: integer read FMaxUnusedItem
|
||||||
|
write FMaxUnusedItem;
|
||||||
|
property ResourceCacheItemClass: TResourceCacheItemClass
|
||||||
|
read FResourceCacheItemClass;
|
||||||
|
property ResourceCacheDescriptorClass: TResourceCacheDescriptorClass
|
||||||
|
read FResourceCacheDescriptorClass;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
{ THandleResourceCache }
|
||||||
|
|
||||||
|
THandleResourceCache = class(TResourceCache)
|
||||||
|
public
|
||||||
|
function FindItem(Handle: THandle): TResourceCacheItem;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
{ TBlockResourceCacheDescriptor }
|
||||||
|
|
||||||
|
TBlockResourceCacheDescriptor = class(TResourceCacheDescriptor)
|
||||||
|
public
|
||||||
|
Data: Pointer;
|
||||||
|
destructor Destroy; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
{ TBlockResourceCache }
|
||||||
|
|
||||||
|
TBlockResourceCache = class(THandleResourceCache)
|
||||||
|
private
|
||||||
|
FDataSize: integer;
|
||||||
|
protected
|
||||||
|
FOnCompareDescPtrWithDescriptor: TListSortCompare;
|
||||||
|
public
|
||||||
|
constructor Create(TheDataSize: integer);
|
||||||
|
function FindDescriptor(DescPtr: Pointer): TBlockResourceCacheDescriptor;
|
||||||
|
function AddResource(Handle: THandle; DescPtr: Pointer
|
||||||
|
): TBlockResourceCacheDescriptor;
|
||||||
|
function CompareDescriptors(Tree: TAvgLvlTree;
|
||||||
|
Desc1, Desc2: Pointer): integer; override;
|
||||||
|
public
|
||||||
|
property DataSize: integer read FDataSize;
|
||||||
|
property OnCompareDescPtrWithDescriptor: TListSortCompare
|
||||||
|
read FOnCompareDescPtrWithDescriptor;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ComparePHandleWithResourceCacheItem(HandlePtr: PHandle;
|
||||||
|
Item: TResourceCacheItem): integer;
|
||||||
|
function CompareDescPtrWithBlockResDesc(DescPtr: Pointer;
|
||||||
|
Item: TBlockResourceCacheDescriptor): integer;
|
||||||
|
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
|
||||||
|
function ComparePHandleWithResourceCacheItem(HandlePtr: PHandle;
|
||||||
|
Item: TResourceCacheItem): integer;
|
||||||
|
begin
|
||||||
|
Result:=CompareHandles(HandlePtr^,Item.Handle);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function CompareDescPtrWithBlockResDesc(DescPtr: Pointer;
|
||||||
|
Item: TBlockResourceCacheDescriptor): integer;
|
||||||
|
begin
|
||||||
|
Result:=CompareMemRange(DescPtr,Item.Data,
|
||||||
|
TBlockResourceCache(Item.Cache).DataSize);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
{ TResourceCacheItem }
|
||||||
|
|
||||||
|
constructor TResourceCacheItem.Create(TheCache: TResourceCache;
|
||||||
|
TheHandle: THandle);
|
||||||
|
begin
|
||||||
|
Cache:=TheCache;
|
||||||
|
Handle:=TheHandle;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TResourceCacheItem.Destroy;
|
||||||
|
begin
|
||||||
|
Cache.RemoveItem(Self);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TResourceCacheItem.IncreaseRefCount;
|
||||||
|
begin
|
||||||
|
inc(FReferenceCount);
|
||||||
|
if FReferenceCount=1 then
|
||||||
|
Cache.ItemUsed(Self);
|
||||||
|
if (FReferenceCount=100) or (FReferenceCount=1000) then
|
||||||
|
WarnReferenceHigh;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TResourceCacheItem.DecreaseRefCount;
|
||||||
|
begin
|
||||||
|
if FReferenceCount=0 then
|
||||||
|
RaiseGDBException('TResourceCacheItem.DecreaseRefCount=0');
|
||||||
|
dec(FReferenceCount);
|
||||||
|
if FReferenceCount=0 then
|
||||||
|
Cache.ItemUnused(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TResourceCacheItem.AddToList(var First, Last: TResourceCacheItem
|
||||||
|
);
|
||||||
|
// add as last
|
||||||
|
begin
|
||||||
|
Next:=nil;
|
||||||
|
Prev:=Last;
|
||||||
|
Last:=Self;
|
||||||
|
if First=nil then First:=Self;
|
||||||
|
if Prev<>nil then Prev.Next:=Self;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TResourceCacheItem.RemoveFromList(var First,Last: TResourceCacheItem);
|
||||||
|
begin
|
||||||
|
if First=Self then First:=Next;
|
||||||
|
if Last=Self then Last:=Prev;
|
||||||
|
if Next<>nil then Next.Prev:=Prev;
|
||||||
|
if Prev<>nil then Prev.Next:=Next;
|
||||||
|
Next:=nil;
|
||||||
|
Prev:=nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TResourceCacheItem.WarnReferenceHigh;
|
||||||
|
begin
|
||||||
|
debugln('WARNING: TResourceCacheItem.IncreaseRefCount ',dbgs(FReferenceCount));
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TResourceCacheDescriptor }
|
||||||
|
|
||||||
|
constructor TResourceCacheDescriptor.Create(TheCache: TResourceCache;
|
||||||
|
TheItem: TResourceCacheItem);
|
||||||
|
begin
|
||||||
|
Cache:=TheCache;
|
||||||
|
Item:=TheItem;
|
||||||
|
Item.IncreaseRefCount;
|
||||||
|
AddToList(Item.FirstDescriptor,Item.LastDescriptor);
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TResourceCacheDescriptor.Destroy;
|
||||||
|
begin
|
||||||
|
Cache.RemoveDescriptor(Self);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TResourceCacheDescriptor.AddToList(
|
||||||
|
var First, Last: TResourceCacheDescriptor);
|
||||||
|
// add as last
|
||||||
|
begin
|
||||||
|
Next:=nil;
|
||||||
|
Prev:=Last;
|
||||||
|
Last:=Self;
|
||||||
|
if First=nil then First:=Self;
|
||||||
|
if Prev<>nil then Prev.Next:=Self;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TResourceCacheDescriptor.RemoveFromList(
|
||||||
|
var First, Last: TResourceCacheDescriptor);
|
||||||
|
begin
|
||||||
|
if First=Self then First:=Next;
|
||||||
|
if Last=Self then Last:=Prev;
|
||||||
|
if Next<>nil then Next.Prev:=Prev;
|
||||||
|
if Prev<>nil then Prev.Next:=Next;
|
||||||
|
Next:=nil;
|
||||||
|
Prev:=nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TResourceCache }
|
||||||
|
|
||||||
|
procedure TResourceCache.RemoveItem(Item: TResourceCacheItem);
|
||||||
|
begin
|
||||||
|
if FDestroying then exit;
|
||||||
|
while Item.FirstDescriptor<>nil do Item.FirstDescriptor.Free;
|
||||||
|
FItems.Remove(Item);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TResourceCache.RemoveDescriptor(Desc: TResourceCacheDescriptor);
|
||||||
|
begin
|
||||||
|
if FDestroying then exit;
|
||||||
|
Desc.RemoveFromList(Desc.Item.FirstDescriptor,Desc.Item.LastDescriptor);
|
||||||
|
FDescriptors.Remove(Desc);
|
||||||
|
if Desc.Item.FirstDescriptor=nil then
|
||||||
|
Desc.Item.Free;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TResourceCache.ItemUsed(Item: TResourceCacheItem);
|
||||||
|
// called after creation or when Item is used again
|
||||||
|
begin
|
||||||
|
if not ItemIsUsed(Item) then begin
|
||||||
|
Item.RemoveFromList(FFirstUnusedItem,FLastUnusedItem);
|
||||||
|
dec(FUnUsedItemCount);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TResourceCache.ItemUnused(Item: TResourceCacheItem);
|
||||||
|
// called when Item is not used any more
|
||||||
|
begin
|
||||||
|
if not ItemIsUsed(Item) then
|
||||||
|
raise Exception.Create('TResourceCache.ItemUnused');
|
||||||
|
Item.AddToList(FFirstUnusedItem,FLastUnusedItem);
|
||||||
|
inc(FUnUsedItemCount);
|
||||||
|
if FUnUsedItemCount>FMaxUnusedItem then
|
||||||
|
// maximum unused resources reached -> free the oldest
|
||||||
|
FFirstUnusedItem.Free;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TResourceCache.ItemIsUsed(Item: TResourceCacheItem): boolean;
|
||||||
|
begin
|
||||||
|
Result:=(FFirstUnusedItem<>Item) and (Item.Next=nil)
|
||||||
|
and (Item.Prev=nil)
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TResourceCache.Create;
|
||||||
|
begin
|
||||||
|
FMaxUnusedItem:=100;
|
||||||
|
FItems:=TAvgLvlTree.CreateObjectCompare(@CompareItems);
|
||||||
|
FDescriptors:=TAvgLvlTree.CreateObjectCompare(@CompareDescriptors);
|
||||||
|
FResourceCacheItemClass:=TResourceCacheItem;
|
||||||
|
FResourceCacheDescriptorClass:=TResourceCacheDescriptor;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TResourceCache.Destroy;
|
||||||
|
begin
|
||||||
|
FDestroying:=true;
|
||||||
|
FItems.FreeAndClear;
|
||||||
|
FItems.Free;
|
||||||
|
FItems:=nil;
|
||||||
|
FDescriptors.FreeAndClear;
|
||||||
|
FDescriptors.Free;
|
||||||
|
FDescriptors:=nil;
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TResourceCache.CompareItems(Tree: TAvgLvlTree; Item1, Item2: Pointer
|
||||||
|
): integer;
|
||||||
|
begin
|
||||||
|
Result:=CompareHandles(TResourceCacheItem(Item1).Handle,
|
||||||
|
TResourceCacheItem(Item2).Handle);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TResourceCache.ConsistencyCheck;
|
||||||
|
var
|
||||||
|
ANode: TAvgLvlTreeNode;
|
||||||
|
Item: TResourceCacheItem;
|
||||||
|
begin
|
||||||
|
if (FFirstUnusedItem=nil) xor (FLastUnusedItem=nil) then
|
||||||
|
RaiseGDBException('');
|
||||||
|
|
||||||
|
// check items
|
||||||
|
ANode:=FItems.FindLowest;
|
||||||
|
while ANode<>nil do begin
|
||||||
|
Item:=TResourceCacheItem(ANode.Data);
|
||||||
|
if Item.FirstDescriptor=nil then
|
||||||
|
RaiseGDBException('');
|
||||||
|
if Item.LastDescriptor=nil then
|
||||||
|
RaiseGDBException('');
|
||||||
|
ANode:=FItems.FindSuccessor(ANode);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ THandleResourceCache }
|
||||||
|
|
||||||
|
function THandleResourceCache.FindItem(Handle: THandle): TResourceCacheItem;
|
||||||
|
var
|
||||||
|
ANode: TAvgLvlTreeNode;
|
||||||
|
begin
|
||||||
|
ANode:=FItems.FindKey(@Handle,@ComparePHandleWithResourceCacheItem);
|
||||||
|
if ANode<>nil then
|
||||||
|
Result:=TResourceCacheItem(ANode.Data)
|
||||||
|
else
|
||||||
|
Result:=nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TBlockResourceCache }
|
||||||
|
|
||||||
|
constructor TBlockResourceCache.Create(TheDataSize: integer);
|
||||||
|
begin
|
||||||
|
inherited Create;
|
||||||
|
FDataSize:=TheDataSize;
|
||||||
|
FResourceCacheDescriptorClass:=TBlockResourceCacheDescriptor;
|
||||||
|
FOnCompareDescPtrWithDescriptor:=@CompareDescPtrWithBlockResDesc;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TBlockResourceCache.FindDescriptor(DescPtr: Pointer
|
||||||
|
): TBlockResourceCacheDescriptor;
|
||||||
|
var
|
||||||
|
ANode: TAvgLvlTreeNode;
|
||||||
|
begin
|
||||||
|
ANode:=FDescriptors.FindKey(DescPtr,FOnCompareDescPtrWithDescriptor);
|
||||||
|
if ANode<>nil then
|
||||||
|
Result:=TBlockResourceCacheDescriptor(ANode.Data)
|
||||||
|
else
|
||||||
|
Result:=nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TBlockResourceCache.AddResource(Handle: THandle; DescPtr: Pointer
|
||||||
|
): TBlockResourceCacheDescriptor;
|
||||||
|
var
|
||||||
|
Item: TResourceCacheItem;
|
||||||
|
|
||||||
|
procedure RaiseDescriptorAlreadyAdded;
|
||||||
|
var
|
||||||
|
Msg: String;
|
||||||
|
i: Integer;
|
||||||
|
begin
|
||||||
|
Msg:='TBlockResourceCache.AddResource Descriptor Already Added '#13;
|
||||||
|
for i:=0 to DataSize-1 do
|
||||||
|
Msg:=Msg+hexstr(ord(PChar(DescPtr)[i]),2);
|
||||||
|
raise Exception.Create(Msg);
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Result:=FindDescriptor(DescPtr);
|
||||||
|
if Result<>nil then
|
||||||
|
RaiseDescriptorAlreadyAdded;
|
||||||
|
|
||||||
|
Item:=FindItem(Handle);
|
||||||
|
if Item=nil then begin
|
||||||
|
Item:=FResourceCacheItemClass.Create(Self,Handle);
|
||||||
|
FItems.Add(Item);
|
||||||
|
end;
|
||||||
|
Result:=TBlockResourceCacheDescriptor(
|
||||||
|
FResourceCacheDescriptorClass.Create(Self,Item));
|
||||||
|
ReAllocMem(Result.Data,DataSize);
|
||||||
|
System.Move(DescPtr^,Result.Data^,DataSize);
|
||||||
|
FDescriptors.Add(Result);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TBlockResourceCache.CompareDescriptors(Tree: TAvgLvlTree; Desc1,
|
||||||
|
Desc2: Pointer): integer;
|
||||||
|
begin
|
||||||
|
Result:=CompareMemRange(TBlockResourceCacheDescriptor(Desc1).Data,
|
||||||
|
TBlockResourceCacheDescriptor(Desc2).Data,
|
||||||
|
DataSize);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TBlockResourceCacheDescriptor }
|
||||||
|
|
||||||
|
destructor TBlockResourceCacheDescriptor.Destroy;
|
||||||
|
begin
|
||||||
|
ReAllocMem(Data,0);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
@ -185,6 +185,55 @@ ResourceString
|
|||||||
rsError = 'Error';
|
rsError = 'Error';
|
||||||
rsPickDate = 'Select a date';
|
rsPickDate = 'Select a date';
|
||||||
|
|
||||||
|
// I'm not sure if in all languages the Dialog texts for a button
|
||||||
|
// have the same meaning as a key
|
||||||
|
// So every VK gets its own constant
|
||||||
|
ifsVK_UNKNOWN = 'Unknown';
|
||||||
|
ifsVK_LBUTTON = 'Mouse Button Left';
|
||||||
|
ifsVK_RBUTTON = 'Mouse Button Right';
|
||||||
|
ifsVK_CANCEL = 'Cancel'; //= dlgCancel
|
||||||
|
ifsVK_MBUTTON = 'Mouse Button Middle';
|
||||||
|
ifsVK_BACK = 'Backspace';
|
||||||
|
ifsVK_TAB = 'Tab';
|
||||||
|
ifsVK_CLEAR = 'Clear';
|
||||||
|
ifsVK_RETURN = 'Return';
|
||||||
|
ifsVK_SHIFT = 'Shift';
|
||||||
|
ifsVK_CONTROL = 'Control';
|
||||||
|
ifsVK_MENU = 'Menu';
|
||||||
|
ifsVK_PAUSE = 'Pause key';
|
||||||
|
ifsVK_CAPITAL = 'Capital';
|
||||||
|
ifsVK_KANA = 'Kana';
|
||||||
|
ifsVK_JUNJA = 'Junja';
|
||||||
|
ifsVK_FINAL = 'Final';
|
||||||
|
ifsVK_HANJA = 'Hanja';
|
||||||
|
ifsVK_ESCAPE = 'Escape';
|
||||||
|
ifsVK_CONVERT = 'Convert';
|
||||||
|
ifsVK_NONCONVERT = 'Nonconvert';
|
||||||
|
ifsVK_ACCEPT = 'Accept';
|
||||||
|
ifsVK_MODECHANGE = 'Mode Change';
|
||||||
|
ifsVK_SPACE = 'Space key';
|
||||||
|
ifsVK_PRIOR = 'Prior';
|
||||||
|
ifsVK_NEXT = 'Next';
|
||||||
|
ifsVK_END = 'End';
|
||||||
|
ifsVK_HOME = 'Home';
|
||||||
|
ifsVK_LEFT = 'Left';
|
||||||
|
ifsVK_UP = 'Up';
|
||||||
|
ifsVK_RIGHT = 'Right';
|
||||||
|
ifsVK_DOWN = 'Down'; //= dlgdownword
|
||||||
|
ifsVK_SELECT = 'Select'; //= lismenuselect
|
||||||
|
ifsVK_PRINT = 'Print';
|
||||||
|
ifsVK_EXECUTE = 'Execute';
|
||||||
|
ifsVK_SNAPSHOT = 'Snapshot';
|
||||||
|
ifsVK_INSERT = 'Insert';
|
||||||
|
ifsVK_DELETE = 'Delete'; //= dlgeddelete
|
||||||
|
ifsVK_HELP = 'Help';
|
||||||
|
ifsVK_LWIN = 'left windows key';
|
||||||
|
ifsVK_RWIN = 'right windows key';
|
||||||
|
ifsVK_APPS = 'application key';
|
||||||
|
ifsVK_NUMPAD = 'Numpad %d';
|
||||||
|
ifsVK_NUMLOCK = 'Numlock';
|
||||||
|
ifsVK_SCROLL = 'Scroll';
|
||||||
|
|
||||||
implementation
|
implementation
|
||||||
|
|
||||||
end.
|
end.
|
||||||
|
|||||||
@ -23,7 +23,7 @@
|
|||||||
*****************************************************************************
|
*****************************************************************************
|
||||||
}
|
}
|
||||||
|
|
||||||
unit lMessages;
|
unit LMessages;
|
||||||
|
|
||||||
{$mode objfpc}{$H+}
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
@ -1080,6 +1080,9 @@ end.
|
|||||||
|
|
||||||
{
|
{
|
||||||
$Log$
|
$Log$
|
||||||
|
Revision 1.68 2004/08/11 20:57:09 mattias
|
||||||
|
moved intfstrconsts.pp to lclstrconsts.pas, implemented TPenHandleCache
|
||||||
|
|
||||||
Revision 1.67 2004/07/16 21:49:00 mattias
|
Revision 1.67 2004/07/16 21:49:00 mattias
|
||||||
added RTTI controls
|
added RTTI controls
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user