GitHub-Mirror/x2utils
1
0
Fork 0
mirror of synced 2024-12-22 01:03:07 +01:00
Code Issues Projects Releases Wiki Activity

Added: X2UtImageInfo unit

Browse Source 
Added: X2UtPersist unit tests
Changed: iif functions have default AIfFalse parameters
Fixed: crash in TX2UtCustomPersist.Write when an object has no runtime type information
This commit is contained in:
Mark van Renswoude 2007-06-13 05:47:25 +00:00
parent b86e2def4a
commit af655e8083
10 changed files with 859 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

223
UnitTests/Units/PersistTest.pas Normal file
View File

@ -0,0 +1,223 @@
unit PersistTest;
interface
uses
Classes,
TestFramework;
type
TPersistTest = class(TTestCase)
published
procedure WriteNoTypeInfo;
procedure WriteSimpleTypes;
end;
implementation
uses
SysUtils,
X2UtPersist;
type
TX2UtPersistTest = class(TX2CustomPersist)
private
FOutput: TStrings;
protected
function BeginSection(const AName: String): Boolean; override;
procedure EndSection(); override;
function ReadFloat(const AName: String; out AValue: Extended): Boolean; override;
function ReadInt64(const AName: String; out AValue: Int64): Boolean; override;
function ReadInteger(const AName: String; out AValue: Integer): Boolean; override;
function ReadString(const AName: String; out AValue: String): Boolean; override;
function WriteFloat(const AName: String; AValue: Extended): Boolean; override;
function WriteInt64(const AName: String; AValue: Int64): Boolean; override;
function WriteInteger(const AName: String; AValue: Integer): Boolean; override;
function WriteString(const AName: String; const AValue: String): Boolean; override;
public
constructor Create();
destructor Destroy(); override;
procedure Write(AObject: TObject); override;
property Output: TStrings read FOutput;
end;
TTypeInfoLess = class(TObject)
end;
TSimpleTypes = class(TPersistent)
private
FBooleanValue: Boolean;
FFloatValue: Double;
FInt64Value: Int64;
FIntValue: Integer;
FStringValue: String;
public
constructor Create();
published
property BooleanValue: Boolean read FBooleanValue write FBooleanValue;
property FloatValue: Double read FFloatValue write FFloatValue;
property Int64Value: Int64 read FInt64Value write FInt64Value;
property IntValue: Integer read FIntValue write FIntValue;
property StringValue: String read FStringValue write FStringValue;
end;
{ TSimpleTypes }
constructor TSimpleTypes.Create();
begin
inherited;
FIntValue := 42;
end;
{ TPersistTest }
procedure TPersistTest.WriteNoTypeInfo;
var
testObject: TTypeInfoLess;
begin
testObject := TTypeInfoLess.Create;
try
with TX2UtPersistTest.Create do
try
Write(testObject);
CheckEquals('', Output.Text);
finally
Free;
end;
finally
FreeAndNil(testObject);
end;
end;
procedure TPersistTest.WriteSimpleTypes;
var
testObject: TSimpleTypes;
begin
testObject := TSimpleTypes.Create;
try
with TX2UtPersistTest.Create do
try
Write(testObject);
CheckEquals('Integer:42'#13#10, Output.Text);
finally
Free;
end;
finally
FreeAndNil(testObject);
end;
end;
{ TX2UtPersistTest }
constructor TX2UtPersistTest.Create();
begin
inherited;
FOutput := TStringList.Create();
end;
destructor TX2UtPersistTest.Destroy();
begin
FreeAndNil(FOutput);
inherited;
end;
procedure TX2UtPersistTest.Write(AObject: TObject);
begin
Output.Clear();
inherited;
end;
function TX2UtPersistTest.BeginSection(const AName: String): Boolean;
begin
Result := inherited BeginSection(AName);
if Result then
Output.Add(AName + ' {');
end;
procedure TX2UtPersistTest.EndSection();
begin
Output.Add('}');
inherited EndSection();
end;
function TX2UtPersistTest.ReadFloat(const AName: String; out AValue: Extended): Boolean;
begin
Result := False;
end;
function TX2UtPersistTest.ReadInt64(const AName: String; out AValue: Int64): Boolean;
begin
Result := False;
end;
function TX2UtPersistTest.ReadInteger(const AName: String; out AValue: Integer): Boolean;
begin
Result := False;
end;
function TX2UtPersistTest.ReadString(const AName: String; out AValue: String): Boolean;
begin
Result := False;
end;
function TX2UtPersistTest.WriteFloat(const AName: String; AValue: Extended): Boolean;
begin
Output.Add(Format('Float:%.2f', [AValue]));
Result := True;
end;
function TX2UtPersistTest.WriteInt64(const AName: String; AValue: Int64): Boolean;
begin
Output.Add(Format('Int64:%d', [AValue]));
Result := True;
end;
function TX2UtPersistTest.WriteInteger(const AName: String; AValue: Integer): Boolean;
begin
Output.Add(Format('Integer:%d', [AValue]));
Result := True;
end;
function TX2UtPersistTest.WriteString(const AName, AValue: String): Boolean;
begin
Output.Add(Format('String:%s', [AValue]));
Result := True;
end;
initialization
RegisterTest(TPersistTest.Suite);
end.

170
UnitTests/X2UtUnitTests.bdsproj Normal file
View File

@ -0,0 +1,170 @@
<?xml version="1.0" encoding="utf-8"?>
<BorlandProject>
<PersonalityInfo>
<Option>
<Option Name="Personality">Delphi.Personality</Option>
<Option Name="ProjectType">VCLApplication</Option>
<Option Name="Version">1.0</Option>
<Option Name="GUID">{8BEE0E67-704C-4611-9014-0F8CC2FB0289}</Option>
</Option>
</PersonalityInfo>
<Delphi.Personality>
<Source>
<Source Name="MainSource">X2UtUnitTests.dpr</Source>
</Source>
<FileVersion>
<FileVersion Name="Version">7.0</FileVersion>
</FileVersion>
<Compiler>
<Compiler Name="A">8</Compiler>
<Compiler Name="B">0</Compiler>
<Compiler Name="C">1</Compiler>
<Compiler Name="D">1</Compiler>
<Compiler Name="E">0</Compiler>
<Compiler Name="F">0</Compiler>
<Compiler Name="G">1</Compiler>
<Compiler Name="H">1</Compiler>
<Compiler Name="I">1</Compiler>
<Compiler Name="J">1</Compiler>
<Compiler Name="K">0</Compiler>
<Compiler Name="L">1</Compiler>
<Compiler Name="M">0</Compiler>
<Compiler Name="N">1</Compiler>
<Compiler Name="O">1</Compiler>
<Compiler Name="P">1</Compiler>
<Compiler Name="Q">0</Compiler>
<Compiler Name="R">0</Compiler>
<Compiler Name="S">0</Compiler>
<Compiler Name="T">0</Compiler>
<Compiler Name="U">0</Compiler>
<Compiler Name="V">1</Compiler>
<Compiler Name="W">1</Compiler>
<Compiler Name="X">1</Compiler>
<Compiler Name="Y">1</Compiler>
<Compiler Name="Z">1</Compiler>
<Compiler Name="ShowHints">True</Compiler>
<Compiler Name="ShowWarnings">True</Compiler>
<Compiler Name="UnitAliases">WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;</Compiler>
<Compiler Name="NamespacePrefix"></Compiler>
<Compiler Name="GenerateDocumentation">False</Compiler>
<Compiler Name="DefaultNamespace"></Compiler>
<Compiler Name="SymbolDeprecated">True</Compiler>
<Compiler Name="SymbolLibrary">True</Compiler>
<Compiler Name="SymbolPlatform">False</Compiler>
<Compiler Name="SymbolExperimental">True</Compiler>
<Compiler Name="UnitLibrary">True</Compiler>
<Compiler Name="UnitPlatform">False</Compiler>
<Compiler Name="UnitDeprecated">True</Compiler>
<Compiler Name="UnitExperimental">True</Compiler>
<Compiler Name="HResultCompat">True</Compiler>
<Compiler Name="HidingMember">True</Compiler>
<Compiler Name="HiddenVirtual">True</Compiler>
<Compiler Name="Garbage">True</Compiler>
<Compiler Name="BoundsError">True</Compiler>
<Compiler Name="ZeroNilCompat">True</Compiler>
<Compiler Name="StringConstTruncated">True</Compiler>
<Compiler Name="ForLoopVarVarPar">True</Compiler>
<Compiler Name="TypedConstVarPar">True</Compiler>
<Compiler Name="AsgToTypedConst">True</Compiler>
<Compiler Name="CaseLabelRange">True</Compiler>
<Compiler Name="ForVariable">True</Compiler>
<Compiler Name="ConstructingAbstract">True</Compiler>
<Compiler Name="ComparisonFalse">True</Compiler>
<Compiler Name="ComparisonTrue">True</Compiler>
<Compiler Name="ComparingSignedUnsigned">True</Compiler>
<Compiler Name="CombiningSignedUnsigned">True</Compiler>
<Compiler Name="UnsupportedConstruct">True</Compiler>
<Compiler Name="FileOpen">True</Compiler>
<Compiler Name="FileOpenUnitSrc">True</Compiler>
<Compiler Name="BadGlobalSymbol">True</Compiler>
<Compiler Name="DuplicateConstructorDestructor">True</Compiler>
<Compiler Name="InvalidDirective">True</Compiler>
<Compiler Name="PackageNoLink">True</Compiler>
<Compiler Name="PackageThreadVar">True</Compiler>
<Compiler Name="ImplicitImport">True</Compiler>
<Compiler Name="HPPEMITIgnored">True</Compiler>
<Compiler Name="NoRetVal">True</Compiler>
<Compiler Name="UseBeforeDef">True</Compiler>
<Compiler Name="ForLoopVarUndef">True</Compiler>
<Compiler Name="UnitNameMismatch">True</Compiler>
<Compiler Name="NoCFGFileFound">True</Compiler>
<Compiler Name="ImplicitVariants">True</Compiler>
<Compiler Name="UnicodeToLocale">True</Compiler>
<Compiler Name="LocaleToUnicode">True</Compiler>
<Compiler Name="ImagebaseMultiple">True</Compiler>
<Compiler Name="SuspiciousTypecast">True</Compiler>
<Compiler Name="PrivatePropAccessor">True</Compiler>
<Compiler Name="UnsafeType">False</Compiler>
<Compiler Name="UnsafeCode">False</Compiler>
<Compiler Name="UnsafeCast">False</Compiler>
<Compiler Name="OptionTruncated">True</Compiler>
<Compiler Name="WideCharReduced">True</Compiler>
<Compiler Name="DuplicatesIgnored">True</Compiler>
<Compiler Name="UnitInitSeq">True</Compiler>
<Compiler Name="LocalPInvoke">True</Compiler>
<Compiler Name="MessageDirective">True</Compiler>
<Compiler Name="CodePage"></Compiler>
</Compiler>
<Linker>
<Linker Name="MapFile">0</Linker>
<Linker Name="OutputObjs">0</Linker>
<Linker Name="GenerateHpps">False</Linker>
<Linker Name="ConsoleApp">1</Linker>
<Linker Name="DebugInfo">True</Linker>
<Linker Name="RemoteSymbols">False</Linker>
<Linker Name="GenerateDRC">False</Linker>
<Linker Name="MinStackSize">16384</Linker>
<Linker Name="MaxStackSize">1048576</Linker>
<Linker Name="ImageBase">4194304</Linker>
<Linker Name="ExeDescription"></Linker>
</Linker>
<Directories>
<Directories Name="OutputDir"></Directories>
<Directories Name="UnitOutputDir"></Directories>
<Directories Name="PackageDLLOutputDir"></Directories>
<Directories Name="PackageDCPOutputDir"></Directories>
<Directories Name="SearchPath">..\</Directories>
<Directories Name="Packages">vcl;rtl;dbrtl;vcldb;vclx;dss;dsnapcrba;dsnapcon;inetdb;webdsnap;websnap;dbxcds;Irc;parsdpk;hotspotter</Directories>
<Directories Name="Conditionals"></Directories>
<Directories Name="DebugSourceDirs"></Directories>
<Directories Name="UsePackages">False</Directories>
</Directories>
<Parameters>
<Parameters Name="RunParams">ip-to-country.csv countries.csv geo.db</Parameters>
<Parameters Name="HostApplication"></Parameters>
<Parameters Name="Launcher"></Parameters>
<Parameters Name="UseLauncher">False</Parameters>
<Parameters Name="DebugCWD"></Parameters>
<Parameters Name="Debug Symbols Search Path"></Parameters>
<Parameters Name="LoadAllSymbols">True</Parameters>
<Parameters Name="LoadUnspecifiedSymbols">False</Parameters>
</Parameters>
<VersionInfo>
<VersionInfo Name="IncludeVerInfo">False</VersionInfo>
<VersionInfo Name="AutoIncBuild">False</VersionInfo>
<VersionInfo Name="MajorVer">1</VersionInfo>
<VersionInfo Name="MinorVer">0</VersionInfo>
<VersionInfo Name="Release">0</VersionInfo>
<VersionInfo Name="Build">0</VersionInfo>
<VersionInfo Name="Debug">False</VersionInfo>
<VersionInfo Name="PreRelease">False</VersionInfo>
<VersionInfo Name="Special">False</VersionInfo>
<VersionInfo Name="Private">False</VersionInfo>
<VersionInfo Name="DLL">False</VersionInfo>
<VersionInfo Name="Locale">1043</VersionInfo>
<VersionInfo Name="CodePage">1252</VersionInfo>
</VersionInfo>
<VersionInfoKeys>
<VersionInfoKeys Name="CompanyName"></VersionInfoKeys>
<VersionInfoKeys Name="FileDescription"></VersionInfoKeys>
<VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="InternalName"></VersionInfoKeys>
<VersionInfoKeys Name="LegalCopyright"></VersionInfoKeys>
<VersionInfoKeys Name="LegalTrademarks"></VersionInfoKeys>
<VersionInfoKeys Name="OriginalFilename"></VersionInfoKeys>
<VersionInfoKeys Name="ProductName"></VersionInfoKeys>
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="Comments"></VersionInfoKeys>
</VersionInfoKeys>
</Delphi.Personality>
</BorlandProject>

4
UnitTests/X2UtUnitTests.cfg
View File

@ -34,6 +34,10 @@
-K$00400000
-LE"C:\Documents and Settings\PsychoMark\My Documents\Borland Studio Projects\Bpl"
-LN"C:\Documents and Settings\PsychoMark\My Documents\Borland Studio Projects\Bpl"
-U"..\"
-O"..\"
-I"..\"
-R"..\"
-w-SYMBOL_PLATFORM
-w-UNIT_PLATFORM
-w-UNSAFE_TYPE

4
UnitTests/X2UtUnitTests.dpr
View File

@ -5,7 +5,9 @@ uses
GUITestRunner,
Variants,
BitsTest in 'Units\BitsTest.pas',
HashesTest in 'Units\HashesTest.pas';
HashesTest in 'Units\HashesTest.pas',
PersistTest in 'Units\PersistTest.pas';
//SettingsTest in 'Units\SettingsTest.pas',
//IniParserTest in 'Units\IniParserTest.pas';

144
UnitTests/X2UtUnitTests.mes Normal file
View File

@ -0,0 +1,144 @@
[GeneralSettings]
HandleExceptions=0
AppendMapFileToBinary=1
NoOwnMadExceptSettings=0
CheckFileCrc=1
CheckForFrozenMainThread=0
FreezeTimeout=60000
AutomaticallySaveBugReport=0
AutoSaveBugReportIfNotSent=1
AutomaticallyMailBugReport=0
AutoMailProgressBox=0
CopyBugReportToClipboard=0
SuspendAllRunningThreads=0
ShowPleaseWaitBox=1
PleaseWaitIcon=plwait1
AutomaticallyContinueApplication=0
AutomaticallyRestartApplication=0
AutomaticallyCloseApplication=0
MailAddress=
SendInBackground=0
Send32Icon=send321
MailAsSmtpServer=0
MailAsSmtpClient=0
UploadViaHttp=0
MailViaMapi=0
MailViaMailto=0
SmtpServer=
SmtpPort=25
SmtpAccount=
SmtpPassword=
HttpServer=
HttpPort=80
HttpAccount=
HttpPassword=
BugReportFile=bugreport.txt
AttachBugReport=0
AttachBugReportFile=1
DeleteBugReportFile=1
BugReportSendAs=bugreport.txt
BugReportZip=
ScreenShotDepth=0
ScreenShotAppOnly=0
ScreenShotSendAs=screenshot.png
ScreenShotZip=
AdditionalAttachments=
AppendBugReports=1
BugReportFileSize=100000
DontSaveDuplicateExceptions=1
DontSaveDuplicateFreezings=1
DuplicateExceptionDefinition=1
DuplicateFreezeDefinition=2
ShowExceptionBox=1
OkBtnText=&OK
DetailsBtnText=&Details
PleaseWaitTitle=Information
PleaseWaitText=Please wait a moment...
MailSubject=bug report
MailBody=please find the bug report attached
SendBoxTitle=Sending bug report...
PrepareAttachMsg=Preparing attachments...
MxLookupMsg=Searching for mail server...
ConnectMsg=Connecting to server...
AuthMsg=Authentication...
SendMailMsg=Sending mail...
FieldsMsg=Setting fields...
SendAttachMsg=Sending attachments...
SendFinalizeMsg=Finalizing...
MailFailureMsg=Sorry, sending the bug report didn't work.
VersionVariable=
[ExceptionBox]
ShowButtonMailBugReport=0
ShowButtonSaveBugReport=0
ShowButtonPrintBugReport=0
ShowButtonShowBugReport=1
ShowButtonContinueApplication=1
ShowButtonRestartApplication=1
ShowButtonCloseApplication=1
IconButtonSendBugReport=send1
IconButtonSaveBugReport=save1
IconButtonPrintBugReport=print1
IconButtonShowBugReport=show1
IconButtonContinueApplication=continue1
IconButtonCantContinueApplication=cantContinue1
IconButtonRestartApplication=restart1
IconButtonCloseApplication=close1
FocusedButton=3
SendAssistant=SendAssistant
SaveAssistant=SaveAssistant
PrintAssistant=PrintAssistant
AutomaticallyShowBugReport=0
NoOwnerDrawButtons=0
BigExceptionIcon=big1
TitleBar=%25appname%25
ExceptionMessage=An error occurred in the application.
FrozenMessage=The application seems to be frozen.
BitFaultMsg=The file "%25modname%25" seems to be corrupt!
MailBugReportText=send bug report
SaveBugReportText=save bug report
PrintBugReportText=print bug report
ShowBugReportText=show bug report
ContinueApplicationText=continue application
RestartApplicationText=restart application
CloseApplicationText=close application
[BugReport]
ListThreads=1
ListModules=1
ListHardware=1
ShowCpuRegisters=0
ShowStackDump=0
Disassembly=0
HideUglyItems=0
ShowRelativeAddrs=1
ShowRelativeLines=1
FormatDisassembly=0
LimitDisassembly=5
EnabledPlugins=modules|processes|hardware
[Filters]
Filter1ExceptionClasses=EDBEditError
Filter1DontCreateBugReport=1
Filter1DontCreateScreenshot=1
Filter1DontSuspendThreads=1
Filter1DontCallHandlers=1
Filter1ShowBox=3
Filter1Assis=
Filter2ExceptionClasses=
Filter2DontCreateBugReport=0
Filter2DontCreateScreenshot=0
Filter2DontSuspendThreads=0
Filter2DontCallHandlers=0
Filter2ShowBox=0
Filter2Assis=
GeneralDontCreateBugReport=0
GeneralDontCreateScreenshot=0
GeneralDontSuspendThreads=0
GeneralDontCallHandlers=0
GeneralShowBox=0
GeneralAssis=
[Assistants]
Assistant1=SendAssistant|Send Assistant|ContactForm|DetailsForm|ScrShotForm
Assistant2=SaveAssistant|Save Assistant|ContactForm|DetailsForm
Assistant3=PrintAssistant|Print Assistant|ContactForm|DetailsForm
Forms1=TPF0%0eTMEContactForm%0bContactForm%07Message%0c%13%00%00%00Contact Information%08MinWidth%04%00%00%00%00%08OnAction%0c%1b%00%00%00madExcept.HandleContactForm%05Timer%04%00%00%00%00%00%09INVButton%0bContinueBtn%07Caption%0c%08%00%00%00Continue%07Enabled%09%0bNoOwnerDraw%08%00%00%09INVButton%07SkipBtn%07Caption%0c%04%00%00%00Skip%07Enabled%08%0bNoOwnerDraw%08%00%00%09INVButton%08AbortBtn%07Caption%0c%05%00%00%00Abort%07Enabled%09%0bNoOwnerDraw%08%00%00%08INVLabel%06Label1%07Caption%0c%0a%00%00%00your name:%07Enabled%09%07Spacing%04%00%00%00%00%00%00%07INVEdit%08NameEdit%07Enabled%09%05Lines%04%01%00%00%00%08Optional%09%0aOutputName%0c%0c%00%00%00contact name%0aOutputType%07%09nvoHeader%07Spacing%04%00%00%00%00%04Text%0c%00%00%00%00%00%00%08INVLabel%06Label2%07Caption%0c%0b%00%00%00your email:%07Enabled%09%07Spacing%04%00%00%00%00%00%00%07INVEdit%09EmailEdit%07Enabled%09%05Lines%04%01%00%00%00%08Optional%08%0aOutputName%0c%0d%00%00%00contact email%0aOutputType%07%09nvoHeader%07Spacing%04%00%00%00%00%04Text%0c%00%00%00%00%00%00%0bINVCheckBox%08MemCheck%07Checked%08%07Enabled%09%0aOutputName%0c%00%00%00%00%07Spacing%04%00%00%00%00%04Text%0c%09%00%00%00some text%00%00%00
Forms2=TPF0%0eTMEDetailsForm%0bDetailsForm%07Message%0c%0d%00%00%00Error Details%08MinWidth%04%00%00%00%00%08OnAction%0c%00%00%00%00%05Timer%04%00%00%00%00%00%09INVButton%0bContinueBtn%07Caption%0c%08%00%00%00Continue%07Enabled%09%0bNoOwnerDraw%08%00%00%09INVButton%07SkipBtn%07Caption%0c%04%00%00%00Skip%07Enabled%09%0bNoOwnerDraw%08%00%00%09INVButton%08AbortBtn%07Caption%0c%05%00%00%00Abort%07Enabled%09%0bNoOwnerDraw%08%00%00%08INVLabel%06Label1%07Caption%0c'%00%00%00in which situation did the error occur?%07Enabled%09%07Spacing%04%00%00%00%00%00%00%07INVEdit%0bDetailsMemo%07Enabled%09%05Lines%04%09%00%00%00%08Optional%08%0aOutputName%0c%0d%00%00%00error details%0aOutputType%07%0dnvoOwnSection%07Spacing%04%00%00%00%00%04Text%0c%00%00%00%00%00%00%00
Forms3=TPF0%0eTMEScrShotForm%0bScrShotForm%0dActiveControl%07%0bContinueBtn%07Message%0c%18%00%00%00Screenshot Configuration%08MinWidth%04%00%00%00%00%08OnAction%0c%1e%00%00%00madExcept.HandleScreenshotForm%05Timer%04%fa%00%00%00%00%09INVButton%0bContinueBtn%07Caption%0c%08%00%00%00Continue%07Enabled%09%0bNoOwnerDraw%08%00%00%09INVButton%07SkipBtn%07Caption%0c%04%00%00%00Skip%07Enabled%08%0bNoOwnerDraw%08%00%00%09INVButton%08AbortBtn%07Caption%0c%05%00%00%00Abort%07Enabled%09%0bNoOwnerDraw%08%00%00%0bINVCheckBox%0bAttachCheck%07Checked%09%07Enabled%09%0aOutputName%0c%00%00%00%00%07Spacing%04%00%00%00%00%04Text%0c%09%00%00%00some text%00%00%08INVImage%0aScrShotImg%06Border%09%09Clickable%09%07Enabled%09%04File%0c%00%00%00%00%06Height%04%00%00%00%00%07Spacing%04%00%00%00%00%05Width%04%00%00%00%00%00%00%08INVLabel%06Label1%07Caption%0c%15%00%00%00(click to edit image)%07Enabled%09%07Spacing%04%00%00%00%00%00%00%00

2
X2UtGraphics.pas
View File

@ -177,7 +177,7 @@ begin
cBack := ColorToRGB(ABackground);
cFore := ColorToRGB(AForeground);
iBack := 256 - AAlpha;
iFore := Succ(AAlpha);
iFore := AAlpha;
Result := RGB(((GetRValue(cBack) * iBack) +
(GetRValue(cFore) * iFore)) shr 8,

3
X2UtHashes.pas
View File

@ -238,9 +238,6 @@ type
FCursor: TX2HashCursor;
FKeyManager: TX2CustomHashManager;
FValueManager: TX2CustomHashManager;
FKeys: TObject;
FValues: TObject;
protected
function CreateCursor(): TX2HashCursor; virtual;
function CreateKeyManager(): TX2CustomHashManager; virtual; abstract;

304
X2UtImageInfo.pas Normal file
View File

@ -0,0 +1,304 @@
unit X2UtImageInfo;
interface
uses
Windows,
SysUtils,
Classes,
Graphics;
type
TX2ImageType = (itUnknown, itBMP, itGIF, itJPG, itPNG);
TX2ImageInfo = record
ImgType: TX2ImageType;
Width: Cardinal;
Height: Cardinal;
end;
function GetImageInfo(const AFilename: String): TX2ImageInfo; overload;
function GetImageInfo(const AStream: TStream): TX2ImageInfo; overload;
function GetImageSize(const AFilename: String): TSize; overload;
function GetImageSize(const AStream: TStream): TSize; overload;
function GetImageType(const AFilename: String): TX2ImageType; overload;
function GetImageType(const AStream: TStream): TX2ImageType; overload;
implementation
uses
Math,
Types;
type
TGetDimensionsProc = procedure(const ASource: TStream; var AImageInfo: TX2ImageInfo);
TCardinal = record
case Byte of
0: (Value: Cardinal);
1: (Byte1, Byte2, Byte3, Byte4: Byte);
end;
TWord = record
case Byte of
0: (Value: Word);
1: (Byte1, Byte2: Byte);
end;
TPNGIHDRChunk = packed record
Width: Cardinal;
Height: Cardinal;
Bitdepth: Byte;
Colortype: Byte;
Compression: Byte;
Filter: Byte;
Interlace: Byte;
end;
TGIFHeader = packed record
Signature: array[0..2] of Char;
Version: array[0..2] of Char;
Width: Word;
Height: Word;
end;
TJPGChunk = record
ID: Word;
Length: Word;
end;
TJPGHeader = packed record
Reserved: Byte;
Height: Word;
Width: Word;
end;
const
SIG_BMP: array[0..1] of Char = ('B', 'M');
SIG_GIF: array[0..2] of Char = ('G', 'I', 'F');
SIG_JPG: array[0..2] of Char = (#255, #216, #255);
SIG_PNG: array[0..7] of Char = (#137, #80, #78, #71, #13, #10, #26, #10);
function SwapBytes(const ASource: Cardinal): Cardinal; overload;
var
mwSource: TCardinal;
mwDest: TCardinal;
begin
mwSource.Value := ASource;
mwDest.Byte1 := mwSource.Byte4;
mwDest.Byte2 := mwSource.Byte3;
mwDest.Byte3 := mwSource.Byte2;
mwDest.Byte4 := mwSource.Byte1;
Result := mwDest.Value;
end;
function SwapBytes(const ASource: Word): Word; overload;
var
mwSource: TWord;
mwDest: TWord;
begin
mwSource.Value := ASource;
mwDest.Byte1 := mwSource.Byte2;
mwDest.Byte2 := mwSource.Byte1;
Result := mwDest.Value;
end;
procedure GetBMPDimensions(const ASource: TStream; var AImageInfo: TX2ImageInfo);
var
bmpFileHeader: TBitmapFileHeader;
bmpInfoHeader: TBitmapInfoHeader;
begin
FillChar(bmpFileHeader, SizeOf(TBitmapFileHeader), #0);
FillChar(bmpInfoHeader, SizeOf(TBitmapInfoHeader), #0);
ASource.Read(bmpFileHeader, SizeOf(TBitmapFileHeader));
ASource.Read(bmpInfoHeader, SizeOf(TBitmapInfoHeader));
AImageInfo.Width := bmpInfoHeader.biWidth;
AImageInfo.Height := bmpInfoHeader.biHeight;
end;
procedure GetGIFDimensions(const ASource: TStream; var AImageInfo: TX2ImageInfo);
var
gifHeader: TGIFHeader;
begin
FillChar(gifHeader, SizeOf(TGIFHeader), #0);
ASource.Read(gifHeader, SizeOf(TGIFHeader));
AImageInfo.Width := gifHeader.Width;
AImageInfo.Height := gifHeader.Height;
end;
procedure GetJPGDimensions(const ASource: TStream; var AImageInfo: TX2ImageInfo);
var
cSig: array[0..1] of Char;
jpgChunk: TJPGChunk;
jpgHeader: TJPGHeader;
iSize: Integer;
iRead: Integer;
begin
FillChar(cSig, SizeOf(cSig), #0);
// Read signature
ASource.Read(cSig, SizeOf(cSig));
iSize := SizeOf(TJPGChunk);
repeat
// Read chunk header
FillChar(jpgChunk, iSize, #0);
iRead := ASource.Read(jpgChunk, iSize);
if iRead <> iSize then
break;
if jpgChunk.ID = $C0FF then begin
ASource.Read(jpgHeader, SizeOf(TJPGHeader));
AImageInfo.Width := SwapBytes(jpgHeader.Width);
AImageInfo.Height := SwapBytes(jpgHeader.Height);
break;
end else
ASource.Position := ASource.Position + (SwapBytes(jpgChunk.Length) - 2);
until False;
end;
procedure GetPNGDimensions(const ASource: TStream; var AImageInfo: TX2ImageInfo);
var
cSig: array[0..7] of Char;
cChunkLen: Cardinal;
cChunkType: array[0..3] of Char;
ihdrData: TPNGIHDRChunk;
begin
FillChar(cSig, SizeOf(cSig), #0);
FillChar(cChunkType, SizeOf(cChunkType), #0);
// Read signature
ASource.Read(cSig, SizeOf(cSig));
// Read IHDR chunk length
cChunkLen := 0;
ASource.Read(cChunkLen, SizeOf(Cardinal));
cChunkLen := SwapBytes(cChunkLen);
if cChunkLen = SizeOf(TPNGIHDRChunk) then begin
// Verify IHDR chunk type
ASource.Read(cChunkType, SizeOf(cChunkType));
if AnsiUpperCase(cChunkType) = 'IHDR' then begin
// Read IHDR data
FillChar(ihdrData, SizeOf(TPNGIHDRChunk), #0);
ASource.Read(ihdrData, SizeOf(TPNGIHDRChunk));
AImageInfo.Width := SwapBytes(ihdrData.Width);
AImageInfo.Height := SwapBytes(ihdrData.Height);
end;
end;
end;
function GetImageInfo(const AFilename: String): TX2ImageInfo;
var
fsImage: TFileStream;
begin
fsImage := TFileStream.Create(AFilename, fmOpenRead or fmShareDenyWrite);
try
Result := GetImageInfo(fsImage);
finally
FreeAndNil(fsImage);
end;
end;
function GetImageInfo(const AStream: TStream): TX2ImageInfo;
var
iPos: Integer;
cBuffer: array[0..2] of Char;
cPNGBuffer: array[0..4] of Char;
GetDimensionsProc: TGetDimensionsProc;
begin
GetDimensionsProc := nil;
Result.ImgType := itUnknown;
Result.Width := 0;
Result.Height := 0;
FillChar(cBuffer, SizeOf(cBuffer), #0);
FillChar(cPNGBuffer, SizeOf(cPNGBuffer), #0);
iPos := AStream.Position;
AStream.Read(cBuffer, SizeOf(cBuffer));
if cBuffer = SIG_GIF then begin
{ GIF }
Result.ImgType := itGIF;
GetDimensionsProc := GetGIFDimensions;
end else if cBuffer = SIG_JPG then begin
{ JPG }
Result.ImgType := itJPG;
GetDimensionsProc := GetJPGDimensions;
end else if cBuffer = Copy(SIG_PNG, 1, 3) then begin
{ PNG }
AStream.Read(cPNGBuffer, SizeOf(cPNGBuffer));
if cPNGBuffer = Copy(SIG_PNG, 4, 5) then begin
Result.ImgType := itPNG;
GetDimensionsProc := GetPNGDimensions;
end;
end else if Copy(cBuffer, 1, 2) = SIG_BMP then begin
{ Bitmap }
Result.ImgType := itBMP;
GetDimensionsProc := GetBMPDimensions;
end;
AStream.Position := iPos;
if Assigned(GetDimensionsProc) then begin
GetDimensionsProc(AStream, Result);
AStream.Position := iPos;
end;
end;
function GetImageSize(const AFilename: String): TSize;
begin
with GetImageInfo(AFilename) do
begin
Result.cx := Width;
Result.cy := Height;
end;
end;
function GetImageSize(const AStream: TStream): TSize;
begin
with GetImageInfo(AStream) do
begin
Result.cx := Width;
Result.cy := Height;
end;
end;
function GetImageType(const AFilename: String): TX2ImageType;
begin
Result := GetImageInfo(AFilename).ImgType;
end;
function GetImageType(const AStream: TStream): TX2ImageType;
begin
Result := GetImageInfo(AStream).ImgType;
end;
end.

6
X2UtMisc.pas
View File

@ -10,10 +10,12 @@ unit X2UtMisc;
interface
//:$ Returns IfTrue or IfFalse depending on the Value
function iif(const AValue: Boolean; const AIfTrue, AIfFalse: Integer): Integer; overload;
function iif(const AValue: Boolean; const AIfTrue: Integer;
const AIfFalse: Integer = 0): Integer; overload;
//:$ Returns IfTrue or IfFalse depending on the Value
function iif(const AValue: Boolean; const AIfTrue, AIfFalse: String): String; overload;
function iif(const AValue: Boolean; const AIfTrue: String;
const AIfFalse: String = ''): String; overload;
//:$ Compares two integers
//:: Returns 0 if the values are equal, 1 if Value1 is greater than Value2 and

4
X2UtPersist.pas
View File

@ -94,7 +94,9 @@ var
continue: Boolean;
begin
Result := True;
Result := (AObject.ClassInfo <> nil);
if not Result then
Exit;
{ Iterate through published properties }
propCount := GetPropList(AObject.ClassInfo, tkProperties, nil);