From af655e80831c60850e4a028c34fd2ec700e04f19 Mon Sep 17 00:00:00 2001 From: Mark van Renswoude Date: Wed, 13 Jun 2007 05:47:25 +0000 Subject: [PATCH] Added: X2UtImageInfo unit Added: X2UtPersist unit tests Changed: iif functions have default AIfFalse parameters Fixed: crash in TX2UtCustomPersist.Write when an object has no runtime type information --- UnitTests/Units/PersistTest.pas | 223 +++++++++++++++++++++++ UnitTests/X2UtUnitTests.bdsproj | 170 ++++++++++++++++++ UnitTests/X2UtUnitTests.cfg | 4 + UnitTests/X2UtUnitTests.dpr | 8 +- UnitTests/X2UtUnitTests.mes | 144 +++++++++++++++ X2UtGraphics.pas | 2 +- X2UtHashes.pas | 3 - X2UtImageInfo.pas | 304 ++++++++++++++++++++++++++++++++ X2UtMisc.pas | 6 +- X2UtPersist.pas | 6 +- 10 files changed, 859 insertions(+), 11 deletions(-) create mode 100644 UnitTests/Units/PersistTest.pas create mode 100644 UnitTests/X2UtUnitTests.bdsproj create mode 100644 UnitTests/X2UtUnitTests.mes create mode 100644 X2UtImageInfo.pas diff --git a/UnitTests/Units/PersistTest.pas b/UnitTests/Units/PersistTest.pas new file mode 100644 index 0000000..c1b5fec --- /dev/null +++ b/UnitTests/Units/PersistTest.pas @@ -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. + diff --git a/UnitTests/X2UtUnitTests.bdsproj b/UnitTests/X2UtUnitTests.bdsproj new file mode 100644 index 0000000..a0b1ce5 --- /dev/null +++ b/UnitTests/X2UtUnitTests.bdsproj @@ -0,0 +1,170 @@ + + + + + + + + + + + + X2UtUnitTests.dpr + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 1 + 1 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 1 + 1 + 1 + 1 + True + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + True + True + False + True + True + False + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + True + True + True + + + + 0 + 0 + False + 1 + True + False + False + 16384 + 1048576 + 4194304 + + + + + + + + ..\ + vcl;rtl;dbrtl;vcldb;vclx;dss;dsnapcrba;dsnapcon;inetdb;webdsnap;websnap;dbxcds;Irc;parsdpk;hotspotter + + + False + + + ip-to-country.csv countries.csv geo.db + + + False + + + True + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1043 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + diff --git a/UnitTests/X2UtUnitTests.cfg b/UnitTests/X2UtUnitTests.cfg index e5e8130..b98b518 100644 --- a/UnitTests/X2UtUnitTests.cfg +++ b/UnitTests/X2UtUnitTests.cfg @@ -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 diff --git a/UnitTests/X2UtUnitTests.dpr b/UnitTests/X2UtUnitTests.dpr index 8d1d7ec..f9acf7a 100644 --- a/UnitTests/X2UtUnitTests.dpr +++ b/UnitTests/X2UtUnitTests.dpr @@ -5,12 +5,14 @@ uses GUITestRunner, Variants, BitsTest in 'Units\BitsTest.pas', - HashesTest in 'Units\HashesTest.pas'; - //SettingsTest in 'Units\SettingsTest.pas', + HashesTest in 'Units\HashesTest.pas', + PersistTest in 'Units\PersistTest.pas'; + +//SettingsTest in 'Units\SettingsTest.pas', //IniParserTest in 'Units\IniParserTest.pas'; begin // MemChk(); RunRegisteredTests(); end. - \ No newline at end of file + diff --git a/UnitTests/X2UtUnitTests.mes b/UnitTests/X2UtUnitTests.mes new file mode 100644 index 0000000..285d55d --- /dev/null +++ b/UnitTests/X2UtUnitTests.mes @@ -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 diff --git a/X2UtGraphics.pas b/X2UtGraphics.pas index 2c3ee64..7a153df 100644 --- a/X2UtGraphics.pas +++ b/X2UtGraphics.pas @@ -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, diff --git a/X2UtHashes.pas b/X2UtHashes.pas index 4ccb6e9..24ba6b3 100644 --- a/X2UtHashes.pas +++ b/X2UtHashes.pas @@ -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; diff --git a/X2UtImageInfo.pas b/X2UtImageInfo.pas new file mode 100644 index 0000000..845e603 --- /dev/null +++ b/X2UtImageInfo.pas @@ -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. diff --git a/X2UtMisc.pas b/X2UtMisc.pas index d80cf9d..76c0944 100644 --- a/X2UtMisc.pas +++ b/X2UtMisc.pas @@ -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 diff --git a/X2UtPersist.pas b/X2UtPersist.pas index 711084d..117eede 100644 --- a/X2UtPersist.pas +++ b/X2UtPersist.pas @@ -94,8 +94,10 @@ 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); if propCount > 0 then