unit GR32_PortableNetworkGraphic; (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 or LGPL 2.1 with linking exception * * The contents of this file are subject to the Mozilla Public License Version * 1.1 (the "License"); you may not use this file except in compliance with * the License. You may obtain a copy of the License at * http://www.mozilla.org/MPL/ * * Software distributed under the License is distributed on an "AS IS" basis, * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License * for the specific language governing rights and limitations under the * License. * * Alternatively, the contents of this file may be used under the terms of the * Free Pascal modified version of the GNU Lesser General Public License * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions * of this license are applicable instead of those above. * Please see the file LICENSE.txt for additional information concerning this * license. * * The Original Code is GR32PNG for Graphics32 * * The Initial Developer of the Original Code is * Christian-W. Budde * * Portions created by the Initial Developer are Copyright (C) 2000-2009 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) interface {$include GR32.inc} {$include GR32_PngCompilerSwitches.inc} // The following defines controls if the corresponding incomplete chunk // implementations should be enabled. They are disabled by default because // a complete implementation is required in order to pass the roundtrip unit // tests. {-$define PNG_CHUNK_SUGGESTED_PALETTE} {-$define PNG_CHUNK_INTERNATIONAL_TEXT} uses Classes, Graphics, SysUtils, {$IFDEF FPC} ZBase, ZDeflate, ZInflate; {$ELSE} {$IFDEF ZLibEx} ZLibEx, ZLibExApi; {$ELSE} {$if (CompilerVersion >= 32)} System.zlib; {$else} zlib; {$ifend} {$ENDIF} {$ENDIF} type {$A1} TColorType = ( ctGrayscale = 0, ctTrueColor = 2, ctIndexedColor = 3, ctGrayscaleAlpha = 4, ctTrueColorAlpha = 6 ); TFilterMethod = ( fmAdaptiveFilter = 0 ); TAdaptiveFilterMethod = ( afmNone = 0, afmSub = 1, afmUp = 2, afmAverage = 3, afmPaeth = 4 ); TAvailableAdaptiveFilterMethod = (aafmSub, aafmUp, aafmAverage, aafmPaeth); TAvailableAdaptiveFilterMethods = set of TAvailableAdaptiveFilterMethod; TInterlaceMethod = ( imNone = 0, imAdam7 = 1 ); TRGB24 = packed record R, G, B: Byte; end; PRGB24 = ^TRGB24; TRGB24Array = array [0..0] of TRGB24; PRGB24Array = ^TRGB24Array; TRGB24Word = packed record R, G, B : Word; end; PRGB24Word = ^TRGB24Word; TRGB32 = packed record R, G, B, A: Byte; end; PRGB32 = ^TRGB32; TRGB32Word = packed record R, G, B, A: Word; end; PRGB32Word = ^TRGB32Word; PByteArray = SysUtils.PByteArray; TByteArray = SysUtils.TByteArray; TChunkName = array [0..3] of AnsiChar; EPngError = class(Exception); {$IFDEF FPC} TZStreamRec = z_stream; {$ENDIF} {$A4} TCustomChunk = class abstract(TPersistent) protected function GetChunkNameAsString: AnsiString; virtual; abstract; function GetChunkName: TChunkName; virtual; abstract; function GetChunkSize: Cardinal; virtual; abstract; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); virtual; abstract; procedure WriteToStream(Stream: TStream); virtual; abstract; property ChunkName: TChunkName read GetChunkName; property ChunkNameAsString: AnsiString read GetChunkNameAsString; property ChunkSize: Cardinal read GetChunkSize; end; TCustomDefinedChunk = class abstract(TCustomChunk) protected function GetChunkNameAsString: AnsiString; override; function GetChunkName: TChunkName; override; class function GetClassChunkName: TChunkName; virtual; abstract; public property ChunkName: TChunkName read GetClassChunkName; end; TCustomDefinedChunkClass = class of TCustomDefinedChunk; TChunkPngImageHeader = class(TCustomDefinedChunk) private FWidth : Integer; FHeight : Integer; FBitDepth : Byte; FColorType : TColorType; FCompressionMethod : Byte; FFilterMethod : TFilterMethod; FInterlaceMethod : TInterlaceMethod; FAdaptiveFilterMethods : TAvailableAdaptiveFilterMethods; function GetHasPalette: Boolean; function GetBytesPerRow: Integer; function GetPixelByteSize: Integer; procedure SetCompressionMethod(const Value: Byte); procedure SetFilterMethod(const Value: TFilterMethod); procedure SetAdaptiveFilterMethods(const Value: TAvailableAdaptiveFilterMethods); protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public constructor Create; virtual; procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; procedure ResetToDefault; virtual; property Width: Integer read FWidth write FWidth; property Height: Integer read FHeight write FHeight; property BitDepth: Byte read FBitDepth write FBitDepth; property ColorType: TColorType read FColorType write FColorType; property CompressionMethod: Byte read FCompressionMethod write SetCompressionMethod; property AdaptiveFilterMethods: TAvailableAdaptiveFilterMethods read FAdaptiveFilterMethods write SetAdaptiveFilterMethods; property FilterMethod: TFilterMethod read FFilterMethod write SetFilterMethod; property InterlaceMethod: TInterlaceMethod read FInterlaceMethod write FInterlaceMethod; property HasPalette: Boolean read GetHasPalette; property BytesPerRow: Integer read GetBytesPerRow; property PixelByteSize: Integer read GetPixelByteSize; end; TCustomDefinedChunkWithHeader = class(TCustomDefinedChunk) protected FHeader : TChunkPngImageHeader; procedure AssignTo(Dest: TPersistent); override; public constructor Create(Header: TChunkPngImageHeader); reintroduce; virtual; procedure HeaderChanged; virtual; property Header: TChunkPngImageHeader read FHeader; end; TCustomDefinedChunkWithHeaderClass = class of TCustomDefinedChunkWithHeader; TChunkPngImageData = class(TCustomDefinedChunkWithHeader) private FData : TMemoryStream; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public constructor Create(Header: TChunkPngImageHeader); override; destructor Destroy; override; procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property Data: TMemoryStream read FData; end; TChunkPngPalette = class(TCustomDefinedChunkWithHeader) private FPaletteEntries : array of TRGB24; function GetPaletteEntry(Index: Cardinal): TRGB24; function GetCount: Cardinal; procedure SetCount(const Value: Cardinal); procedure SetPaletteEntry(Index: Cardinal; const Value: TRGB24); protected procedure AssignTo(Dest: TPersistent); override; class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure PaletteEntriesChanged; virtual; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property PaletteEntry[Index: Cardinal]: TRGB24 read GetPaletteEntry write SetPaletteEntry; default; property Count: Cardinal read GetCount write SetCount; end; TChunkPngGamma = class(TCustomDefinedChunkWithHeader) private FGamma : Cardinal; function GetGammaAsSingle: Single; procedure SetGammaAsSingle(const Value: Single); protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property Gamma: Cardinal read FGamma write FGamma; property GammaAsSingle: Single read GetGammaAsSingle write SetGammaAsSingle; end; TChunkPngStandardColorSpaceRGB = class(TCustomDefinedChunkWithHeader) private FRenderingIntent : Byte; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property RenderingIntent: Byte read FRenderingIntent write FRenderingIntent; end; TChunkPngPrimaryChromaticities = class(TCustomDefinedChunkWithHeader) private FWhiteX : Integer; FWhiteY : Integer; FRedX : Integer; FRedY : Integer; FGreenX : Integer; FGreenY : Integer; FBlueX : Integer; FBlueY : Integer; function GetBlueX: Single; function GetBlueY: Single; function GetGreenX: Single; function GetGreenY: Single; function GetRedX: Single; function GetRedY: Single; function GetWhiteX: Single; function GetWhiteY: Single; procedure SetBlueX(const Value: Single); procedure SetBlueY(const Value: Single); procedure SetGreenX(const Value: Single); procedure SetGreenY(const Value: Single); procedure SetRedX(const Value: Single); procedure SetRedY(const Value: Single); procedure SetWhiteX(const Value: Single); procedure SetWhiteY(const Value: Single); protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property WhiteX: Integer read FWhiteX write FWhiteX; property WhiteY: Integer read FWhiteY write FWhiteY; property RedX: Integer read FRedX write FRedX; property RedY: Integer read FRedY write FRedY; property GreenX: Integer read FGreenX write FGreenX; property GreenY: Integer read FGreenY write FGreenY; property BlueX: Integer read FBlueX write FBlueX; property BlueY: Integer read FBlueY write FBlueY; property WhiteXAsSingle: Single read GetWhiteX write SetWhiteX; property WhiteYAsSingle: Single read GetWhiteY write SetWhiteY; property RedXAsSingle: Single read GetRedX write SetRedX; property RedYAsSingle: Single read GetRedY write SetRedY; property GreenXAsSingle: Single read GetGreenX write SetGreenX; property GreenYAsSingle: Single read GetGreenY write SetGreenY; property BlueXAsSingle: Single read GetBlueX write SetBlueX; property BlueYAsSingle: Single read GetBlueY write SetBlueY; end; TChunkPngTime = class(TCustomDefinedChunkWithHeader) private FYear : Word; FMonth : Byte; FDay : Byte; FHour : Byte; FMinute : Byte; FSecond : Byte; function GetModifiedDateTime: TDateTime; procedure SetModifiedDateTime(const Value: TDateTime); protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property Year: Word read FYear write FYear; property Month: Byte read FMonth write FMonth; property Day: Byte read FDay write FDay; property Hour: Byte read FHour write FHour; property Minute: Byte read FMinute write FMinute; property Second: Byte read FSecond write FSecond; property ModifiedDateTime: TDateTime read GetModifiedDateTime write SetModifiedDateTime; end; TChunkPngEmbeddedIccProfile = class(TCustomDefinedChunkWithHeader) private FProfileName : AnsiString; FCompressionMethod : Byte; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property ProfileName: AnsiString read FProfileName write FProfileName; property CompressionMethod: Byte read FCompressionMethod write FCompressionMethod; end; TCustomPngSignificantBits = class abstract(TPersistent) protected class function GetChunkSize: Cardinal; virtual; abstract; public constructor Create(BitDepth: Integer = 8); virtual; abstract; procedure ReadFromStream(Stream: TStream); virtual; abstract; procedure WriteToStream(Stream: TStream); virtual; abstract; property ChunkSize: Cardinal read GetChunkSize; end; TPngSignificantBitsFormat0 = class(TCustomPngSignificantBits) private FGrayBits : Byte; protected class function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public constructor Create(BitDepth: Integer = 8); override; procedure ReadFromStream(Stream: TStream); override; procedure WriteToStream(Stream: TStream); override; property GrayBits: Byte read FGrayBits write FGrayBits; end; TPngSignificantBitsFormat23 = class(TCustomPngSignificantBits) private FRedBits : Byte; FBlueBits : Byte; FGreenBits : Byte; protected class function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public constructor Create(BitDepth: Integer = 8); override; procedure ReadFromStream(Stream: TStream); override; procedure WriteToStream(Stream: TStream); override; property RedBits: Byte read FRedBits write FRedBits; property BlueBits: Byte read FBlueBits write FBlueBits; property GreenBits: Byte read FGreenBits write FGreenBits; end; TPngSignificantBitsFormat4 = class(TCustomPngSignificantBits) private FGrayBits : Byte; FAlphaBits : Byte; protected class function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public constructor Create(BitDepth: Integer = 8); override; procedure ReadFromStream(Stream: TStream); override; procedure WriteToStream(Stream: TStream); override; property GrayBits: Byte read FGrayBits write FGrayBits; property AlphaBits: Byte read FAlphaBits write FAlphaBits; end; TPngSignificantBitsFormat6 = class(TCustomPngSignificantBits) private FRedBits : Byte; FBlueBits : Byte; FGreenBits : Byte; FAlphaBits : Byte; protected class function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public constructor Create(BitDepth: Integer = 8); override; procedure ReadFromStream(Stream: TStream); override; procedure WriteToStream(Stream: TStream); override; property RedBits: Byte read FRedBits write FRedBits; property BlueBits: Byte read FBlueBits write FBlueBits; property GreenBits: Byte read FGreenBits write FGreenBits; property AlphaBits: Byte read FAlphaBits write FAlphaBits; end; TChunkPngSignificantBits = class(TCustomDefinedChunkWithHeader) private FSignificantBits : TCustomPngSignificantBits; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public constructor Create(Header: TChunkPngImageHeader); override; destructor Destroy; override; procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; procedure HeaderChanged; override; property SignificantBits: TCustomPngSignificantBits read FSignificantBits; end; TCustomPngBackgroundColor = class abstract(TPersistent) protected class function GetChunkSize: Cardinal; virtual; abstract; public procedure ReadFromStream(Stream: TStream); virtual; abstract; procedure WriteToStream(Stream: TStream); virtual; abstract; property ChunkSize: Cardinal read GetChunkSize; end; TPngBackgroundColorFormat04 = class(TCustomPngBackgroundColor) private FGraySampleValue : Word; protected class function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream); override; procedure WriteToStream(Stream: TStream); override; property GraySampleValue: Word read FGraySampleValue write FGraySampleValue; end; TPngBackgroundColorFormat26 = class(TCustomPngBackgroundColor) private FRedSampleValue : Word; FBlueSampleValue : Word; FGreenSampleValue : Word; protected class function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream); override; procedure WriteToStream(Stream: TStream); override; property RedSampleValue: Word read FRedSampleValue write FRedSampleValue; property BlueSampleValue: Word read FBlueSampleValue write FBlueSampleValue; property GreenSampleValue: Word read FGreenSampleValue write FGreenSampleValue; end; TPngBackgroundColorFormat3 = class(TCustomPngBackgroundColor) private FIndex : Byte; protected class function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream); override; procedure WriteToStream(Stream: TStream); override; property PaletteIndex: Byte read FIndex write FIndex; end; TChunkPngBackgroundColor = class(TCustomDefinedChunkWithHeader) private FBackground : TCustomPngBackgroundColor; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public constructor Create(Header: TChunkPngImageHeader); override; destructor Destroy; override; procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; procedure HeaderChanged; override; property Background: TCustomPngBackgroundColor read FBackground; end; TChunkPngImageHistogram = class(TCustomDefinedChunkWithHeader) private FHistogram : array of Word; function GetCount: Cardinal; function GetFrequency(Index: Cardinal): Word; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property Count: Cardinal read GetCount; property Frequency[Index: Cardinal]: Word read GetFrequency; end; TSuggestedPalette8ByteEntry = record Red : Byte; Green : Byte; Blue : Byte; Alpha : Byte; Frequency : Word; end; PSuggestedPalette8ByteEntry = ^TSuggestedPalette8ByteEntry; TSuggestedPalette8ByteArray = array [0..0] of TSuggestedPalette8ByteEntry; PSuggestedPalette8ByteArray = ^TSuggestedPalette8ByteArray; TSuggestedPalette16ByteEntry = record Red : Word; Green : Word; Blue : Word; Alpha : Word; Frequency : Word; end; PSuggestedPalette16ByteEntry = ^TSuggestedPalette16ByteEntry; TSuggestedPalette16ByteArray = array [0..0] of TSuggestedPalette16ByteEntry; PSuggestedPalette16ByteArray = ^TSuggestedPalette16ByteArray; {$ifdef PNG_CHUNK_SUGGESTED_PALETTE} TChunkPngSuggestedPalette = class(TCustomDefinedChunkWithHeader) private FPaletteName : AnsiString; FData : Pointer; FCount : Cardinal; FSampleDepth : Byte; function GetCount: Cardinal; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; public constructor Create(Header: TChunkPngImageHeader); override; procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property Count: Cardinal read GetCount; end; {$endif PNG_CHUNK_SUGGESTED_PALETTE} TCustomPngTransparency = class abstract(TPersistent) protected function GetChunkSize: Cardinal; virtual; abstract; public procedure ReadFromStream(Stream: TStream); virtual; abstract; procedure WriteToStream(Stream: TStream); virtual; abstract; property ChunkSize: Cardinal read GetChunkSize; end; TPngTransparencyFormat0 = class(TCustomPngTransparency) private FGraySampleValue : Word; protected procedure AssignTo(Dest: TPersistent); override; function GetChunkSize: Cardinal; override; public procedure ReadFromStream(Stream: TStream); override; procedure WriteToStream(Stream: TStream); override; property GraySampleValue: Word read FGraySampleValue write FGraySampleValue; end; TPngTransparencyFormat2 = class(TCustomPngTransparency) private FRedSampleValue : Word; FBlueSampleValue : Word; FGreenSampleValue : Word; protected procedure AssignTo(Dest: TPersistent); override; function GetChunkSize: Cardinal; override; public procedure ReadFromStream(Stream: TStream); override; procedure WriteToStream(Stream: TStream); override; property RedSampleValue: Word read FRedSampleValue write FRedSampleValue; property BlueSampleValue: Word read FBlueSampleValue write FBlueSampleValue; property GreenSampleValue: Word read FGreenSampleValue write FGreenSampleValue; end; TPngTransparencyFormat3 = class(TCustomPngTransparency) private function GetCount: Cardinal; function GetTransparency(Index: Cardinal): Byte; protected FTransparency : array of Byte; procedure AssignTo(Dest: TPersistent); override; function GetChunkSize: Cardinal; override; public procedure ReadFromStream(Stream: TStream); override; procedure WriteToStream(Stream: TStream); override; property Count: Cardinal read GetCount; property Transparency[Index: Cardinal]: Byte read GetTransparency; end; TChunkPngTransparency = class(TCustomDefinedChunkWithHeader) protected FTransparency : TCustomPngTransparency; class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public constructor Create(Header: TChunkPngImageHeader); override; destructor Destroy; override; procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; procedure HeaderChanged; override; property Transparency: TCustomPngTransparency read FTransparency; end; TChunkPngPhysicalPixelDimensions = class(TCustomDefinedChunkWithHeader) private FPixelsPerUnitX : Cardinal; FPixelsPerUnitY : Cardinal; FUnit : Byte; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property PixelsPerUnitX: Cardinal read FPixelsPerUnitX write FPixelsPerUnitX; property PixelsPerUnitY: Cardinal read FPixelsPerUnitY write FPixelsPerUnitY; property PixelUnit: Byte read FUnit write FUnit; end; TChunkPngPhysicalScale = class(TCustomDefinedChunkWithHeader) private FUnitSpecifier : Byte; FUnitsPerPixelX : Single; FUnitsPerPixelY : Single; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property UnitSpecifier: Byte read FUnitSpecifier write FUnitSpecifier; property UnitsPerPixelX: Single read FUnitsPerPixelX write FUnitsPerPixelX; property UnitsPerPixelY: Single read FUnitsPerPixelY write FUnitsPerPixelY; end; TChunkPngImageOffset = class(TCustomDefinedChunkWithHeader) private FImagePositionX : Integer; FImagePositionY : Integer; FUnitSpecifier : Byte; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property UnitSpecifier: Byte read FUnitSpecifier write FUnitSpecifier; property ImagePositionX: Integer read FImagePositionX write FImagePositionX; property ImagePositionY: Integer read FImagePositionY write FImagePositionY; end; TChunkPngPixelCalibrator = class(TCustomDefinedChunkWithHeader) private FCalibratorName : AnsiString; FOriginalZeroes : array [0..1] of Integer; FEquationType : Byte; FNumberOfParams : Byte; FUnitName : AnsiString; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property CalibratorName: AnsiString read FCalibratorName write FCalibratorName; property OriginalZeroMin: Integer read FOriginalZeroes[0] write FOriginalZeroes[0]; property OriginalZeroMax: Integer read FOriginalZeroes[1] write FOriginalZeroes[1]; property EquationType: Byte read FEquationType write FEquationType; property NumberOfParams: Byte read FNumberOfParams write FNumberOfParams; end; TCustomChunkPngText = class(TCustomDefinedChunkWithHeader) private procedure SetKeyword(const Value: AnsiString); procedure SetText(const Value: AnsiString); protected FKeyword : AnsiString; FText : AnsiString; procedure AssignTo(Dest: TPersistent); override; procedure KeywordChanged; virtual; procedure TextChanged; virtual; public property Keyword: AnsiString read FKeyword write SetKeyword; property Text: AnsiString read FText write SetText; end; TChunkPngText = class(TCustomChunkPngText) protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; end; TChunkPngCompressedText = class(TCustomChunkPngText) private FCompressionMethod : Byte; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure SetCompressionMethod(const Value: Byte); procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property CompressionMethod: Byte read FCompressionMethod write SetCompressionMethod; end; {$ifdef PNG_CHUNK_INTERNATIONAL_TEXT} TChunkPngInternationalText = class(TCustomChunkPngText) private FCompressionMethod : Byte; FCompressionFlag : Byte; FLanguageString : AnsiString; FTranslatedKeyword : string; protected class function GetClassChunkName: TChunkName; override; function GetChunkSize: Cardinal; override; procedure AssignTo(Dest: TPersistent); override; public procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property CompressionMethod: Byte read FCompressionMethod write FCompressionMethod; property CompressionFlag: Byte read FCompressionFlag write FCompressionFlag; property LanguageString: AnsiString read FLanguageString write FLanguageString; property TranslatedKeyword: string read FTranslatedKeyword write FTranslatedKeyword; end; {$endif PNG_CHUNK_INTERNATIONAL_TEXT} TChunkPngUnknown = class(TCustomChunk) private function GetData(index: Integer): Byte; procedure SetData(index: Integer; const Value: Byte); protected FChunkName : TChunkName; FDataStream : TMemoryStream; function GetChunkName: TChunkName; override; function GetChunkNameAsString: AnsiString; override; function GetChunkSize: Cardinal; override; function CalculateChecksum: Integer; procedure AssignTo(Dest: TPersistent); override; public constructor Create(ChunkName: TChunkName); virtual; destructor Destroy; override; procedure ReadFromStream(Stream: TStream; ChunkSize: Cardinal); override; procedure WriteToStream(Stream: TStream); override; property Data[index : Integer]: Byte read GetData write SetData; property DataStream: TMemoryStream read FDataStream; end; TChunkList = class(TPersistent) private FChunks : array of TCustomChunk; function GetCount: Cardinal; protected function GetChunk(Index: Integer): TCustomChunk; procedure AssignTo(Dest: TPersistent); override; public destructor Destroy; override; procedure Add(Item: TCustomChunk); procedure Clear; virtual; procedure Delete(Index: Cardinal); function IndexOf(Item: TCustomChunk): Integer; procedure Remove(Item: TCustomChunk); property Count: Cardinal read GetCount; property Chunks[Index: Integer]: TCustomChunk read GetChunk; default; end; TCustomPngCoder = class abstract protected FStream : TStream; FHeader : TChunkPngImageHeader; FGamma : TChunkPngGamma; FPalette : TChunkPngPalette; FTransparency : TCustomPngTransparency; FRowBuffer : array [0..1] of PByteArray; FAlphaTable : PByteArray; FMappingTable : PByteArray; procedure BuildMappingTables; virtual; procedure EncodeFilterSub(CurrentRow, PreviousRow, OutputRow: PByteArray; BytesPerRow, PixelByteSize: Integer); procedure EncodeFilterUp(CurrentRow, PreviousRow, OutputRow: PByteArray; BytesPerRow, PixelByteSize: Integer); procedure EncodeFilterAverage(CurrentRow, PreviousRow, OutputRow: PByteArray; BytesPerRow, PixelByteSize: Integer); procedure EncodeFilterPaeth(CurrentRow, PreviousRow, OutputRow: PByteArray; BytesPerRow, PixelByteSize: Integer); procedure DecodeFilterSub(CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: NativeInt); procedure DecodeFilterUp(CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: NativeInt); procedure DecodeFilterAverage(CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: NativeInt); procedure DecodeFilterPaeth(CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: NativeInt); procedure EncodeFilterRow(CurrentRow, PreviousRow, OutputRow, TempBuffer: PByteArray; BytesPerRow, PixelByteSize: Integer); virtual; abstract; procedure DecodeFilterRow(FilterMethod: TAdaptiveFilterMethod; CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: Integer); virtual; abstract; public constructor Create(Stream: TStream; Header: TChunkPngImageHeader; Gamma: TChunkPngGamma = nil; Palette: TChunkPngPalette = nil; Transparency : TCustomPngTransparency = nil); virtual; destructor Destroy; override; end; TScanLineCallback = function(Bitmap: TObject; Y: Integer): Pointer of object; TCustomPngDecoder = class abstract(TCustomPngCoder) protected procedure EncodeFilterRow(CurrentRow, PreviousRow, OutputRow, TempBuffer: PByteArray; BytesPerRow, PixelByteSize: Integer); override; procedure DecodeFilterRow(FilterMethod: TAdaptiveFilterMethod; CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: Integer); override; public procedure DecodeToScanline(Bitmap: TObject; ScanLineCallback: TScanLineCallback); virtual; abstract; end; TCustomPngDecoderClass = class of TCustomPngDecoder; TCustomPngEncoder = class abstract(TCustomPngCoder) protected procedure EncodeFilterRow(CurrentRow, PreviousRow, OutputRow, TempBuffer: PByteArray; BytesPerRow, PixelByteSize: Integer); override; procedure DecodeFilterRow(FilterMethod: TAdaptiveFilterMethod; CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: Integer); override; public procedure EncodeFromScanline(Bitmap: TObject; ScanLineCallback: TScanLineCallback); virtual; abstract; end; TCustomPngEncoderClass = class of TCustomPngEncoder; TCustomPngTranscoder = class abstract(TCustomPngCoder) protected procedure EncodeFilterRow(CurrentRow, PreviousRow, OutputRow, TempBuffer: PByteArray; BytesPerRow, PixelByteSize: Integer); override; procedure DecodeFilterRow(FilterMethod: TAdaptiveFilterMethod; CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: Integer); override; procedure Transcode; virtual; abstract; public constructor Create(Stream: TStream; Header: TChunkPngImageHeader; Gamma: TChunkPngGamma = nil; Palette: TChunkPngPalette = nil; Transparency: TCustomPngTransparency = nil); override; destructor Destroy; override; end; TCustomPngTranscoderClass = class of TCustomPngTranscoder; TPortableNetworkGraphic = class(TInterfacedPersistent, IStreamPersist) private FCompressionLevel : Byte; function GetBitDepth: Byte; function GetColorType: TColorType; function GetCompressionMethod: Byte; function GetFilterMethod: TFilterMethod; function GetHeight: Integer; function GetInterlaceMethod: TInterlaceMethod; function GetPaletteEntry(Index: Integer): TRGB24; function GetPaletteEntryCount: Integer; function GetWidth: Integer; function GetGamma: Single; function GetModifiedTime: TDateTime; function GetPixelsPerUnitX: Cardinal; function GetPixelsPerUnitY: Cardinal; function GetPixelUnit: Byte; procedure SetPixelsPerUnitX(const Value: Cardinal); procedure SetPixelsPerUnitY(const Value: Cardinal); procedure SetPixelUnit(const Value: Byte); procedure SetBitDepth(const Value: Byte); procedure SetChromaChunk(const Value: TChunkPngPrimaryChromaticities); procedure SetColorType(const Value: TColorType); procedure SetCompressionMethod(const Value: Byte); procedure SetCompressionLevel(const Value: Byte); procedure SetFilterMethods(const Value: TAvailableAdaptiveFilterMethods); procedure SetFilterMethod(const Value: TFilterMethod); procedure SetGamma(const Value: Single); procedure SetModifiedTime(const Value: TDateTime); procedure SetHeight(const Value: Integer); procedure SetImageHeader(const Value: TChunkPngImageHeader); procedure SetInterlaceMethod(const Value: TInterlaceMethod); procedure SetGammaChunk(const Value: TChunkPngGamma); procedure SetPaletteChunk(const Value: TChunkPngPalette); procedure SetTransparencyChunk(const Value: TChunkPngTransparency); procedure SetPhysicalDimensions(const Value: TChunkPngPhysicalPixelDimensions); procedure SetSignificantBits(const Value: TChunkPngSignificantBits); procedure SetTimeChunk(const Value: TChunkPngTime); procedure SetWidth(const Value: Integer); function CalculateCRC(Buffer: PByte; Count: Cardinal): Cardinal; overload; function CalculateCRC(Stream: TStream): Cardinal; overload; {$IFDEF CheckCRC} function CheckCRC(Stream: TStream; CRC: Cardinal): Boolean; {$ENDIF} procedure ReadImageDataChunk(Stream: TStream; Size: Integer); procedure ReadUnknownChunk(Stream: TStream; ChunkName: TChunkName; ChunkSize: Integer); function GetFilterMethods: TAvailableAdaptiveFilterMethods; procedure SetBackgroundChunk(const Value: TChunkPngBackgroundColor); protected FImageHeader : TChunkPngImageHeader; FPaletteChunk : TChunkPngPalette; FGammaChunk : TChunkPngGamma; FTimeChunk : TChunkPngTime; FSignificantBits : TChunkPngSignificantBits; FPhysicalDimensions : TChunkPngPhysicalPixelDimensions; FChromaChunk : TChunkPngPrimaryChromaticities; FTransparencyChunk : TChunkPngTransparency; FBackgroundChunk : TChunkPngBackgroundColor; FDataChunkList : TChunkList; FAdditionalChunkList : TChunkList; procedure Clear; virtual; procedure AssignTo(Dest: TPersistent); override; procedure CopyImageData(Stream: TStream); procedure StoreImageData(Stream: TStream); procedure DecompressImageDataToStream(Stream: TStream); procedure CompressImageDataFromStream(Stream: TStream); procedure CompressionLevelChanged; virtual; procedure AdaptiveFilterMethodsChanged; virtual; procedure InterlaceMethodChanged; virtual; property ImageHeader: TChunkPngImageHeader read FImageHeader write SetImageHeader; property PaletteChunk: TChunkPngPalette read FPaletteChunk write SetPaletteChunk; property TransparencyChunk: TChunkPngTransparency read FTransparencyChunk write SetTransparencyChunk; property BackgroundChunk: TChunkPngBackgroundColor read FBackgroundChunk write SetBackgroundChunk; property GammaChunk: TChunkPngGamma read FGammaChunk write SetGammaChunk; property TimeChunk: TChunkPngTime read FTimeChunk write SetTimeChunk; property PhysicalPixelDimensionsChunk: TChunkPngPhysicalPixelDimensions read FPhysicalDimensions write SetPhysicalDimensions; public constructor Create; virtual; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure LoadFromStream(Stream: TStream); virtual; procedure SaveToStream(Stream: TStream); virtual; procedure LoadFromFile(Filename: TFilename); virtual; procedure SaveToFile(Filename: TFilename); virtual; class function CanLoad(const FileName: TFileName): Boolean; overload; class function CanLoad(Stream: TStream): Boolean; overload; function HasPhysicalPixelDimensionsInformation: Boolean; function HasGammaInformation: Boolean; function HasModifiedTimeInformation: Boolean; procedure RemovePhysicalPixelDimensionsInformation; procedure RemoveGammaInformation; procedure RemoveModifiedTimeInformation; property Width: Integer read GetWidth write SetWidth; property Height: Integer read GetHeight write SetHeight; property BitDepth: Byte read GetBitDepth write SetBitDepth; property ColorType: TColorType read GetColorType write SetColorType; property CompressionMethod: Byte read GetCompressionMethod write SetCompressionMethod; property CompressionLevel: Byte read FCompressionLevel write SetCompressionLevel; property AdaptiveFilterMethods: TAvailableAdaptiveFilterMethods read GetFilterMethods write SetFilterMethods; property FilterMethod: TFilterMethod read GetFilterMethod write SetFilterMethod; property InterlaceMethod: TInterlaceMethod read GetInterlaceMethod write SetInterlaceMethod; property PaletteEntry[Index: Integer]: TRGB24 read GetPaletteEntry; property PaletteEntryCount: Integer read GetPaletteEntryCount; property Gamma: Single read GetGamma write SetGamma; property ModifiedTime: TDateTime read GetModifiedTime write SetModifiedTime; property PixelsPerUnitX: Cardinal read GetPixelsPerUnitX write SetPixelsPerUnitX; property PixelsPerUnitY: Cardinal read GetPixelsPerUnitY write SetPixelsPerUnitY; property PixelUnit: Byte read GetPixelUnit write SetPixelUnit; property SignificantBitsChunk: TChunkPngSignificantBits read FSignificantBits write SetSignificantBits; property PrimaryChromaticitiesChunk: TChunkPngPrimaryChromaticities read FChromaChunk write SetChromaChunk; end; procedure RegisterPngChunk(ChunkClass: TCustomDefinedChunkWithHeaderClass); procedure RegisterPngChunks(ChunkClasses: array of TCustomDefinedChunkWithHeaderClass); function FindPngChunkByChunkName(ChunkName: TChunkName): TCustomDefinedChunkWithHeaderClass; function ColorTypeToString(Value: TColorType): string; function InterlaceMethodToString(Value: TInterlaceMethod): string; implementation uses Math, GR32_LowLevel, GR32.BigEndian; resourcestring RCStrAncillaryUnknownChunk = 'Unknown chunk is marked as ancillary'; RCStrChunkSizeTooSmall = 'Chunk size too small!'; RCStrDataIncomplete = 'Data not complete'; RCStrChunkInvalid = 'Invalid chunk data'; RCStrDirectCompressionMethodSetError = 'Compression Method may not be specified directly yet!'; RCStrDirectFilterMethodSetError = 'Filter Method may not be specified directly yet!'; RCStrDirectGammaSetError = 'Gamma may not be specified directly yet!'; RCStrDirectHeightSetError = 'Height may not be specified directly yet!'; RCStrDirectWidthSetError = 'Width may not be specified directly yet!'; RCStrEmptyChunkList = 'Chunk list is empty'; RCStrHeaderInvalid = 'The provided header is not valid!'; RCStrIncompletePalette = 'Palette is incomplete'; RCStrIndexOutOfBounds = 'Index out of bounds (%d)'; RCStrNewHeaderError = 'New header may not be nil!'; RCStrNotAValidPNGFile = 'Not a valid PNG file'; RCStrNotYetImplemented = 'PNG feature not implemented (%s)'; RCStrChunkNotImplemented = 'Chunk type %s not implemented'; RCStrPaletteLimited = 'Palette is limited to 256 entries'; RCStrSeveralChromaChunks = 'Primary chromaticities chunk defined twice!'; RCStrSeveralGammaChunks = 'Gamma chunk defined twice!'; RCStrSeveralPaletteChunks = 'Palette chunk defined twice!'; RCStrSeveralTransparencyChunks = 'Transparency chunk defined twice!'; RCStrSeveralBackgroundChunks = 'Background chunk defined twice!'; RCStrSeveralPhysicalPixelDimensionChunks = 'Several physical pixel dimenson chunks found'; RCStrSeveralSignificantBitsChunksFound = 'Several significant bits chunks found'; RCStrSeveralTimeChunks = 'Time chunk appears twice!'; RCStrMissingIDATChunk = 'IDAT chunk missing'; RCStrUnknownColorType = 'Unknown color type!'; RCStrUnspecifiedPixelUnit = 'Unspecified unit'; RCStrUnsupportedCompressionMethod = 'Compression method not supported!'; RCStrUnsupportedCompressMethod = 'Unsupported compression method'; RCStrUnsupportedFilter = 'Unsupported Filter'; RCStrUnsupportedFilterMethod = 'Unsupported filter method'; RCStrUnsupportedInterlaceMethod = 'Unsupported interlace method'; RCStrUnsupportedColorType = 'Unsupported color type'; RCStrWrongBitdepth = 'Wrong Bitdepth'; RCStrWrongInterlaceMethod = 'Wrong interlace method'; RCStrWrongPixelPerUnit = 'Pixel per unit may not be zero!'; RCStrWrongTransparencyFormat = 'Wrong transparency format'; RCStrInvalidCompressionLevel = 'Invalid compression level'; RCStrBitDepthTranscodingError = 'Bit depth may not be specified directly yet!'; RCStrColorTypeTranscodingError = 'Color Type may not be specified directly yet!'; RCStrGrayscale = 'Grayscale'; RCStrTrueColor = 'True Color'; RCStrIndexedColor = 'Indexed Color'; RCStrGrayscaleAlpha = 'Transparent Grayscale'; RCStrTrueColorAlpha = 'Transparent True Color'; RCStrInterlacingNone = 'None'; RCStrInterlacingAdam7 = 'Adam7'; {$IFDEF CheckCRC} RCStrCRCError = 'CRC Error'; {$ENDIF} type TCrcTable = array [0..255] of Cardinal; PCrcTable = ^TCrcTable; var GCrcTable : PCrcTable; GPngChunkClasses: array of TCustomDefinedChunkWithHeaderClass; const PNG_SIG: array[0..7] of AnsiChar = #$89'PNG'#$0D#$0A#$1A#$0A; const CRowStart : array[0..6] of Integer = (0, 0, 4, 0, 2, 0, 1); CColumnStart : array[0..6] of Integer = (0, 4, 0, 2, 0, 1, 0); CRowIncrement : array[0..6] of Integer = (8, 8, 8, 4, 4, 2, 2); CColumnIncrement : array[0..6] of Integer = (8, 8, 4, 4, 2, 2, 1); type TPngNonInterlacedToAdam7Transcoder = class(TCustomPngTranscoder) protected procedure Transcode; override; end; TPngAdam7ToNonInterlacedTranscoder = class(TCustomPngTranscoder) protected procedure Transcode; override; end; function IsPngChunkRegistered(ChunkClass: TCustomDefinedChunkWithHeaderClass): Boolean; var ChunkClassIndex : Integer; begin Result := False; for ChunkClassIndex := 0 to Length(GPngChunkClasses) - 1 do if GPngChunkClasses[ChunkClassIndex] = ChunkClass then begin Result := True; Exit; end; end; procedure RegisterPngChunk(ChunkClass: TCustomDefinedChunkWithHeaderClass); begin Assert(not IsPngChunkRegistered(ChunkClass), 'PNG chunk already registered'); SetLength(GPngChunkClasses, Length(GPngChunkClasses) + 1); GPngChunkClasses[Length(GPngChunkClasses) - 1] := ChunkClass; end; procedure RegisterPngChunks(ChunkClasses: array of TCustomDefinedChunkWithHeaderClass); var ChunkClassIndex : Integer; begin for ChunkClassIndex := 0 to Length(ChunkClasses) - 1 do RegisterPngChunk(ChunkClasses[ChunkClassIndex]); end; function FindPngChunkByChunkName(ChunkName: TChunkName): TCustomDefinedChunkWithHeaderClass; var ChunkClassIndex : Integer; begin Result := nil; for ChunkClassIndex := 0 to Length(GPngChunkClasses) - 1 do if GPngChunkClasses[ChunkClassIndex].GetClassChunkName = ChunkName then begin Result := GPngChunkClasses[ChunkClassIndex]; Exit; end; end; { conversion } function ColorTypeToString(Value: TColorType): string; const CColorTypeNames : array [TColorType] of string = (RCStrGrayScale, 'undefined', RCStrTrueColor, RCStrIndexedColor, RCStrGrayscaleAlpha, 'undefined', RCStrTrueColorAlpha); begin Result := CColorTypeNames[Value]; end; function InterlaceMethodToString(Value: TInterlaceMethod): string; const CInterlaceMethodNames : array [TInterlaceMethod] of string = (RCStrInterlacingNone, RCStrInterlacingAdam7); begin Result := CInterlaceMethodNames[Value]; end; { zlib functions } procedure ZCompress(Data: Pointer; Size: Integer; const Output: TStream; Level: Byte = Z_BEST_COMPRESSION); overload; const CBufferSize = $8000; var ZStreamRecord : TZStreamRec; ZResult : Integer; TempBuffer : Pointer; begin FillChar(ZStreamRecord, SizeOf(TZStreamRec), 0); with ZStreamRecord do begin next_in := Data; avail_in := Size; {$IFNDEF FPC} {$IFNDEF ZLibEx} zalloc := zlibAllocMem; zfree := zlibFreeMem; {$ENDIF} {$ENDIF} end; {$IFDEF FPC} if DeflateInit_(@ZStreamRecord, Level, ZLIB_VERSION, SizeOf(TZStreamRec)) < 0 then raise EPngError.Create('Error during compression'); {$ELSE} if DeflateInit_(ZStreamRecord, Level, ZLIB_VERSION, SizeOf(TZStreamRec)) < 0 then raise EPngError.Create('Error during compression'); {$ENDIF} GetMem(TempBuffer, CBufferSize); try while ZStreamRecord.avail_in > 0 do begin ZStreamRecord.next_out := TempBuffer; ZStreamRecord.avail_out := CBufferSize; deflate(ZStreamRecord, Z_NO_FLUSH); Output.Write(TempBuffer^, CBufferSize - ZStreamRecord.avail_out); end; repeat ZStreamRecord.next_out := TempBuffer; ZStreamRecord.avail_out := CBufferSize; ZResult := deflate(ZStreamRecord, Z_FINISH); Output.Write(TempBuffer^, CBufferSize - ZStreamRecord.avail_out); until (ZResult = Z_STREAM_END) and (ZStreamRecord.avail_out > 0); finally FreeMem(TempBuffer); end; if deflateEnd(ZStreamRecord) > 0 then raise EPngError.Create('Error on stream validation'); end; procedure ZCompress(const Input: TMemoryStream; const Output: TStream; Level: Byte = Z_BEST_COMPRESSION); overload; begin ZCompress(Input.Memory, Input.Size, Output, Level); end; procedure ZDecompress(Data: Pointer; Size: Integer; const Output: TStream); overload; const CBufferSize = $8000; var ZStreamRecord : TZStreamRec; ZResult : Integer; TempBuffer : Pointer; begin FillChar(ZStreamRecord, SizeOf(TZStreamRec), 0); with ZStreamRecord do begin next_in := Data; avail_in := Size; {$IFNDEF FPC} {$IFNDEF ZLibEx} zalloc := zlibAllocMem; zfree := zlibFreeMem; {$ENDIF} {$ENDIF} end; {$IFDEF FPC} if inflateInit_(@ZStreamRecord, ZLIB_VERSION, SizeOf(TZStreamRec)) < 0 then raise EPngError.Create('Error during decompression'); {$ELSE} if inflateInit_(ZStreamRecord, ZLIB_VERSION, SizeOf(TZStreamRec)) < 0 then raise EPngError.Create('Error during decompression'); {$ENDIF} try GetMem(TempBuffer, CBufferSize); try ZResult := Z_OK; while (ZStreamRecord.avail_in > 0) and (ZResult <> Z_STREAM_END) do begin ZStreamRecord.next_out := TempBuffer; ZStreamRecord.avail_out := CBufferSize; ZResult := inflate(ZStreamRecord, Z_NO_FLUSH); if ZResult < 0 then raise EPngError.CreateFmt('Error during decompression: %d', [ZResult]); Output.Write(TempBuffer^, CBufferSize - ZStreamRecord.avail_out); end; finally FreeMem(TempBuffer); end; finally if inflateEnd(ZStreamRecord) > 0 then raise EPngError.Create('Error on stream validation'); end; end; procedure ZDecompress(const Input: TMemoryStream; const Output: TStream); overload; begin ZDecompress(Input.Memory, Input.Size, Output); end; { TCustomDefinedChunk } function TCustomDefinedChunk.GetChunkName: TChunkName; begin Result := GetClassChunkName; end; function TCustomDefinedChunk.GetChunkNameAsString: AnsiString; begin Result := AnsiString(GetClassChunkName); end; { TChunkPngUnknown } constructor TChunkPngUnknown.Create(ChunkName: TChunkName); begin FChunkName := ChunkName; FDataStream := TMemoryStream.Create; end; destructor TChunkPngUnknown.Destroy; begin FDataStream.Free; inherited; end; function TChunkPngUnknown.CalculateChecksum: Integer; type PByteArray = ^TByteArray; TByteArray = array[0..MaxInt-1] of Byte; var i: integer; begin Result := 0; for i := 0 to FDataStream.Size-1 do Inc(Result, PByteArray(FDataStream.Memory)[i]); end; procedure TChunkPngUnknown.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngUnknown then begin TChunkPngUnknown(Dest).FDataStream.CopyFrom(FDataStream, FDataStream.Size); TChunkPngUnknown(Dest).FChunkName := FChunkName; end else inherited AssignTo(Dest); end; function TChunkPngUnknown.GetData(Index: Integer): Byte; type PByteArray = ^TByteArray; TByteArray = array[0..MaxInt-1] of Byte; begin if (Index < 0) or (Index >= FDataStream.Size) then raise EPngError.CreateFmt(RCStrIndexOutOfBounds, [index]); Result := PByteArray(FDataStream.Memory)[Index]; end; function TChunkPngUnknown.GetChunkSize: Cardinal; begin Result := FDataStream.Size; end; function TChunkPngUnknown.GetChunkNameAsString: AnsiString; begin Result := FChunkName; end; function TChunkPngUnknown.GetChunkName: TChunkName; begin Result := FChunkName; end; procedure TChunkPngUnknown.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin Assert(Stream.Position+ChunkSize <= Stream.Size); FDataStream.Clear; FDataStream.Position := 0; if ChunkSize > 0 then FDataStream.CopyFrom(Stream, ChunkSize); end; procedure TChunkPngUnknown.WriteToStream(Stream: TStream); begin FDataStream.Position := 0; Stream.CopyFrom(FDataStream, 0); end; procedure TChunkPngUnknown.SetData(Index: Integer; const Value: Byte); type PByteArray = ^TByteArray; TByteArray = array[0..MaxInt-1] of Byte; begin if (Index < 0) or (Index >= FDataStream.Size) then raise EPngError.CreateFmt(RCStrIndexOutOfBounds, [Index]); PByteArray(FDataStream.Memory)[Index] := Value; end; { TChunkPngImageHeader } constructor TChunkPngImageHeader.Create; begin inherited; FAdaptiveFilterMethods := [aafmSub, aafmUp, aafmAverage, aafmPaeth]; ResetToDefault; end; procedure TChunkPngImageHeader.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngImageHeader then with TChunkPngImageHeader(Dest) do begin FWidth := Self.FWidth; FHeight := Self.FHeight; FBitDepth := Self.FBitDepth; FColorType := Self.FColorType; FCompressionMethod := Self.FCompressionMethod; FFilterMethod := Self.FFilterMethod; FInterlaceMethod := Self.FInterlaceMethod; FAdaptiveFilterMethods := Self.FAdaptiveFilterMethods; end else inherited; end; function TChunkPngImageHeader.GetBytesPerRow: Integer; begin case FColorType of ctGrayscale, ctIndexedColor: Result := ((FWidth * FBitDepth + $7) and not $7) shr 3; ctGrayscaleAlpha: Result := 2 * (FBitDepth shr 3) * FWidth; ctTrueColor: Result := 3 * (FBitDepth shr 3) * FWidth; ctTrueColorAlpha: Result := 4 * (FBitDepth shr 3) * FWidth; else raise EPngError.Create(RCStrUnknownColorType); end; end; class function TChunkPngImageHeader.GetClassChunkName: TChunkName; begin Result := 'IHDR'; end; function TChunkPngImageHeader.GetChunkSize: Cardinal; begin Result := 13; end; procedure TChunkPngImageHeader.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); // read width FWidth := BigEndian.ReadCardinal(Stream); // read height FHeight := BigEndian.ReadCardinal(Stream); // read bit depth Stream.Read(FBitDepth, 1); // read Color type Stream.Read(FColorType, 1); // check consistency between Color type and bit depth case FColorType of ctGrayscale: if not (FBitDepth in [1, 2, 4, 8, 16]) then raise EPngError.Create(RCStrWrongBitdepth); ctTrueColor, ctGrayscaleAlpha, ctTrueColorAlpha: if not (FBitDepth in [8, 16]) then raise EPngError.Create(RCStrWrongBitdepth); ctIndexedColor: if not (FBitDepth in [1, 2, 4, 8]) then raise EPngError.Create(RCStrWrongBitdepth); else raise EPngError.Create(RCStrUnsupportedColorType); end; // read compression method Stream.Read(FCompressionMethod, 1); // check for compression method if FCompressionMethod <> 0 then raise EPngError.Create(RCStrUnsupportedCompressMethod); // read filter method Stream.Read(FFilterMethod, 1); // check for filter method if FFilterMethod <> fmAdaptiveFilter then raise EPngError.Create(RCStrUnsupportedFilterMethod); // read interlace method Stream.Read(FInterlaceMethod, 1); // check for interlace method if not (FInterlaceMethod in [imNone, imAdam7]) then raise EPngError.Create(RCStrUnsupportedInterlaceMethod); end; procedure TChunkPngImageHeader.WriteToStream(Stream: TStream); begin // write width BigEndian.WriteCardinal(Stream, FWidth); // write height BigEndian.WriteCardinal(Stream, FHeight); // write bit depth Stream.Write(FBitDepth, 1); // write Color type Stream.Write(FColorType, 1); // write compression method Stream.Write(FCompressionMethod, 1); // write filter method Stream.Write(FFilterMethod, 1); // write interlace method Stream.Write(FInterlaceMethod, 1); end; function TChunkPngImageHeader.GetPixelByteSize: Integer; begin case ColorType of ctGrayscale: if FBitDepth = 16 then Result := 2 else Result := 1; ctTrueColor: Result := 3 * FBitDepth div 8; ctIndexedColor: Result := 1; ctGrayscaleAlpha: Result := 2 * FBitDepth div 8; ctTrueColorAlpha: Result := 4 * FBitDepth div 8; else Result := 0; end; end; function TChunkPngImageHeader.GetHasPalette: Boolean; begin Result := FColorType in [ctIndexedColor]; end; procedure TChunkPngImageHeader.ResetToDefault; begin FWidth := 0; FHeight := 0; FBitDepth := 8; FColorType := ctTrueColor; FCompressionMethod := 0; FFilterMethod := fmAdaptiveFilter; FInterlaceMethod := imNone; end; procedure TChunkPngImageHeader.SetAdaptiveFilterMethods( const Value: TAvailableAdaptiveFilterMethods); begin FAdaptiveFilterMethods := Value; end; procedure TChunkPngImageHeader.SetCompressionMethod(const Value: Byte); begin // check for compression method if Value <> 0 then raise EPngError.Create(RCStrUnsupportedCompressMethod); end; procedure TChunkPngImageHeader.SetFilterMethod(const Value: TFilterMethod); begin // check for filter method if Value <> fmAdaptiveFilter then raise EPngError.Create(RCStrUnsupportedFilterMethod); end; { TCustomDefinedChunkWithHeader } procedure TCustomDefinedChunkWithHeader.AssignTo(Dest: TPersistent); begin if Dest is TCustomDefinedChunkWithHeader then with TCustomDefinedChunkWithHeader(Dest) do begin FHeader.Assign(Self.FHeader); end else inherited; end; constructor TCustomDefinedChunkWithHeader.Create(Header: TChunkPngImageHeader); begin if not (Header is TChunkPngImageHeader) then raise EPngError.Create(RCStrHeaderInvalid); FHeader := Header; inherited Create; end; procedure TCustomDefinedChunkWithHeader.HeaderChanged; begin // purely virtual, do nothing by default end; { TChunkPngPalette } procedure TChunkPngPalette.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngPalette then with TChunkPngPalette(Dest) do begin SetLength(FPaletteEntries, Length(Self.FPaletteEntries)); Move(Self.FPaletteEntries[0], FPaletteEntries[0], Length(Self.FPaletteEntries) * SizeOf(TRGB24)); end else inherited; end; class function TChunkPngPalette.GetClassChunkName: TChunkName; begin Result := 'PLTE'; end; function TChunkPngPalette.GetPaletteEntry(Index: Cardinal): TRGB24; begin if (Index < Count) then Result := FPaletteEntries[Index] else raise EPngError.Create(RCStrIndexOutOfBounds); end; procedure TChunkPngPalette.SetPaletteEntry(Index: Cardinal; const Value: TRGB24); begin if (Index < Count) then FPaletteEntries[Index] := Value else raise EPngError.Create(RCStrIndexOutOfBounds); end; function TChunkPngPalette.GetCount: Cardinal; begin Result := Length(FPaletteEntries); end; function TChunkPngPalette.GetChunkSize: Cardinal; begin Result := Length(FPaletteEntries) * SizeOf(TRGB24); end; procedure TChunkPngPalette.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (ChunkSize mod SizeOf(TRGB24)) <> 0 then raise EPngError.Create(RCStrIncompletePalette); SetLength(FPaletteEntries, ChunkSize div SizeOf(TRGB24)); Stream.Read(FPaletteEntries[0], Length(FPaletteEntries) * SizeOf(TRGB24)); end; procedure TChunkPngPalette.WriteToStream(Stream: TStream); begin Stream.Write(FPaletteEntries[0], ChunkSize); end; procedure TChunkPngPalette.PaletteEntriesChanged; begin // nothing todo here yet end; procedure TChunkPngPalette.SetCount(const Value: Cardinal); begin if Value > 256 then raise EPngError.Create(RCStrPaletteLimited); if Value <> Cardinal(Length(FPaletteEntries)) then begin SetLength(FPaletteEntries, Value); PaletteEntriesChanged; end; end; { TChunkPngTransparency } procedure TChunkPngTransparency.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngTransparency then with TChunkPngTransparency(Dest) do begin FTransparency.Assign(Self.FTransparency); end else inherited; end; constructor TChunkPngTransparency.Create(Header: TChunkPngImageHeader); begin inherited; case Header.ColorType of ctGrayscale: FTransparency := TPngTransparencyFormat0.Create; ctTrueColor: FTransparency := TPngTransparencyFormat2.Create; ctIndexedColor: FTransparency := TPngTransparencyFormat3.Create; end; end; destructor TChunkPngTransparency.Destroy; begin FTransparency.Free; inherited; end; class function TChunkPngTransparency.GetClassChunkName: TChunkName; begin Result := 'tRNS'; end; procedure TChunkPngTransparency.HeaderChanged; var OldTransparency : TCustomPngTransparency; begin inherited; // store old transparency object OldTransparency := FTransparency; // change transparency object class case FHeader.ColorType of ctGrayscale: if not (FTransparency is TPngTransparencyFormat0) then FTransparency := TPngTransparencyFormat0.Create; ctTrueColor: if not (FTransparency is TPngTransparencyFormat2) then FTransparency := TPngTransparencyFormat2.Create; ctIndexedColor: if not (FTransparency is TPngTransparencyFormat3) then FTransparency := TPngTransparencyFormat3.Create; else FTransparency := nil; end; if (OldTransparency <> nil) and (OldTransparency <> FTransparency) then begin if (FTransparency <> nil) then FTransparency.Assign(OldTransparency); OldTransparency.Free; end; end; function TChunkPngTransparency.GetChunkSize: Cardinal; begin if (FTransparency <> nil) then Result := FTransparency.ChunkSize else Result := 0; end; procedure TChunkPngTransparency.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (FTransparency <> nil) then FTransparency.ReadFromStream(Stream); end; procedure TChunkPngTransparency.WriteToStream(Stream: TStream); begin // check consistency case FHeader.ColorType of ctGrayscale: if not (FTransparency is TPngTransparencyFormat0) then raise EPngError.Create(RCStrWrongTransparencyFormat); ctTrueColor: if not (FTransparency is TPngTransparencyFormat2) then raise EPngError.Create(RCStrWrongTransparencyFormat); ctIndexedColor: if not (FTransparency is TPngTransparencyFormat3) then raise EPngError.Create(RCStrWrongTransparencyFormat); end; if (FTransparency <> nil) then FTransparency.WriteToStream(Stream); end; { TPngTransparencyFormat0 } procedure TPngTransparencyFormat0.AssignTo(Dest: TPersistent); begin if Dest is TPngTransparencyFormat0 then with TPngTransparencyFormat0(Dest) do begin FGraySampleValue := Self.FGraySampleValue; end else inherited; end; function TPngTransparencyFormat0.GetChunkSize: Cardinal; begin Result := 2; end; procedure TPngTransparencyFormat0.ReadFromStream(Stream: TStream); begin inherited; FGraySampleValue := BigEndian.ReadWord(Stream); end; procedure TPngTransparencyFormat0.WriteToStream(Stream: TStream); begin inherited; BigEndian.WriteWord(Stream, FGraySampleValue); end; { TPngTransparencyFormat2 } procedure TPngTransparencyFormat2.AssignTo(Dest: TPersistent); begin if Dest is TPngTransparencyFormat2 then with TPngTransparencyFormat2(Dest) do begin FRedSampleValue := Self.FRedSampleValue; FBlueSampleValue := Self.FBlueSampleValue; FGreenSampleValue := Self.FGreenSampleValue; end else inherited; end; function TPngTransparencyFormat2.GetChunkSize: Cardinal; begin Result := 6; end; procedure TPngTransparencyFormat2.ReadFromStream(Stream: TStream); begin inherited; FRedSampleValue := BigEndian.ReadWord(Stream); FBlueSampleValue := BigEndian.ReadWord(Stream); FGreenSampleValue := BigEndian.ReadWord(Stream); end; procedure TPngTransparencyFormat2.WriteToStream(Stream: TStream); begin inherited; BigEndian.WriteWord(Stream, FRedSampleValue); BigEndian.WriteWord(Stream, FBlueSampleValue); BigEndian.WriteWord(Stream, FGreenSampleValue); end; { TPngTransparencyFormat3 } procedure TPngTransparencyFormat3.AssignTo(Dest: TPersistent); begin if Dest is TPngTransparencyFormat3 then with TPngTransparencyFormat3(Dest) do begin SetLength(FTransparency, Length(Self.FTransparency)); Move(Self.FTransparency[0], FTransparency, Length(FTransparency)); end else inherited; end; function TPngTransparencyFormat3.GetChunkSize: Cardinal; begin Result := Count; end; function TPngTransparencyFormat3.GetCount: Cardinal; begin Result := Length(FTransparency); end; function TPngTransparencyFormat3.GetTransparency(Index: Cardinal): Byte; begin if Index < Count then Result := FTransparency[Index] else raise EPngError.Create(RCStrIndexOutOfBounds); end; procedure TPngTransparencyFormat3.ReadFromStream(Stream: TStream); begin inherited; SetLength(FTransparency, Stream.Size - Stream.Position); Stream.Read(FTransparency[0], Length(FTransparency)); end; procedure TPngTransparencyFormat3.WriteToStream(Stream: TStream); begin inherited; Stream.Write(FTransparency[0], Length(FTransparency)); end; { TChunkPngPhysicalPixelDimensions } procedure TChunkPngPhysicalPixelDimensions.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngPhysicalPixelDimensions then with TChunkPngPhysicalPixelDimensions(Dest) do begin FPixelsPerUnitX := Self.FPixelsPerUnitX; FPixelsPerUnitY := Self.FPixelsPerUnitY; FUnit := Self.FUnit; end else inherited; end; class function TChunkPngPhysicalPixelDimensions.GetClassChunkName: TChunkName; begin Result := 'pHYs'; end; function TChunkPngPhysicalPixelDimensions.GetChunkSize: Cardinal; begin Result := 9; end; procedure TChunkPngPhysicalPixelDimensions.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); // read pixels per unit, X axis FPixelsPerUnitX := BigEndian.ReadCardinal(Stream); // read pixels per unit, Y axis FPixelsPerUnitY := BigEndian.ReadCardinal(Stream); // read unit Stream.Read(FUnit, 1); end; procedure TChunkPngPhysicalPixelDimensions.WriteToStream(Stream: TStream); begin // write pixels per unit, X axis BigEndian.WriteCardinal(Stream, FPixelsPerUnitX); // write pixels per unit, Y axis BigEndian.WriteCardinal(Stream, FPixelsPerUnitY); // write unit Stream.Write(FUnit, 1); end; { TChunkPngPhysicalScale } procedure TChunkPngPhysicalScale.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngPhysicalScale then with TChunkPngPhysicalScale(Dest) do begin FUnitSpecifier := Self.FUnitSpecifier; FUnitsPerPixelX := Self.FUnitsPerPixelX; FUnitsPerPixelY := Self.FUnitsPerPixelY; end else inherited; end; class function TChunkPngPhysicalScale.GetClassChunkName: TChunkName; begin Result := 'sCAL'; end; function TChunkPngPhysicalScale.GetChunkSize: Cardinal; begin Result := 4; end; procedure TChunkPngPhysicalScale.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); // read unit specifier Stream.Read(FUnitSpecifier, 1); // yet todo, see http://www.libpng.org/pub/png/book/chapter11.html#png.ch11.div.9 end; procedure TChunkPngPhysicalScale.WriteToStream(Stream: TStream); begin raise EPngError.CreateFmt(RCStrChunkNotImplemented, [ChunkNameAsString]); // yet todo, see http://www.libpng.org/pub/png/book/chapter11.html#png.ch11.div.9 end; { TChunkPngImageOffset } procedure TChunkPngImageOffset.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngImageOffset then with TChunkPngImageOffset(Dest) do begin FImagePositionX := Self.FImagePositionX; FImagePositionY := Self.FImagePositionY; FUnitSpecifier := Self.FUnitSpecifier; end else inherited; end; class function TChunkPngImageOffset.GetClassChunkName: TChunkName; begin Result := 'oFFs'; end; function TChunkPngImageOffset.GetChunkSize: Cardinal; begin Result := 9; end; procedure TChunkPngImageOffset.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); // read image positions FImagePositionX := BigEndian.ReadCardinal(Stream); FImagePositionY := BigEndian.ReadCardinal(Stream); // read unit specifier Stream.Read(FUnitSpecifier, 1); end; procedure TChunkPngImageOffset.WriteToStream(Stream: TStream); begin // write image positions BigEndian.WriteCardinal(Stream, FImagePositionX); BigEndian.WriteCardinal(Stream, FImagePositionY); // write unit specifier Stream.Write(FUnitSpecifier, 1); end; { TChunkPngPixelCalibrator } procedure TChunkPngPixelCalibrator.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngPixelCalibrator then with TChunkPngPixelCalibrator(Dest) do begin FCalibratorName := Self.FCalibratorName; FOriginalZeroes[0] := Self.FOriginalZeroes[0]; FOriginalZeroes[1] := Self.FOriginalZeroes[1]; FEquationType := Self.FEquationType; FNumberOfParams := Self.FNumberOfParams; FUnitName := Self.FUnitName; end else inherited; end; class function TChunkPngPixelCalibrator.GetClassChunkName: TChunkName; begin Result := 'pCAL'; end; function TChunkPngPixelCalibrator.GetChunkSize: Cardinal; begin Result := 9; end; procedure TChunkPngPixelCalibrator.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); var Index : Integer; ParamIndex : Integer; begin // read keyword Index := 1; SetLength(FCalibratorName, 80); while (Stream.Position < Stream.Size) do begin Stream.Read(FCalibratorName[Index], SizeOf(Byte)); if FCalibratorName[Index] = #0 then begin SetLength(FCalibratorName, Index - 1); Break; end; Inc(Index); end; // read original zeros FOriginalZeroes[0] := BigEndian.ReadCardinal(Stream); FOriginalZeroes[1] := BigEndian.ReadCardinal(Stream); // read equation type Stream.Read(FEquationType, 1); // read number of parameters Stream.Read(FNumberOfParams, 1); // read keyword Index := 1; SetLength(FUnitName, 80); while (Stream.Position < Stream.Size) do begin Stream.Read(FUnitName[Index], SizeOf(Byte)); if FUnitName[Index] = #0 then begin SetLength(FUnitName, Index - 1); Break; end; Inc(Index); end; for ParamIndex := 0 to FNumberOfParams - 2 do begin // yet todo end; end; procedure TChunkPngPixelCalibrator.WriteToStream(Stream: TStream); begin inherited; end; { TCustomChunkPngText } procedure TCustomChunkPngText.AssignTo(Dest: TPersistent); begin if Dest is TCustomChunkPngText then with TCustomChunkPngText(Dest) do begin FKeyword := Self.FKeyword; FText := Self.FText; end else inherited; end; procedure TCustomChunkPngText.SetKeyword(const Value: AnsiString); begin if FKeyword <> Value then begin FKeyword := Value; KeywordChanged; end; end; procedure TCustomChunkPngText.SetText(const Value: AnsiString); begin if FText <> Value then begin FText := Value; TextChanged; end; end; procedure TCustomChunkPngText.KeywordChanged; begin // yet empty end; procedure TCustomChunkPngText.TextChanged; begin // yet empty end; { TChunkPngText } class function TChunkPngText.GetClassChunkName: TChunkName; begin Result := 'tEXt'; end; function TChunkPngText.GetChunkSize: Cardinal; begin Result := Length(FKeyword) + Length(FText) + 1; end; procedure TChunkPngText.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); var Index : Integer; begin // read keyword Index := 1; SetLength(FKeyword, 80); while (Stream.Position < Stream.Size) do begin Stream.Read(FKeyword[Index], SizeOf(Byte)); if FKeyword[Index] = #0 then begin SetLength(FKeyword, Index - 1); Break; end; Inc(Index); if (Index > High(FKeyword)) then raise EPngError.Create(RCStrChunkInvalid); end; // read text SetLength(FText, Stream.Size - Stream.Position); if (Stream.Position < Stream.Size) then Stream.Read(FText[1], SizeOf(Byte)*(Stream.Size-Stream.Position)); end; procedure TChunkPngText.WriteToStream(Stream: TStream); var Temp : Byte; begin // write keyword Stream.Write(FKeyword[1], Length(FKeyword)); // write separator Temp := 0; Stream.Write(Temp, 1); // write text if (Length(FText) > 0) then Stream.Write(FText[1], Length(FText)); end; { TChunkPngCompressedText } procedure TChunkPngCompressedText.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngCompressedText then with TChunkPngCompressedText(Dest) do begin FCompressionMethod := Self.FCompressionMethod; end else inherited; end; class function TChunkPngCompressedText.GetClassChunkName: TChunkName; begin Result := 'zTXt'; end; function TChunkPngCompressedText.GetChunkSize: Cardinal; var OutputStream: TMemoryStream; begin // calculate chunk size Result := Length(FKeyword) + 1 + 1; // +1 = separator, +1 = compression method if (Length(FText) > 0) then begin OutputStream := TMemoryStream.Create; try // compress text ZCompress(@FText[1], Length(FText), OutputStream); Inc(Result, OutputStream.Size); finally OutputStream.Free; end; end; end; procedure TChunkPngCompressedText.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); var DataIn : Pointer; DataInSize : Integer; Output : TMemoryStream; Index : Integer; begin inherited; // read keyword and null separator Index := 1; SetLength(FKeyword, 80); while (Stream.Position < Stream.Size) do begin Stream.Read(FKeyword[Index], SizeOf(Byte)); if FKeyword[Index] = #0 then begin SetLength(FKeyword, Index - 1); Break; end; Inc(Index); if (Index > High(FKeyword)) then raise EPngError.Create(RCStrChunkInvalid); end; // read compression method Stream.Read(FCompressionMethod, SizeOf(Byte)); if FCompressionMethod <> 0 then raise EPngError.Create(RCStrUnsupportedCompressMethod); // read text DataInSize := Stream.Size - Stream.Position; GetMem(DataIn, DataInSize); try Stream.Read(DataIn^, DataInSize); Output := TMemoryStream.Create; try ZDecompress(DataIn, DataInSize, Output); SetLength(FText, Output.Size); Move(Output.Memory^, FText[1], Output.Size); finally Output.Free; end; finally FreeMem(DataIn); end; end; procedure TChunkPngCompressedText.SetCompressionMethod(const Value: Byte); begin if Value <> 0 then raise EPngError.Create(RCStrUnsupportedCompressMethod); FCompressionMethod := Value; end; procedure TChunkPngCompressedText.WriteToStream(Stream: TStream); var OutputStream: TMemoryStream; Temp : Byte; begin if (Length(FKeyword) = 0) then raise EPngError.Create(RCStrChunkInvalid); // write keyword Stream.Write(FKeyword[1], Length(FKeyword)); // write separator Temp := 0; Stream.Write(Temp, 1); // write compression method Stream.Write(FCompressionMethod, SizeOf(Byte)); if (Length(FText) > 0) then begin OutputStream := TMemoryStream.Create; try // compress text ZCompress(@FText[1], Length(FText), OutputStream); // write text Stream.Write(OutputStream.Memory^, OutputStream.Size); finally OutputStream.Free; end; end; end; { TChunkPngInternationalText } {$ifdef PNG_CHUNK_INTERNATIONAL_TEXT} procedure TChunkPngInternationalText.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngInternationalText then with TChunkPngInternationalText(Dest) do begin FCompressionMethod := Self.FCompressionMethod; FCompressionFlag := Self.FCompressionFlag; FLanguageString := Self.FLanguageString; FTranslatedKeyword := Self.FTranslatedKeyword; end else inherited; end; class function TChunkPngInternationalText.GetClassChunkName: TChunkName; begin Result := 'iTXt'; end; function TChunkPngInternationalText.GetChunkSize: Cardinal; begin Result := 0; end; procedure TChunkPngInternationalText.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); var Index : Integer; begin inherited; // read keyword Index := 1; SetLength(FKeyword, 80); while (Stream.Position < Stream.Size) do begin Stream.Read(FKeyword[Index], SizeOf(Byte)); if FKeyword[Index] = #0 then begin SetLength(FKeyword, Index - 1); Break; end; Inc(Index); end; // read compression flag Stream.Read(FCompressionFlag, SizeOf(Byte)); // read compression method Stream.Read(FCompressionMethod, SizeOf(Byte)); // read language string Index := 1; SetLength(FLanguageString, 10); while (Stream.Position < Stream.Size) do begin Stream.Read(FLanguageString[Index], SizeOf(Byte)); if FLanguageString[Index] = #0 then begin SetLength(FLanguageString, Index - 1); Break; end; Inc(Index); end; // yet todo! Exit; end; procedure TChunkPngInternationalText.WriteToStream(Stream: TStream); begin // TODO raise EPngError.CreateFmt(RCStrChunkNotImplemented, [ChunkNameAsString]); end; {$endif PNG_CHUNK_INTERNATIONAL_TEXT} { TChunkPngImageData } constructor TChunkPngImageData.Create; begin inherited; FData := TMemoryStream.Create; end; destructor TChunkPngImageData.Destroy; begin FData.Free; inherited; end; procedure TChunkPngImageData.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngImageData then with TChunkPngImageData(Dest) do begin FData.Seek(0, soFromBeginning); Self.FData.Seek(0, soFromBeginning); FData.CopyFrom(Self.FData, Self.FData.Size); FData.Seek(0, soFromBeginning); end else inherited; end; class function TChunkPngImageData.GetClassChunkName: TChunkName; begin Result := 'IDAT'; end; function TChunkPngImageData.GetChunkSize: Cardinal; begin Result := FData.Size; end; procedure TChunkPngImageData.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin inherited; FData.CopyFrom(Stream, ChunkSize); end; procedure TChunkPngImageData.WriteToStream(Stream: TStream); begin FData.Seek(0, soFromBeginning); Stream.CopyFrom(FData, FData.Size); end; { TChunkPngTime } procedure TChunkPngTime.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngTime then with TChunkPngTime(Dest) do begin FYear := Self.FYear; FMonth := Self.FMonth; FDay := Self.FDay; FHour := Self.FHour; FMinute := Self.FMinute; FSecond := Self.FSecond; end else inherited; end; class function TChunkPngTime.GetClassChunkName: TChunkName; begin Result := 'tIME'; end; function TChunkPngTime.GetModifiedDateTime: TDateTime; begin Result := EncodeDate(Year, Month, Day) + EncodeTime(Hour, Minute, Second, 0); end; function TChunkPngTime.GetChunkSize: Cardinal; begin Result := 7; end; procedure TChunkPngTime.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); // read year FYear := BigEndian.ReadWord(Stream); // read month Stream.Read(FMonth, SizeOf(Byte)); // read day Stream.Read(FDay, SizeOf(Byte)); // read hour Stream.Read(FHour, SizeOf(Byte)); // read minute Stream.Read(FMinute, SizeOf(Byte)); // read second Stream.Read(FSecond, SizeOf(Byte)); end; procedure TChunkPngTime.WriteToStream(Stream: TStream); begin // write year BigEndian.WriteWord(Stream, FYear); // write month Stream.Write(FMonth, SizeOf(Byte)); // write day Stream.Write(FDay, SizeOf(Byte)); // write hour Stream.Write(FHour, SizeOf(Byte)); // write minute Stream.Write(FMinute, SizeOf(Byte)); // write second Stream.Write(FSecond, SizeOf(Byte)); end; procedure TChunkPngTime.SetModifiedDateTime(const Value: TDateTime); var mnth : Word; day : Word; hour : Word; min : Word; sec : Word; msec : Word; begin DecodeDate(Value, FYear, mnth, day); FMonth := mnth; FDay := day; DecodeTime(Value, hour, min, sec, msec); FHour := hour; FMinute := min; FSecond := sec; end; { TChunkPngEmbeddedIccProfile } procedure TChunkPngEmbeddedIccProfile.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngEmbeddedIccProfile then with TChunkPngEmbeddedIccProfile(Dest) do begin FProfileName := Self.FProfileName; FCompressionMethod := Self.FCompressionMethod; end else inherited; end; class function TChunkPngEmbeddedIccProfile.GetClassChunkName: TChunkName; begin Result := 'iCCP'; end; function TChunkPngEmbeddedIccProfile.GetChunkSize: Cardinal; begin Result := Length(FProfileName) + 2; end; procedure TChunkPngEmbeddedIccProfile.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); var Index : Integer; begin // read keyword Index := 1; SetLength(FProfileName, 80); while (Stream.Position < Stream.Size) do begin Stream.Read(FProfileName[Index], SizeOf(Byte)); if FProfileName[Index] = #0 then begin SetLength(FProfileName, Index - 1); Break; end; Inc(Index); end; // read compression method Stream.Read(FCompressionMethod, 1); // not yet completed end; procedure TChunkPngEmbeddedIccProfile.WriteToStream(Stream: TStream); var Temp : Byte; begin // write keyword Stream.Write(FProfileName[1], Length(FProfileName)); // write separator Temp := 0; Stream.Write(Temp, 1); // write compression method Stream.Write(FCompressionMethod, 1); end; { TChunkPngGamma } procedure TChunkPngGamma.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngGamma then with TChunkPngGamma(Dest) do begin FGamma := Self.FGamma; end else inherited; end; class function TChunkPngGamma.GetClassChunkName: TChunkName; begin Result := 'gAMA'; end; function TChunkPngGamma.GetGammaAsSingle: Single; begin Result := FGamma * 1E-5; end; procedure TChunkPngGamma.SetGammaAsSingle(const Value: Single); begin FGamma := Round(Value * 1E5); end; function TChunkPngGamma.GetChunkSize: Cardinal; begin Result := 4; end; procedure TChunkPngGamma.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); // read gamma FGamma := BigEndian.ReadCardinal(Stream); end; procedure TChunkPngGamma.WriteToStream(Stream: TStream); begin // write gamma BigEndian.WriteCardinal(Stream, FGamma); end; { TChunkPngStandardColorSpaceRGB } procedure TChunkPngStandardColorSpaceRGB.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngStandardColorSpaceRGB then with TChunkPngStandardColorSpaceRGB(Dest) do begin FRenderingIntent := Self.FRenderingIntent; end else inherited; end; class function TChunkPngStandardColorSpaceRGB.GetClassChunkName: TChunkName; begin Result := 'sRGB'; end; function TChunkPngStandardColorSpaceRGB.GetChunkSize: Cardinal; begin Result := 1; end; procedure TChunkPngStandardColorSpaceRGB.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); // read rendering intent Stream.Read(FRenderingIntent, SizeOf(Byte)); end; procedure TChunkPngStandardColorSpaceRGB.WriteToStream(Stream: TStream); begin // write rendering intent Stream.Write(FRenderingIntent, SizeOf(Byte)); end; { TChunkPngPrimaryChromaticities } class function TChunkPngPrimaryChromaticities.GetClassChunkName: TChunkName; begin Result := 'cHRM'; end; procedure TChunkPngPrimaryChromaticities.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngPrimaryChromaticities then with TChunkPngPrimaryChromaticities(Dest) do begin FWhiteX := Self.FWhiteX; FWhiteY := Self.FWhiteY; FRedX := Self.FRedX; FRedY := Self.FRedY; FGreenX := Self.FGreenX; FGreenY := Self.FGreenY; FBlueX := Self.FBlueX; FBlueY := Self.FBlueY; end else inherited; end; function TChunkPngPrimaryChromaticities.GetBlueX: Single; begin Result := FBlueX * 1E-5; end; function TChunkPngPrimaryChromaticities.GetBlueY: Single; begin Result := FBlueY * 1E-5; end; function TChunkPngPrimaryChromaticities.GetGreenX: Single; begin Result := FGreenX * 1E-5; end; function TChunkPngPrimaryChromaticities.GetGreenY: Single; begin Result := FGreenY * 1E-5; end; function TChunkPngPrimaryChromaticities.GetRedX: Single; begin Result := FRedX * 1E-5; end; function TChunkPngPrimaryChromaticities.GetRedY: Single; begin Result := FRedY * 1E-5; end; function TChunkPngPrimaryChromaticities.GetWhiteX: Single; begin Result := FWhiteX * 1E-5; end; function TChunkPngPrimaryChromaticities.GetWhiteY: Single; begin Result := FWhiteY * 1E-5; end; function TChunkPngPrimaryChromaticities.GetChunkSize: Cardinal; begin Result := 32; end; procedure TChunkPngPrimaryChromaticities.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); // read white point x FWhiteX := BigEndian.ReadCardinal(Stream); // read white point y FWhiteY := BigEndian.ReadCardinal(Stream); // read red x FRedX := BigEndian.ReadCardinal(Stream); // read red y FRedY := BigEndian.ReadCardinal(Stream); // read green x FGreenX := BigEndian.ReadCardinal(Stream); // read green y FGreenY := BigEndian.ReadCardinal(Stream); // read blue x FBlueX := BigEndian.ReadCardinal(Stream); // read blue y FBlueY := BigEndian.ReadCardinal(Stream); end; procedure TChunkPngPrimaryChromaticities.WriteToStream(Stream: TStream); begin // write white point x BigEndian.WriteCardinal(Stream, FWhiteX); // write white point y BigEndian.WriteCardinal(Stream, FWhiteY); // write red x BigEndian.WriteCardinal(Stream, FRedX); // write red y BigEndian.WriteCardinal(Stream, FRedY); // write green x BigEndian.WriteCardinal(Stream, FGreenX); // write green y BigEndian.WriteCardinal(Stream, FGreenY); // write blue x BigEndian.WriteCardinal(Stream, FBlueX); // write blue y BigEndian.WriteCardinal(Stream, FBlueY); end; procedure TChunkPngPrimaryChromaticities.SetBlueX(const Value: Single); begin FBlueX := Round(Value * 1E5); end; procedure TChunkPngPrimaryChromaticities.SetBlueY(const Value: Single); begin FBlueY := Round(Value * 1E5); end; procedure TChunkPngPrimaryChromaticities.SetGreenX(const Value: Single); begin FGreenX := Round(Value * 1E5); end; procedure TChunkPngPrimaryChromaticities.SetGreenY(const Value: Single); begin FGreenY := Round(Value * 1E5); end; procedure TChunkPngPrimaryChromaticities.SetRedX(const Value: Single); begin FRedX := Round(Value * 1E5); end; procedure TChunkPngPrimaryChromaticities.SetRedY(const Value: Single); begin FRedY := Round(Value * 1E5); end; procedure TChunkPngPrimaryChromaticities.SetWhiteX(const Value: Single); begin FWhiteX := Round(Value * 1E5); end; procedure TChunkPngPrimaryChromaticities.SetWhiteY(const Value: Single); begin FWhiteY := Round(Value * 1E5); end; { TPngSignificantBitsFormat0 } constructor TPngSignificantBitsFormat0.Create(BitDepth: Integer = 8); begin inherited; FGrayBits := BitDepth; end; procedure TPngSignificantBitsFormat0.AssignTo(Dest: TPersistent); begin if Dest is TPngSignificantBitsFormat0 then with TPngSignificantBitsFormat0(Dest) do begin FGrayBits := Self.FGrayBits; end else inherited; end; class function TPngSignificantBitsFormat0.GetChunkSize: Cardinal; begin Result := 1; end; procedure TPngSignificantBitsFormat0.ReadFromStream(Stream: TStream); begin Stream.Read(FGrayBits, 1); end; procedure TPngSignificantBitsFormat0.WriteToStream(Stream: TStream); begin Stream.Write(FGrayBits, 1); end; { TPngSignificantBitsFormat23 } constructor TPngSignificantBitsFormat23.Create(BitDepth: Integer = 8); begin inherited; FRedBits := BitDepth; FGreenBits := BitDepth; FBlueBits := BitDepth; end; procedure TPngSignificantBitsFormat23.AssignTo(Dest: TPersistent); begin if Dest is TPngSignificantBitsFormat23 then with TPngSignificantBitsFormat23(Dest) do begin FRedBits := Self.FRedBits; FBlueBits := Self.FBlueBits; FGreenBits := Self.FGreenBits; end else inherited; end; class function TPngSignificantBitsFormat23.GetChunkSize: Cardinal; begin Result := 3; end; procedure TPngSignificantBitsFormat23.ReadFromStream(Stream: TStream); begin Stream.Read(FRedBits, 1); Stream.Read(FGreenBits, 1); Stream.Read(FBlueBits, 1); end; procedure TPngSignificantBitsFormat23.WriteToStream(Stream: TStream); begin Stream.Write(FRedBits, 1); Stream.Write(FGreenBits, 1); Stream.Write(FBlueBits, 1); end; { TPngSignificantBitsFormat4 } constructor TPngSignificantBitsFormat4.Create(BitDepth: Integer = 8); begin inherited; FGrayBits := BitDepth; FAlphaBits := BitDepth; end; procedure TPngSignificantBitsFormat4.AssignTo(Dest: TPersistent); begin if Dest is TPngSignificantBitsFormat4 then with TPngSignificantBitsFormat4(Dest) do begin FGrayBits := Self.FGrayBits; FAlphaBits := Self.FAlphaBits; end else if Dest is TPngSignificantBitsFormat0 then with TPngSignificantBitsFormat0(Dest) do FGrayBits := Self.FGrayBits else inherited; end; class function TPngSignificantBitsFormat4.GetChunkSize: Cardinal; begin Result := 2; end; procedure TPngSignificantBitsFormat4.ReadFromStream(Stream: TStream); begin Stream.Read(FGrayBits, 1); Stream.Read(FAlphaBits, 1); end; procedure TPngSignificantBitsFormat4.WriteToStream(Stream: TStream); begin Stream.Write(FGrayBits, 1); Stream.Write(FAlphaBits, 1); end; { TPngSignificantBitsFormat6 } constructor TPngSignificantBitsFormat6.Create(BitDepth: Integer = 8); begin inherited; FRedBits := BitDepth; FGreenBits := BitDepth; FBlueBits := BitDepth; FAlphaBits := BitDepth; end; procedure TPngSignificantBitsFormat6.AssignTo(Dest: TPersistent); begin if Dest is TPngSignificantBitsFormat6 then with TPngSignificantBitsFormat6(Dest) do begin FRedBits := Self.FRedBits; FBlueBits := Self.FBlueBits; FGreenBits := Self.FGreenBits; FAlphaBits := Self.FAlphaBits; end else if Dest is TPngSignificantBitsFormat23 then with TPngSignificantBitsFormat23(Dest) do begin FRedBits := Self.FRedBits; FBlueBits := Self.FBlueBits; FGreenBits := Self.FGreenBits; end else inherited; end; class function TPngSignificantBitsFormat6.GetChunkSize: Cardinal; begin Result := 4; end; procedure TPngSignificantBitsFormat6.ReadFromStream(Stream: TStream); begin Stream.Read(FRedBits, 1); Stream.Read(FGreenBits, 1); Stream.Read(FBlueBits, 1); Stream.Read(FAlphaBits, 1); end; procedure TPngSignificantBitsFormat6.WriteToStream(Stream: TStream); begin Stream.Write(FRedBits, 1); Stream.Write(FGreenBits, 1); Stream.Write(FBlueBits, 1); Stream.Write(FAlphaBits, 1); end; { TChunkPngSignificantBits } procedure TChunkPngSignificantBits.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngSignificantBits then with TChunkPngSignificantBits(Dest) do begin FSignificantBits.Assign(Self.FSignificantBits); end else inherited; end; constructor TChunkPngSignificantBits.Create(Header: TChunkPngImageHeader); begin inherited; case Header.ColorType of ctGrayscale: FSignificantBits := TPngSignificantBitsFormat0.Create(Header.BitDepth); ctTrueColor, ctIndexedColor: FSignificantBits := TPngSignificantBitsFormat23.Create(Header.BitDepth); ctGrayscaleAlpha: FSignificantBits := TPngSignificantBitsFormat4.Create(Header.BitDepth); ctTrueColorAlpha: FSignificantBits := TPngSignificantBitsFormat6.Create(Header.BitDepth); end; end; destructor TChunkPngSignificantBits.Destroy; begin FSignificantBits.Free; inherited; end; class function TChunkPngSignificantBits.GetClassChunkName: TChunkName; begin Result := 'sBIT'; end; procedure TChunkPngSignificantBits.HeaderChanged; var OldSignificantBits : TCustomPngSignificantBits; begin inherited; // store old SignificantBits object OldSignificantBits := FSignificantBits; // change SignificantBits object class case FHeader.ColorType of ctGrayscale: if not (FSignificantBits is TPngSignificantBitsFormat0) then FSignificantBits := TPngSignificantBitsFormat0.Create(FHeader.BitDepth); ctTrueColor, ctIndexedColor: if not (FSignificantBits is TPngSignificantBitsFormat23) then FSignificantBits := TPngSignificantBitsFormat23.Create(FHeader.BitDepth); ctTrueColorAlpha: if not (FSignificantBits is TPngSignificantBitsFormat4) then FSignificantBits := TPngSignificantBitsFormat4.Create(FHeader.BitDepth); ctGrayscaleAlpha : if not (FSignificantBits is TPngSignificantBitsFormat6) then FSignificantBits := TPngSignificantBitsFormat6.Create(FHeader.BitDepth); else FSignificantBits := nil; end; if (OldSignificantBits <> nil) and (OldSignificantBits <> FSignificantBits) then begin if (FSignificantBits <> nil) then FSignificantBits.Assign(OldSignificantBits); OldSignificantBits.Free; end; end; function TChunkPngSignificantBits.GetChunkSize: Cardinal; begin if (FSignificantBits <> nil) then Result := FSignificantBits.GetChunkSize else Result := 0; end; procedure TChunkPngSignificantBits.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); if (FSignificantBits <> nil) then FSignificantBits.ReadFromStream(Stream); end; procedure TChunkPngSignificantBits.WriteToStream(Stream: TStream); begin if (FSignificantBits <> nil) then FSignificantBits.WriteToStream(Stream); end; { TPngBackgroundColorFormat04 } procedure TPngBackgroundColorFormat04.AssignTo(Dest: TPersistent); begin if Dest is TPngBackgroundColorFormat04 then with TPngBackgroundColorFormat04(Dest) do begin FGraySampleValue := Self.FGraySampleValue; end else inherited; end; class function TPngBackgroundColorFormat04.GetChunkSize: Cardinal; begin Result := 2; end; procedure TPngBackgroundColorFormat04.ReadFromStream(Stream: TStream); begin FGraySampleValue := BigEndian.ReadWord(Stream); end; procedure TPngBackgroundColorFormat04.WriteToStream(Stream: TStream); begin BigEndian.WriteWord(Stream, FGraySampleValue); end; { TPngBackgroundColorFormat26 } procedure TPngBackgroundColorFormat26.AssignTo(Dest: TPersistent); begin if Dest is TPngBackgroundColorFormat26 then with TPngBackgroundColorFormat26(Dest) do begin FRedSampleValue := Self.FRedSampleValue; FBlueSampleValue := Self.FBlueSampleValue; FGreenSampleValue := Self.FGreenSampleValue; end else inherited; end; class function TPngBackgroundColorFormat26.GetChunkSize: Cardinal; begin Result := 6; end; procedure TPngBackgroundColorFormat26.ReadFromStream(Stream: TStream); begin FRedSampleValue := BigEndian.ReadWord(Stream); FGreenSampleValue := BigEndian.ReadWord(Stream); FBlueSampleValue := BigEndian.ReadWord(Stream); end; procedure TPngBackgroundColorFormat26.WriteToStream(Stream: TStream); begin BigEndian.WriteWord(Stream, FRedSampleValue); BigEndian.WriteWord(Stream, FGreenSampleValue); BigEndian.WriteWord(Stream, FBlueSampleValue); end; { TPngBackgroundColorFormat3 } procedure TPngBackgroundColorFormat3.AssignTo(Dest: TPersistent); begin if Dest is TPngBackgroundColorFormat3 then with TPngBackgroundColorFormat3(Dest) do begin FIndex := Self.FIndex; end else inherited; end; class function TPngBackgroundColorFormat3.GetChunkSize: Cardinal; begin Result := 1; end; procedure TPngBackgroundColorFormat3.ReadFromStream(Stream: TStream); begin Stream.Read(FIndex, 1); end; procedure TPngBackgroundColorFormat3.WriteToStream(Stream: TStream); begin Stream.Write(FIndex, 1); end; { TChunkPngBackgroundColor } procedure TChunkPngBackgroundColor.AssignTo(Dest: TPersistent); begin if Dest is TChunkPngBackgroundColor then with TChunkPngBackgroundColor(Dest) do begin FBackground.Assign(Self.FBackground); end else inherited; end; constructor TChunkPngBackgroundColor.Create(Header: TChunkPngImageHeader); begin inherited; case Header.ColorType of ctGrayscale, ctGrayscaleAlpha: FBackground := TPngBackgroundColorFormat04.Create; ctTrueColor, ctTrueColorAlpha: FBackground := TPngBackgroundColorFormat26.Create; ctIndexedColor: FBackground := TPngBackgroundColorFormat3.Create; end; end; destructor TChunkPngBackgroundColor.Destroy; begin FBackground.Free; inherited; end; class function TChunkPngBackgroundColor.GetClassChunkName: TChunkName; begin Result := 'bKGD'; end; procedure TChunkPngBackgroundColor.HeaderChanged; var OldBackground : TCustomPngBackgroundColor; begin inherited; // store old background object OldBackground := FBackground; // change background object class case FHeader.ColorType of ctGrayscale, ctGrayscaleAlpha: if not (FBackground is TPngBackgroundColorFormat04) then FBackground := TPngBackgroundColorFormat04.Create; ctTrueColor, ctTrueColorAlpha : if not (FBackground is TPngBackgroundColorFormat26) then FBackground := TPngBackgroundColorFormat26.Create; ctIndexedColor : if not (FBackground is TPngBackgroundColorFormat3) then FBackground := TPngBackgroundColorFormat3.Create; else FBackground := nil; end; if (OldBackground <> nil) and (OldBackground <> FBackground) then begin if (FBackground <> nil) then FBackground.Assign(OldBackground); OldBackground.Free; end; end; function TChunkPngBackgroundColor.GetChunkSize: Cardinal; begin if (FBackground <> nil) then Result := FBackground.GetChunkSize else Result := 0; end; procedure TChunkPngBackgroundColor.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); begin if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); if (FBackground <> nil) then FBackground.ReadFromStream(Stream); end; procedure TChunkPngBackgroundColor.WriteToStream(Stream: TStream); begin if (FBackground <> nil) then FBackground.WriteToStream(Stream); end; { TChunkPngImageHistogram } class function TChunkPngImageHistogram.GetClassChunkName: TChunkName; begin Result := 'hIST'; end; function TChunkPngImageHistogram.GetCount: Cardinal; begin Result := Length(FHistogram); end; function TChunkPngImageHistogram.GetFrequency(Index: Cardinal): Word; begin if Index < Count then Result := FHistogram[Index] else raise Exception.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TChunkPngImageHistogram.GetChunkSize: Cardinal; begin Result := Count * SizeOf(Word); end; procedure TChunkPngImageHistogram.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); var Index : Integer; begin // check size if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); // adjust histogram array size SetLength(FHistogram, ChunkSize div 2); // read histogram data for Index := 0 to Length(FHistogram) - 1 do FHistogram[Index] := BigEndian.ReadWord(Stream); end; procedure TChunkPngImageHistogram.WriteToStream(Stream: TStream); var Index : Integer; begin // write histogram data for Index := 0 to Length(FHistogram) - 1 do BigEndian.WriteWord(Stream, FHistogram[Index]); end; { TChunkPngSuggestedPalette } {$ifdef PNG_CHUNK_SUGGESTED_PALETTE} constructor TChunkPngSuggestedPalette.Create(Header: TChunkPngImageHeader); begin inherited; FData := nil; FCount := 0; end; class function TChunkPngSuggestedPalette.GetClassChunkName: TChunkName; begin Result := 'sPLT'; end; function TChunkPngSuggestedPalette.GetCount: Cardinal; begin Result := FCount; end; function TChunkPngSuggestedPalette.GetChunkSize: Cardinal; begin Result := Cardinal(Length(FPaletteName)) + 2 + (4 * (FSampleDepth shr 3) + 2) * Count; end; procedure TChunkPngSuggestedPalette.ReadFromStream(Stream: TStream; ChunkSize: Cardinal); var Index : Integer; DataSize : Integer; begin if (Stream.Position+ChunkSize > Stream.Size) or (GetChunkSize > ChunkSize) then raise EPngError.Create(RCStrChunkSizeTooSmall); // read palette name Index := 1; SetLength(FPaletteName, 80); while (Stream.Position < ChunkSize) do begin Stream.Read(FPaletteName[Index], SizeOf(Byte)); if FPaletteName[Index] = #0 then begin SetLength(FPaletteName, Index - 1); Break; end; Inc(Index); end; // read sample depth Stream.Read(FSampleDepth, 1); DataSize := Integer(ChunkSize) - Length(FPaletteName) - 2; Assert(DataSize >= 0); Assert(DataSize mod 2 = 0); Assert(DataSize mod (4 * (FSampleDepth shr 3) + 2) = 0); FCount := DataSize div (4 * (FSampleDepth shr 3) + 2); ReallocMem(FData, DataSize); if FSampleDepth = 8 then for Index := 0 to FCount - 1 do with PSuggestedPalette8ByteArray(FData)^[Index] do begin Stream.Read(Red, 1); Stream.Read(Green, 1); Stream.Read(Blue, 1); Stream.Read(Alpha, 1); Frequency := BigEndian.ReadWord(Stream); end else if FSampleDepth = 16 then for Index := 0 to FCount - 1 do with PSuggestedPalette16ByteArray(FData)^[Index] do begin Red := BigEndian.ReadWord(Stream); Green := BigEndian.ReadWord(Stream); Blue := BigEndian.ReadWord(Stream); Alpha := BigEndian.ReadWord(Stream); Frequency := BigEndian.ReadWord(Stream); end; end; procedure TChunkPngSuggestedPalette.WriteToStream(Stream: TStream); begin // TODO raise EPngError.CreateFmt(RCStrChunkNotImplemented, [ChunkNameAsString]); end; {$endif PNG_CHUNK_SUGGESTED_PALETTE} { TChunkList } destructor TChunkList.Destroy; begin Clear; inherited; end; procedure TChunkList.Add(Item: TCustomChunk); begin SetLength(FChunks, Length(FChunks) + 1); FChunks[Length(FChunks) - 1] := Item; end; procedure TChunkList.AssignTo(Dest: TPersistent); var Index : Integer; ChunkClass : TCustomDefinedChunkWithHeaderClass; begin if Dest is TChunkList then with TChunkList(Dest) do begin Clear; SetLength(FChunks, Self.Count); for Index := 0 to Self.Count - 1 do if Self.FChunks[Index] is TCustomDefinedChunkWithHeader then begin ChunkClass := TCustomDefinedChunkWithHeaderClass(Self.FChunks[Index].ClassType); FChunks[Index] := ChunkClass.Create(TCustomDefinedChunkWithHeader(Self.FChunks[Index]).FHeader); FChunks[Index].Assign(Self.FChunks[Index]); end else inherited; end else inherited; end; procedure TChunkList.Clear; var Index : Integer; begin for Index := 0 to Count - 1 do FChunks[Index].Free; SetLength(FChunks, 0) end; procedure TChunkList.Delete(Index: Cardinal); begin if Index >= Count then raise EPngError.Create(RCStrEmptyChunkList); FChunks[Index].Free; if Index < Count then System.Move(FChunks[Index + 1], FChunks[Index], (Count - Index) * SizeOf(Pointer)); SetLength(FChunks, Length(FChunks) - 1); end; function TChunkList.GetChunk(Index: Integer): TCustomChunk; begin if Cardinal(Index) >= Cardinal(Count) then raise EPngError.CreateFmt(RCStrIndexOutOfBounds, [Index]) else Result := FChunks[Index]; end; function TChunkList.GetCount: Cardinal; begin Result := Length(FChunks); end; function TChunkList.IndexOf(Item: TCustomChunk): Integer; begin for Result := 0 to Count - 1 do if FChunks[Result] = Item then Exit; Result := -1; end; procedure TChunkList.Remove(Item: TCustomChunk); begin Delete(IndexOf(Item)); end; { TCustomPngCoder } constructor TCustomPngCoder.Create(Stream: TStream; Header: TChunkPngImageHeader; Gamma: TChunkPngGamma = nil; Palette: TChunkPngPalette = nil; Transparency : TCustomPngTransparency = nil); begin FStream := Stream; FHeader := Header; FGamma := Gamma; FPalette := Palette; FTransparency := Transparency; FMappingTable := nil; FAlphaTable := nil; BuildMappingTables; inherited Create; end; destructor TCustomPngCoder.Destroy; begin Dispose(FMappingTable); Dispose(FAlphaTable); inherited; end; procedure TCustomPngCoder.BuildMappingTables; var Index : Integer; Palette : PRGB24Array; FracVal : Single; Color : TRGB24; MaxByte : Byte; PreCalcGamma : Extended; const COne255th : Extended = 1 / 255; begin if FHeader.HasPalette then begin if (FPalette <> nil) then begin GetMem(FMappingTable, FPalette.Count * SizeOf(TRGB24)); Palette := PRGB24Array(FMappingTable); if (FGamma <> nil) then begin PreCalcGamma := 1 / (FGamma.Gamma * 2.2E-5); for Index := 0 to FPalette.Count - 1 do begin Color := FPalette.PaletteEntry[Index]; Palette[Index].R := Round(Power((Color.R * COne255th), PreCalcGamma) * 255); Palette[Index].G := Round(Power((Color.G * COne255th), PreCalcGamma) * 255); Palette[Index].B := Round(Power((Color.B * COne255th), PreCalcGamma) * 255); end; end else for Index := 0 to FPalette.Count - 1 do Palette[Index] := FPalette.PaletteEntry[Index]; end else begin // create gray scale palette GetMem(FMappingTable, 256 * SizeOf(TRGB24)); Palette := PRGB24Array(FMappingTable); MaxByte := ((1 shl FHeader.BitDepth) - 1) and $FF; FracVal := 1 / MaxByte; if (FGamma <> nil) then begin PreCalcGamma := 1 / (FGamma.Gamma * 2.2E-5); for Index := 0 to FPalette.Count - 1 do begin Palette[Index].R := Round(Power(Index * FracVal, PreCalcGamma) * 255); Palette[Index].G := Palette[Index].R; Palette[Index].B := Palette[Index].B; end; end else begin for Index := 0 to MaxByte do begin Palette[Index].R := Round(255 * (Index * FracVal)); Palette[Index].G := Palette[Index].R; Palette[Index].B := Palette[Index].R; end; end; end; // build alpha table GetMem(FAlphaTable, 256); FillChar(FAlphaTable^, 256, $FF); // eventually fill alpha table if FTransparency is TPngTransparencyFormat3 then with TPngTransparencyFormat3(FTransparency) do for Index := 0 to Count - 1 do FAlphaTable[Index] := Transparency[Index]; end else begin GetMem(FMappingTable, 256); if (FGamma <> nil) and (FGamma.Gamma <> 0) then begin PreCalcGamma := 1 / (FGamma.Gamma * 2.2E-5); for Index := 0 to $FF do FMappingTable[Index] := Round(Power((Index * COne255th), PreCalcGamma) * 255); end else for Index := 0 to $FF do FMappingTable[Index] := Index; end; end; procedure TCustomPngCoder.DecodeFilterSub(CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: NativeInt); {$IFDEF PUREPASCAL} var Index : Integer; begin for Index := PixelByteSize + 1 to BytesPerRow do CurrentRow[Index] := (CurrentRow[Index] + CurrentRow[Index - PixelByteSize]) and $FF; {$ELSE} asm {$IFDEF Target_x64} // RCX = Self // RDX = CurrentRow // R9 = BytesPerRow ADD RDX, 1 MOV RAX, RDX MOV RCX, BytesPerRow ADD RAX, PixelByteSize SUB RCX, PixelByteSize LEA RAX, [RAX + RCX] LEA RDX, [RDX + RCX] NEG RCX JNL @Done @Start: MOV R8B, [RAX + RCX].Byte ADD R8B, [RDX + RCX].Byte MOV [RAX + RCX].Byte, R8B ADD RCX, 1 JS @Start @Done: {$ENDIF} {$IFDEF Target_x86} ADD EDX, 1 MOV EAX, EDX MOV ECX, BytesPerRow.DWORD ADD EAX, PixelByteSize.DWORD SUB ECX, PixelByteSize.DWORD LEA EAX, [EAX + ECX] LEA EDX, [EDX + ECX] NEG ECX JNL @Done PUSH EBX @Start: MOV BL, [EAX + ECX].Byte ADD BL, [EDX + ECX].Byte MOV [EAX + ECX].Byte, BL ADD ECX, 1 JS @Start POP EBX @Done: {$ENDIF} {$ENDIF} end; procedure TCustomPngCoder.DecodeFilterUp(CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: NativeInt); {$IFDEF PUREPASCAL} var Index : Integer; begin for Index := 1 to BytesPerRow do CurrentRow[Index] := (CurrentRow[Index] + PreviousRow[Index]) and $FF; {$ELSE} asm {$IFDEF Target_x64} // RCX = Self // RDX = CurrentRow // R8 = PreviousRow // R9 = BytesPerRow MOV RAX, RDX MOV RDX, R8 MOV RCX, BytesPerRow LEA RAX, [RAX + RCX + 1] LEA RDX, [RDX + RCX + 1] NEG RCX JNL @Done @Start: MOV R8B, [RAX + RCX].Byte ADD R8B, [RDX + RCX].Byte MOV [RAX + RCX].Byte, R8B ADD RCX, 1 JS @Start @Done: {$ENDIF} {$IFDEF Target_x86} MOV EAX, EDX MOV EDX, ECX MOV ECX, BytesPerRow.DWORD LEA EAX, [EAX + ECX + 1] LEA EDX, [EDX + ECX + 1] NEG ECX JNL @Done PUSH EBX @Start: MOV BL, [EAX + ECX].Byte ADD BL, [EDX + ECX].Byte MOV [EAX + ECX].Byte, BL ADD ECX, 1 JS @Start POP EBX @Done: {$ENDIF} {$ENDIF} end; procedure TCustomPngCoder.DecodeFilterAverage(CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: NativeInt); var Index : Integer; begin for Index := 1 to PixelByteSize do CurrentRow[Index] := (CurrentRow[Index] + PreviousRow[Index] shr 1) and $FF; for Index := PixelByteSize + 1 to BytesPerRow do CurrentRow[Index] := (CurrentRow[Index] + (CurrentRow[Index - PixelByteSize] + PreviousRow[Index]) shr 1) and $FF; end; function PaethPredictor(a, b, c: Byte): Integer; {$IFNDEF TARGET_x64} pascal; {$ENDIF} {$IFDEF PUREPASCAL} var DistA, DistB, DistC: Integer; begin DistA := Abs(b - c); DistB := Abs(a - c); DistC := Abs(a + b - c * 2); if (DistA <= DistB) and (DistA <= DistC) then Result := a else if DistB <= DistC then Result := b else Result := c; {$ELSE} asm {$IFDEF TARGET_x64} // RCX = a // RDX = b // R8 = c // calculate DistA = Abs(b - c) MOVZX RAX, DL // RAX = b SUB RAX, R8 // RAX = b - c MOV R10, RAX // R10 = b - c JAE @PositiveDistA // if R10 >= 0 then NOT RAX // ... INC RAX // RAX = Abs(b - c) = DistA @PositiveDistA: // calculate DistB = Abs(a - c) MOVZX R11, CL // R11 = a SUB R11, R8 // R11 = a - c MOV R9, R11 // R9 = a - c JAE @PositiveDistB // if R9 >= 0 then NOT R11 // ... INC R11 // R11 = Abs(a - c) = DistB @PositiveDistB: // calculate DistC = Abs(a + b - c * 2) ADD R10, R9 // R10 = b - c + a - c = a + b - 2 * c JNL @PositiveDistC // if R10 >= 0 then NOT R10 // ... INC R10 // R10 = Abs(a + b - c * 2) = DistC @PositiveDistC: MOV R9, RAX // R9 = DistA SUB R9, R11 // R9 = DistA - DistB JA @NextCheck // if (DistA <= DistB) then MOV R9, RAX // R9 = DistA SUB R9, R10 // R9 = DistA - DistC JA @NextCheck // if (DistA <= DistC) then MOV RAX, RCX // RAX = a JMP @Done // Exit @NextCheck: MOV R9, R11 // R9 = DistB SUB R9, R10 // R9 = DistB - DistC JA @ResultC // if (DistB <= DistC) then MOV RAX, RDX // RAX = b JMP @Done @ResultC: MOV RAX, R8 // RAX = c @Done: {$ELSE} MOVZX EDX, c PUSH EBX MOVZX EAX, b SUB EAX, EDX JAE @PositiveDistA NOT EAX INC EAX @PositiveDistA: MOVZX EBX, a SUB EBX, EDX JAE @PositiveDistB NOT EBX INC EBX @PositiveDistB: MOVZX ECX, a SUB ECX, EDX MOVZX EDX, b ADD ECX, EDX MOVZX EDX, c SUB ECX, EDX JAE @PositiveDistC NOT ECX INC ECX @PositiveDistC: MOV EDX, EAX SUB EDX, EBX JA @NextCheck MOV EDX, EAX SUB EDX, ECX JA @NextCheck MOVZX EDX, a MOV Result, EDX JMP @Done @NextCheck: MOV EDX, EBX SUB EDX, ECX JA @ResultC MOVZX EDX, b MOV Result, EDX JMP @Done @ResultC: MOVZX EDX, c MOV Result, EDX @Done: POP EBX {$ENDIF} {$ENDIF} end; procedure TCustomPngCoder.DecodeFilterPaeth(CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: NativeInt); var Index : Integer; begin DecodeFilterUp(CurrentRow, PreviousRow, PixelByteSize, PixelByteSize); for Index := PixelByteSize + 1 to BytesPerRow do CurrentRow[Index] := (CurrentRow[Index] + PaethPredictor(CurrentRow[Index - PixelByteSize], PreviousRow[Index], PreviousRow[Index - PixelByteSize])) and $FF; end; procedure TCustomPngCoder.EncodeFilterSub(CurrentRow, PreviousRow, OutputRow: PByteArray; BytesPerRow, PixelByteSize: Integer); var Index : Integer; begin // copy first pixel Move(CurrentRow[1], OutputRow[1], PixelByteSize); for Index := PixelByteSize + 1 to BytesPerRow do OutputRow[Index] := (CurrentRow[Index] - CurrentRow[Index - PixelByteSize]) and $FF; end; procedure TCustomPngCoder.EncodeFilterUp(CurrentRow, PreviousRow, OutputRow: PByteArray; BytesPerRow, PixelByteSize: Integer); var Index : Integer; begin for Index := 1 to BytesPerRow do OutputRow[Index] := (CurrentRow[Index] - PreviousRow[Index]) and $FF; end; procedure TCustomPngCoder.EncodeFilterAverage(CurrentRow, PreviousRow, OutputRow: PByteArray; BytesPerRow, PixelByteSize: Integer); var Index : Integer; begin for Index := 1 to PixelByteSize do OutputRow[Index] := (CurrentRow[Index] - PreviousRow[Index] shr 1) and $FF; for Index := PixelByteSize + 1 to BytesPerRow do OutputRow[Index] := (CurrentRow[Index] - (CurrentRow[Index - PixelByteSize] + PreviousRow[Index]) shr 1) and $FF; end; procedure TCustomPngCoder.EncodeFilterPaeth(CurrentRow, PreviousRow, OutputRow: PByteArray; BytesPerRow, PixelByteSize: Integer); var Index : Integer; begin EncodeFilterUp(CurrentRow, PreviousRow, OutputRow, PixelByteSize, PixelByteSize); for Index := PixelByteSize + 1 to BytesPerRow do OutputRow[Index] := (CurrentRow[Index] - PaethPredictor(CurrentRow[Index - PixelByteSize], PreviousRow[Index], PreviousRow[Index - PixelByteSize])) and $FF; end; { TCustomPngDecoder } procedure TCustomPngDecoder.DecodeFilterRow(FilterMethod: TAdaptiveFilterMethod; CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: Integer); begin case FilterMethod of afmNone : ; afmSub : DecodeFilterSub(CurrentRow, PreviousRow, BytesPerRow, PixelByteSize); afmUp : DecodeFilterUp(CurrentRow, PreviousRow, BytesPerRow, PixelByteSize); afmAverage : DecodeFilterAverage(CurrentRow, PreviousRow, BytesPerRow, PixelByteSize); afmPaeth : DecodeFilterPaeth(CurrentRow, PreviousRow, BytesPerRow, PixelByteSize); else raise EPngError.Create(RCStrUnsupportedFilter); end; end; procedure TCustomPngDecoder.EncodeFilterRow(CurrentRow, PreviousRow, OutputRow, TempBuffer: PByteArray; BytesPerRow, PixelByteSize: Integer); begin raise Exception.Create('Class is only meant for decoding'); end; { TCustomPngEncoder } function CalculateRowSum(CurrentRow: PByteArray; BytesPerRow: Integer): Cardinal; var Index : Integer; begin Result := 0; for Index := 1 to BytesPerRow do Result := Result + Cardinal(Abs(SmallInt(CurrentRow[Index]))); end; procedure TCustomPngEncoder.EncodeFilterRow(CurrentRow, PreviousRow, OutputRow, TempBuffer: PByteArray; BytesPerRow, PixelByteSize: Integer); var PixelIndex : Integer; CurrentSum : Cardinal; BestSum : Cardinal; begin BestSum := 0; OutputRow^[0] := 0; for PixelIndex := 1 to BytesPerRow do BestSum := BestSum + CurrentRow[PixelIndex]; Move(CurrentRow^[1], OutputRow^[1], BytesPerRow); // check whether sub pre filter shall be used if aafmSub in FHeader.AdaptiveFilterMethods then begin // calculate sub filter EncodeFilterSub(CurrentRow, PreviousRow, TempBuffer, BytesPerRow, PixelByteSize); CurrentSum := CalculateRowSum(TempBuffer, BytesPerRow); // check if sub filter is the current best filter if CurrentSum < BestSum then begin BestSum := CurrentSum; Move(TempBuffer^[1], OutputRow^[1], BytesPerRow); OutputRow^[0] := 1; end; end; // check whether up pre filter shall be used if aafmUp in FHeader.AdaptiveFilterMethods then begin // calculate up filter EncodeFilterUp(CurrentRow, PreviousRow, TempBuffer, BytesPerRow, PixelByteSize); CurrentSum := CalculateRowSum(TempBuffer, BytesPerRow); // check if up filter is the current best filter if CurrentSum < BestSum then begin BestSum := CurrentSum; Move(TempBuffer^[1], OutputRow^[1], BytesPerRow); OutputRow^[0] := 2; end; end; // check whether average pre filter shall be used if aafmAverage in FHeader.AdaptiveFilterMethods then begin // calculate average filter EncodeFilterAverage(CurrentRow, PreviousRow, TempBuffer, BytesPerRow, PixelByteSize); CurrentSum := CalculateRowSum(TempBuffer, BytesPerRow); // check if average filter is the current best filter if CurrentSum < BestSum then begin BestSum := CurrentSum; Move(TempBuffer^[1], OutputRow^[1], BytesPerRow); OutputRow^[0] := 3; end; end; // check whether paeth pre filter shall be used if aafmPaeth in FHeader.AdaptiveFilterMethods then begin // calculate paeth filter EncodeFilterPaeth(CurrentRow, PreviousRow, TempBuffer, BytesPerRow, PixelByteSize); CurrentSum := CalculateRowSum(TempBuffer, BytesPerRow); // check if paeth filter is the current best filter if CurrentSum < BestSum then begin Move(TempBuffer^[1], OutputRow^[1], BytesPerRow); OutputRow^[0] := 4; end; end; end; procedure TCustomPngEncoder.DecodeFilterRow(FilterMethod: TAdaptiveFilterMethod; CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: Integer); begin raise Exception.Create('Class is only meant for encoding'); end; { TCustomPngTranscoder } constructor TCustomPngTranscoder.Create(Stream: TStream; Header: TChunkPngImageHeader; Gamma: TChunkPngGamma = nil; Palette: TChunkPngPalette = nil; Transparency: TCustomPngTransparency = nil); begin inherited; GetMem(FRowBuffer[0], FHeader.BytesPerRow + 1); GetMem(FRowBuffer[1], FHeader.BytesPerRow + 1); end; destructor TCustomPngTranscoder.Destroy; begin Dispose(FRowBuffer[0]); Dispose(FRowBuffer[1]); inherited; end; procedure TCustomPngTranscoder.DecodeFilterRow( FilterMethod: TAdaptiveFilterMethod; CurrentRow, PreviousRow: PByteArray; BytesPerRow, PixelByteSize: Integer); begin case FilterMethod of afmNone : ; afmSub : DecodeFilterSub(CurrentRow, PreviousRow, BytesPerRow, PixelByteSize); afmUp : DecodeFilterUp(CurrentRow, PreviousRow, BytesPerRow, PixelByteSize); afmAverage : DecodeFilterAverage(CurrentRow, PreviousRow, BytesPerRow, PixelByteSize); afmPaeth : DecodeFilterPaeth(CurrentRow, PreviousRow, BytesPerRow, PixelByteSize); else raise EPngError.Create(RCStrUnsupportedFilter); end; end; procedure TCustomPngTranscoder.EncodeFilterRow(CurrentRow, PreviousRow, OutputRow, TempBuffer: PByteArray; BytesPerRow, PixelByteSize: Integer); var PixelIndex : Integer; CurrentSum : Cardinal; BestSum : Cardinal; begin BestSum := 0; OutputRow^[0] := 0; for PixelIndex := 1 to BytesPerRow do BestSum := BestSum + CurrentRow[PixelIndex]; Move(CurrentRow^[1], OutputRow^[1], BytesPerRow); // check whether sub pre filter shall be used if aafmSub in FHeader.AdaptiveFilterMethods then begin // calculate sub filter EncodeFilterSub(CurrentRow, PreviousRow, TempBuffer, BytesPerRow, PixelByteSize); CurrentSum := CalculateRowSum(TempBuffer, BytesPerRow); // check if sub filter is the current best filter if CurrentSum < BestSum then begin BestSum := CurrentSum; Move(TempBuffer^[1], OutputRow^[1], BytesPerRow); OutputRow^[0] := 1; end; end; // check whether up pre filter shall be used if aafmUp in FHeader.AdaptiveFilterMethods then begin // calculate up filter EncodeFilterUp(CurrentRow, PreviousRow, TempBuffer, BytesPerRow, PixelByteSize); CurrentSum := CalculateRowSum(TempBuffer, BytesPerRow); // check if up filter is the current best filter if CurrentSum < BestSum then begin BestSum := CurrentSum; Move(TempBuffer^[1], OutputRow^[1], BytesPerRow); OutputRow^[0] := 2; end; end; // check whether average pre filter shall be used if aafmAverage in FHeader.AdaptiveFilterMethods then begin // calculate average filter EncodeFilterAverage(CurrentRow, PreviousRow, TempBuffer, BytesPerRow, PixelByteSize); CurrentSum := CalculateRowSum(TempBuffer, BytesPerRow); // check if average filter is the current best filter if CurrentSum < BestSum then begin BestSum := CurrentSum; Move(TempBuffer^[1], OutputRow^[1], BytesPerRow); OutputRow^[0] := 3; end; end; // check whether paeth pre filter shall be used if aafmPaeth in FHeader.AdaptiveFilterMethods then begin // calculate paeth filter EncodeFilterPaeth(CurrentRow, PreviousRow, TempBuffer, BytesPerRow, PixelByteSize); CurrentSum := CalculateRowSum(TempBuffer, BytesPerRow); // check if paeth filter is the current best filter if CurrentSum < BestSum then begin Move(TempBuffer^[1], OutputRow^[1], BytesPerRow); OutputRow^[0] := 4; end; end; end; { TPortableNetworkGraphic } constructor TPortableNetworkGraphic.Create; begin FImageHeader := TChunkPngImageHeader.Create; FDataChunkList := TChunkList.Create; FAdditionalChunkList := TChunkList.Create; FCompressionLevel := Z_BEST_COMPRESSION; inherited; end; destructor TPortableNetworkGraphic.Destroy; begin FAdditionalChunkList.Clear; FAdditionalChunkList.Free; FDataChunkList.Free; FImageHeader.Free; FPaletteChunk.Free; FGammaChunk.Free; FTimeChunk.Free; FSignificantBits.Free; FPhysicalDimensions.Free; FChromaChunk.Free; FTransparencyChunk.Free; FBackgroundChunk.Free; inherited; end; procedure TPortableNetworkGraphic.SetPaletteChunk( const Value: TChunkPngPalette); begin if (FPaletteChunk <> nil) then if (Value <> nil) then FPaletteChunk.Assign(Value) else FreeAndNil(FPaletteChunk) else if (Value <> nil) then begin FPaletteChunk := TChunkPngPalette.Create(FImageHeader); FPaletteChunk.Assign(Value); end; end; procedure TPortableNetworkGraphic.SetPhysicalDimensions( const Value: TChunkPngPhysicalPixelDimensions); begin if (FPhysicalDimensions <> nil) then if (Value <> nil) then FPhysicalDimensions.Assign(Value) else FreeAndNil(FPhysicalDimensions) else if (Value <> nil) then begin FPhysicalDimensions := TChunkPngPhysicalPixelDimensions.Create(FImageHeader); FPhysicalDimensions.Assign(Value); end; end; procedure TPortableNetworkGraphic.SetSignificantBits( const Value: TChunkPngSignificantBits); begin if (FSignificantBits <> nil) then if (Value <> nil) then FSignificantBits.Assign(Value) else FreeAndNil(FSignificantBits) else if (Value <> nil) then begin FSignificantBits := TChunkPngSignificantBits.Create(FImageHeader); FSignificantBits.Assign(Value); end; end; procedure TPortableNetworkGraphic.SetTimeChunk(const Value: TChunkPngTime); begin if (FTimeChunk <> nil) then if (Value <> nil) then FTimeChunk.Assign(Value) else FreeAndNil(FTimeChunk) else if (Value <> nil) then begin FTimeChunk := TChunkPngTime.Create(FImageHeader); FTimeChunk.Assign(Value); end; end; procedure TPortableNetworkGraphic.SetTransparencyChunk( const Value: TChunkPngTransparency); begin if (FTransparencyChunk <> nil) then if (Value <> nil) then FTransparencyChunk.Assign(Value) else FreeAndNil(FTransparencyChunk) else if (Value <> nil) then begin FTransparencyChunk := TChunkPngTransparency.Create(FImageHeader); FTransparencyChunk.Assign(Value); end; end; procedure TPortableNetworkGraphic.SetPixelsPerUnitX(const Value: Cardinal); begin if Value = 0 then raise EPngError.Create(RCStrWrongPixelPerUnit); if not (FPhysicalDimensions <> nil) then FPhysicalDimensions := TChunkPngPhysicalPixelDimensions.Create(FImageHeader); FPhysicalDimensions.PixelsPerUnitX := Value; end; procedure TPortableNetworkGraphic.SetPixelsPerUnitY(const Value: Cardinal); begin if Value = 0 then raise EPngError.Create(RCStrWrongPixelPerUnit); if not (FPhysicalDimensions <> nil) then FPhysicalDimensions := TChunkPngPhysicalPixelDimensions.Create(FImageHeader); FPhysicalDimensions.PixelsPerUnitY := Value; end; procedure TPortableNetworkGraphic.SetPixelUnit(const Value: Byte); begin if Value > 1 then raise EPngError.Create(RCStrUnspecifiedPixelUnit); if not (FPhysicalDimensions <> nil) then FPhysicalDimensions := TChunkPngPhysicalPixelDimensions.Create(FImageHeader); FPhysicalDimensions.PixelUnit := Value; end; procedure TPortableNetworkGraphic.SetChromaChunk( const Value: TChunkPngPrimaryChromaticities); begin if (FChromaChunk <> nil) then if (Value <> nil) then FChromaChunk.Assign(Value) else FreeAndNil(FChromaChunk) else if (Value <> nil) then begin FChromaChunk := TChunkPngPrimaryChromaticities.Create(FImageHeader); FChromaChunk.Assign(Value); end; end; procedure TPortableNetworkGraphic.SetGammaChunk(const Value: TChunkPngGamma); begin if (FGammaChunk <> nil) then if (Value <> nil) then FGammaChunk.Assign(Value) else FreeAndNil(FGammaChunk) else if (Value <> nil) then begin FGammaChunk := TChunkPngGamma.Create(FImageHeader); FGammaChunk.Assign(Value); end; end; procedure TPortableNetworkGraphic.SetBackgroundChunk( const Value: TChunkPngBackgroundColor); begin if (FGammaChunk <> nil) then if (Value <> nil) then FBackgroundChunk.Assign(Value) else FreeAndNil(FBackgroundChunk) else if (Value <> nil) then begin FBackgroundChunk := TChunkPngBackgroundColor.Create(FImageHeader); FBackgroundChunk.Assign(Value); end; end; procedure TPortableNetworkGraphic.SetImageHeader( const Value: TChunkPngImageHeader); begin if not (Value <> nil) then raise EPngError.Create(RCStrNewHeaderError) else FImageHeader.Assign(Value); end; procedure TPortableNetworkGraphic.SetBitDepth(const Value: Byte); begin raise EPngError.CreateFmt(RCStrBitDepthTranscodingError, [Value]); end; procedure TPortableNetworkGraphic.SetColorType(const Value: TColorType); begin raise EPngError.CreateFmt(RCStrColorTypeTranscodingError, [Integer(Value)]); end; procedure TPortableNetworkGraphic.SetFilterMethods( const Value: TAvailableAdaptiveFilterMethods); begin if (FImageHeader <> nil) then if FImageHeader.FAdaptiveFilterMethods <> Value then begin FImageHeader.FAdaptiveFilterMethods := Value; AdaptiveFilterMethodsChanged; end; end; procedure TPortableNetworkGraphic.SetCompressionLevel(const Value: Byte); begin if not (Value in [1..9]) then raise EPngError.Create(RCStrInvalidCompressionLevel); if FCompressionLevel <> Value then begin FCompressionLevel := Value; CompressionLevelChanged; end; end; procedure TPortableNetworkGraphic.SetCompressionMethod(const Value: Byte); begin raise EPngError.CreateFmt(RCStrDirectCompressionMethodSetError, [Value]); end; procedure TPortableNetworkGraphic.SetFilterMethod(const Value: TFilterMethod); begin raise EPngError.CreateFmt(RCStrDirectFilterMethodSetError, [Integer(Value)]); end; procedure TPortableNetworkGraphic.SetWidth(const Value: Integer); begin raise EPngError.CreateFmt(RCStrDirectWidthSetError, [Value]); end; procedure TPortableNetworkGraphic.SetInterlaceMethod( const Value: TInterlaceMethod); begin if Value <> FImageHeader.InterlaceMethod then begin InterlaceMethodChanged; FImageHeader.InterlaceMethod := Value; end; end; procedure TPortableNetworkGraphic.SetModifiedTime(const Value: TDateTime); begin if (FTimeChunk <> nil) then FTimeChunk.ModifiedDateTime := Value; end; procedure TPortableNetworkGraphic.SetGamma(const Value: Single); begin raise EPngError.CreateFmt(RCStrDirectGammaSetError, [Value]); end; procedure TPortableNetworkGraphic.SetHeight(const Value: Integer); begin raise EPngError.CreateFmt(RCStrDirectHeightSetError, [Value]); end; procedure TPortableNetworkGraphic.CopyImageData(Stream: TStream); var DataIndex : Integer; begin // combine all data chunks first for DataIndex := 0 to FDataChunkList.Count - 1 do begin // make sure the chunk is inded an image data chunk Assert(FDataChunkList[DataIndex] is TChunkPngImageData); // concat current chunk to data stream with TChunkPngImageData(FDataChunkList[DataIndex]) do begin Data.Seek(0, soFromBeginning); Stream.CopyFrom(Data, Data.Size); end; end; end; procedure TPortableNetworkGraphic.StoreImageData(Stream: TStream); var DataChunk : TChunkPngImageData; ChunkSize : Integer; begin // delete old image data FDataChunkList.Clear; ChunkSize := Stream.Size; while Stream.Position < Stream.Size do begin DataChunk := TChunkPngImageData.Create(ImageHeader); if (Stream.Size - Stream.Position) < ChunkSize then ChunkSize := (Stream.Size - Stream.Position); // copy data to IDAT chunk DataChunk.Data.CopyFrom(Stream, ChunkSize); // add data chunk to data chunk list FDataChunkList.Add(DataChunk); end; end; procedure TPortableNetworkGraphic.DecompressImageDataToStream(Stream: TStream); var DataStream: TMemoryStream; begin DataStream := TMemoryStream.Create; try // copy image data from all data chunks to one continous data stream CopyImageData(DataStream); // check whether compression method is supported if FImageHeader.CompressionMethod <> 0 then raise EPngError.Create(RCStrUnsupportedCompressionMethod); // reset data stream position to zero DataStream.Seek(0, soFromBeginning); // decompress z-stream ZDecompress(DataStream, Stream); finally DataStream.Free; end; end; procedure TPortableNetworkGraphic.CompressImageDataFromStream(Stream: TStream); var DataStream: TMemoryStream; begin DataStream := TMemoryStream.Create; try // set compression method FImageHeader.CompressionMethod := 0; // compress Stream to DataStream if Stream is TMemoryStream then ZCompress(TMemoryStream(Stream), DataStream, FCompressionLevel) else raise EPngError.CreateFmt(RCStrNotYetImplemented, ['source stream must be TMemoryStream']); // reset data stream position to zero DataStream.Seek(0, soFromBeginning); // copy image data from all data chunks to one continous data stream StoreImageData(DataStream); finally DataStream.Free; end; end; class function TPortableNetworkGraphic.CanLoad(const FileName: TFileName): Boolean; var FileStream: TFileStream; begin FileStream := TFileStream.Create(FileName, fmOpenRead); try Result := CanLoad(FileStream); finally FileStream.Free; end; end; class function TPortableNetworkGraphic.CanLoad(Stream: TStream): Boolean; var Signature: array[0..SizeOf(PNG_SIG)-1] of AnsiChar; begin Result := (Stream.Size >= SizeOf(Signature)); if Result then begin Stream.Read(Signature, SizeOf(Signature)); Stream.Seek(-SizeOf(Signature), soFromCurrent); Result := CompareMem(@Signature, @PNG_SIG, SizeOf(Signature)); end; end; procedure TPortableNetworkGraphic.LoadFromFile(Filename: TFilename); var FileStream: TFileStream; begin FileStream := TFileStream.Create(FileName, fmOpenRead); try LoadFromStream(FileStream); finally FileStream.Free; end; end; procedure TPortableNetworkGraphic.LoadFromStream(Stream: TStream); var ChunkName : TChunkName; ChunkSize : Integer; ChunkCRC : Cardinal; ChunkClass : TCustomDefinedChunkWithHeaderClass; Chunk : TCustomDefinedChunkWithHeader; MemoryStream : TMemoryStream; GotIDAT : boolean; SavePos : UInt64; begin GotIDAT := False; Clear; // Check for minimum file size and signature if (not CanLoad(Stream)) then raise EPngError.Create(RCStrNotAValidPNGFile); // Skip chunk ID and magic - We already checked them in CanLoad above Stream.Seek(SizeOf(PNG_SIG), soFromCurrent); MemoryStream := TMemoryStream.Create; try // read image header chunk size ChunkSize := BigEndian.ReadCardinal(Stream); if ChunkSize > Stream.Size - 12 then raise EPngError.Create(RCStrNotAValidPNGFile); // read image header chunk ID SavePos := Stream.Position; Stream.Read(ChunkName, 4); if ChunkName <> 'IHDR' then raise EPngError.Create(RCStrNotAValidPNGFile); // reset position to the chunk start and copy stream to memory Stream.Position := SavePos; MemoryStream.CopyFrom(Stream, ChunkSize + 4); MemoryStream.Position := 4; // load image header FImageHeader.ReadFromStream(MemoryStream, ChunkSize); // read image header chunk size ChunkCRC := 0; Stream.Read(ChunkCRC, 4); {$IFDEF CheckCRC} if not CheckCRC(MemoryStream, Swap32(ChunkCRC)) then raise EPngError.Create(RCStrCRCError); {$ENDIF} while Stream.Position < Stream.Size do begin // read image header chunk size ChunkSize := BigEndian.ReadCardinal(Stream); if Stream.Position+ChunkSize+4 > Stream.Size then raise EPngError.Create(RCStrNotAValidPNGFile); // read chunk ID SavePos := Stream.Position; Stream.Read(ChunkName, 4); // check for stream end if ChunkName = 'IEND' then begin // read image header chunk size Stream.Read(ChunkCRC, 4); {$IFDEF CheckCRC} if ChunkCRC <> 2187346606 then raise EPngError.Create(RCStrCRCError); {$ENDIF} Break; end; // reset position to the chunk start and copy stream to memory Stream.Position := SavePos; MemoryStream.Clear; MemoryStream.CopyFrom(Stream, ChunkSize + 4); // reset memory stream to beginning of the chunk MemoryStream.Seek(4, soFromBeginning); if ChunkName = 'IHDR' then raise EPngError.Create(RCStrNotAValidPNGFile); if ChunkName = 'IDAT' then begin ReadImageDataChunk(MemoryStream, ChunkSize); GotIDAT := True; end else if ChunkName = 'gAMA' then begin if (FGammaChunk <> nil) then raise EPngError.Create(RCStrSeveralGammaChunks); FGammaChunk := TChunkPngGamma.Create(FImageHeader); FGammaChunk.ReadFromStream(MemoryStream, ChunkSize); end else if ChunkName = 'cHRM' then begin if (FChromaChunk <> nil) then raise EPngError.Create(RCStrSeveralChromaChunks); FChromaChunk := TChunkPngPrimaryChromaticities.Create(FImageHeader); FChromaChunk.ReadFromStream(MemoryStream, ChunkSize); end else if ChunkName = 'tIME' then begin if (FTimeChunk <> nil) then raise EPngError.Create(RCStrSeveralTimeChunks); FTimeChunk := TChunkPngTime.Create(FImageHeader); FTimeChunk.ReadFromStream(MemoryStream, ChunkSize); end else if ChunkName = 'sBIT' then begin if (FSignificantBits <> nil) then raise EPngError.Create(RCStrSeveralSignificantBitsChunksFound); FSignificantBits := TChunkPngSignificantBits.Create(FImageHeader); FSignificantBits.ReadFromStream(MemoryStream, ChunkSize); end else if ChunkName = 'pHYs' then begin if (FPhysicalDimensions <> nil) then raise EPngError.Create(RCStrSeveralPhysicalPixelDimensionChunks); FPhysicalDimensions := TChunkPngPhysicalPixelDimensions.Create(FImageHeader); FPhysicalDimensions.ReadFromStream(MemoryStream, ChunkSize); end else if ChunkName = 'PLTE' then begin if (FPaletteChunk <> nil) then raise EPngError.Create(RCStrSeveralPaletteChunks); FPaletteChunk := TChunkPngPalette.Create(FImageHeader); FPaletteChunk.ReadFromStream(MemoryStream, ChunkSize); end else if ChunkName = 'tRNS' then begin if (FTransparencyChunk <> nil) then raise EPngError.Create(RCStrSeveralTransparencyChunks); FTransparencyChunk := TChunkPngTransparency.Create(FImageHeader); FTransparencyChunk.ReadFromStream(MemoryStream, ChunkSize); end else if ChunkName = 'bKGD' then begin if (FBackgroundChunk <> nil) then raise EPngError.Create(RCStrSeveralBackgroundChunks); FBackgroundChunk := TChunkPngBackgroundColor.Create(FImageHeader); FBackgroundChunk.ReadFromStream(MemoryStream, ChunkSize); end else begin ChunkClass := FindPngChunkByChunkName(ChunkName); if ChunkClass <> nil then begin Chunk := ChunkClass.Create(FImageHeader); Chunk.ReadFromStream(MemoryStream, ChunkSize); FAdditionalChunkList.Add(Chunk); end else begin // check if chunk is ancillary if (Byte(ChunkName[0]) and $80) <> 0 then raise EPngError.Create(RCStrAncillaryUnknownChunk); ReadUnknownChunk(MemoryStream, ChunkName, ChunkSize); end; end; // read & check CRC Stream.Read(ChunkCRC, 4); {$IFDEF CheckCRC} if not CheckCRC(MemoryStream, Swap32(ChunkCRC)) then raise EPngError.Create(RCStrCRCError); {$ENDIF} end; finally MemoryStream.Free; end; if (not GotIDAT) then raise EPngError.Create(RCStrMissingIDATChunk); end; procedure TPortableNetworkGraphic.SaveToFile(Filename: TFilename); var FileStream: TFileStream; begin FileStream := TFileStream.Create(FileName, fmCreate); try SaveToStream(FileStream); finally FileStream.Free; end; end; procedure TPortableNetworkGraphic.SaveToStream(Stream: TStream); var ChunkName : TChunkName; ChunkSize : Cardinal; CRC : Cardinal; MemoryStream : TMemoryStream; Index : Integer; procedure SaveChunkToStream(Chunk: TCustomChunk); begin MemoryStream.Clear; // store chunk size directly to stream ChunkSize := Chunk.ChunkSize; BigEndian.WriteCardinal(Stream, ChunkSize); // store chunk name to memory stream ChunkName := Chunk.ChunkName; MemoryStream.Write(ChunkName, 4); // save chunk to memory stream Chunk.WriteToStream(MemoryStream); // copy memory stream to stream MemoryStream.Position := 0; Stream.CopyFrom(MemoryStream, 0); // calculate and write CRC CRC := Swap32(CalculateCRC(MemoryStream)); Stream.Write(CRC, SizeOf(Cardinal)); end; begin // Write chunk ID and PNG magic Stream.Write(PNG_SIG, SizeOf(PNG_SIG)); MemoryStream := TMemoryStream.Create; try // store chunk size directly to stream ChunkSize := FImageHeader.ChunkSize; BigEndian.WriteCardinal(Stream, ChunkSize); // store chunk name to memory stream ChunkName := FImageHeader.ChunkName; MemoryStream.Write(ChunkName, 4); // save image header to memory stream FImageHeader.WriteToStream(MemoryStream); // copy memory stream to stream MemoryStream.Position := 0;; Stream.CopyFrom(MemoryStream, 0); // calculate and write CRC CRC := Swap32(CalculateCRC(MemoryStream)); Stream.Write(CRC, SizeOf(Cardinal)); // eventually save physical pixel dimensions chunk if (FPhysicalDimensions <> nil) then SaveChunkToStream(FPhysicalDimensions); // eventually save significant bits chunk if (FSignificantBits <> nil) then SaveChunkToStream(FSignificantBits); // eventually save gamma chunk if (FGammaChunk <> nil) then SaveChunkToStream(FGammaChunk); // eventually save chroma chunk if (FChromaChunk <> nil) then SaveChunkToStream(FChromaChunk); // eventually save palette chunk if (FPaletteChunk <> nil) then SaveChunkToStream(FPaletteChunk); // eventually save transparency chunk if (FTransparencyChunk <> nil) then SaveChunkToStream(FTransparencyChunk); // eventually save background chunk if (FBackgroundChunk <> nil) then SaveChunkToStream(FBackgroundChunk); // store additional chunks for Index := 0 to FAdditionalChunkList.Count - 1 do SaveChunkToStream(TCustomChunk(FAdditionalChunkList[Index])); // save data streams for Index := 0 to FDataChunkList.Count - 1 do SaveChunkToStream(TCustomChunk(FDataChunkList[Index])); finally MemoryStream.Free; end; // write chunk size BigEndian.WriteCardinal(Stream, 0); // write chunk ID ChunkName := 'IEND'; Stream.Write(ChunkName, 4); // write CRC CRC := 2187346606; Stream.Write(CRC, 4); end; procedure TPortableNetworkGraphic.ReadUnknownChunk(Stream: TStream; ChunkName: TChunkName; ChunkSize: Integer); var UnknownChunk : TChunkPngUnknown; begin UnknownChunk := TChunkPngUnknown.Create(ChunkName); UnknownChunk.ReadFromStream(Stream, ChunkSize); FAdditionalChunkList.Add(UnknownChunk); end; procedure TPortableNetworkGraphic.RemoveGammaInformation; begin FreeAndNil(FGammaChunk); end; procedure TPortableNetworkGraphic.RemoveModifiedTimeInformation; begin FreeAndNil(FTimeChunk); end; procedure TPortableNetworkGraphic.RemovePhysicalPixelDimensionsInformation; begin FreeAndNil(FPhysicalDimensions); end; procedure TPortableNetworkGraphic.CompressionLevelChanged; var TempStream : TMemoryStream; begin TempStream := TMemoryStream.Create; try DecompressImageDataToStream(TempStream); TempStream.Seek(0, soFromBeginning); CompressImageDataFromStream(TempStream); finally TempStream.Free; end; end; procedure TPortableNetworkGraphic.AdaptiveFilterMethodsChanged; begin if FDataChunkList.Count > 0 then begin // transcoding! raise EPngError.CreateFmt(RCStrNotYetImplemented, ['AdaptiveFilterMethods transcoding']); end; end; procedure TPortableNetworkGraphic.InterlaceMethodChanged; var TempStream : TMemoryStream; TranscoderClass : TCustomPngTranscoderClass; begin TempStream := TMemoryStream.Create; try DecompressImageDataToStream(TempStream); TempStream.Seek(0, soFromBeginning); case FImageHeader.InterlaceMethod of imNone : TranscoderClass := TPngNonInterlacedToAdam7Transcoder; imAdam7 : TranscoderClass := TPngAdam7ToNonInterlacedTranscoder; else raise EPngError.Create(RCStrWrongInterlaceMethod); end; with TranscoderClass.Create(TempStream, FImageHeader) do try Transcode; finally Free; end; TempStream.Seek(0, soFromBeginning); CompressImageDataFromStream(TempStream); finally TempStream.Free; end; end; procedure TPortableNetworkGraphic.ReadImageDataChunk(Stream: TStream; Size: Integer); var ImageDataChunk : TChunkPngImageData; begin ImageDataChunk := TChunkPngImageData.Create(FImageHeader); ImageDataChunk.ReadFromStream(Stream, Size); FDataChunkList.Add(ImageDataChunk); end; procedure TPortableNetworkGraphic.Assign(Source: TPersistent); begin if Source is TPortableNetworkGraphic then with TPortableNetworkGraphic(Source) do begin if (Self.FImageHeader <> nil) then Self.FImageHeader.Assign(FImageHeader); // assign palette chunk if (Self.FPaletteChunk <> nil) then if (FPaletteChunk <> nil) then Self.FPaletteChunk.Assign(FPaletteChunk) else FreeAndNil(Self.FPaletteChunk) else if (FPaletteChunk <> nil) then begin Self.FPaletteChunk := TChunkPngPalette.Create(FImageHeader); Self.FPaletteChunk.Assign(FPaletteChunk); end; // assign gamma chunk if (Self.FGammaChunk <> nil) then if (FGammaChunk <> nil) then Self.FGammaChunk.Assign(FGammaChunk) else FreeAndNil(Self.FGammaChunk) else if (FGammaChunk <> nil) then begin Self.FGammaChunk := TChunkPngGamma.Create(FImageHeader); Self.FGammaChunk.Assign(FGammaChunk); end; // assign time chunk if (Self.FTimeChunk <> nil) then if (FTimeChunk <> nil) then Self.FTimeChunk.Assign(FTimeChunk) else FreeAndNil(Self.FTimeChunk) else if (FTimeChunk <> nil) then begin Self.FTimeChunk := TChunkPngTime.Create(FImageHeader); Self.FTimeChunk.Assign(FTimeChunk); end; // assign significant bits if (Self.FSignificantBits <> nil) then if (FSignificantBits <> nil) then Self.FSignificantBits.Assign(FSignificantBits) else FreeAndNil(Self.FSignificantBits) else if (FSignificantBits <> nil) then begin Self.FSignificantBits := TChunkPngSignificantBits.Create(FImageHeader); Self.FSignificantBits.Assign(FSignificantBits); end; // assign physical dimensions if (Self.FPhysicalDimensions <> nil) then if (FPhysicalDimensions <> nil) then Self.FPhysicalDimensions.Assign(FPhysicalDimensions) else FreeAndNil(Self.FPhysicalDimensions) else if (FPhysicalDimensions <> nil) then begin Self.FPhysicalDimensions := TChunkPngPhysicalPixelDimensions.Create(FImageHeader); Self.FPhysicalDimensions.Assign(FPhysicalDimensions); end; // assign primary chromaticities if (Self.FChromaChunk <> nil) then if (FChromaChunk <> nil) then Self.FChromaChunk.Assign(FChromaChunk) else FreeAndNil(Self.FChromaChunk) else if (FChromaChunk <> nil) then begin Self.FChromaChunk := TChunkPngPrimaryChromaticities.Create(FImageHeader); Self.FChromaChunk.Assign(FChromaChunk); end; // assign transparency if (Self.FTransparencyChunk <> nil) then if (FTransparencyChunk <> nil) then Self.FTransparencyChunk.Assign(FTransparencyChunk) else FreeAndNil(Self.FTransparencyChunk) else if (FTransparencyChunk <> nil) then begin Self.FTransparencyChunk := TChunkPngTransparency.Create(FImageHeader); Self.FTransparencyChunk.Assign(FTransparencyChunk); end; // assign background if (Self.FBackgroundChunk <> nil) then if (FBackgroundChunk <> nil) then Self.FBackgroundChunk.Assign(FBackgroundChunk) else FreeAndNil(Self.FBackgroundChunk) else if (FBackgroundChunk <> nil) then begin Self.FBackgroundChunk := TChunkPngBackgroundColor.Create(FImageHeader); Self.FBackgroundChunk.Assign(FBackgroundChunk); end; if (Self.FDataChunkList <> nil) then Self.FDataChunkList.Assign(FDataChunkList); if (Self.FAdditionalChunkList <> nil) then Self.FAdditionalChunkList.Assign(FAdditionalChunkList); end else inherited; end; procedure TPortableNetworkGraphic.AssignTo(Dest: TPersistent); begin if Dest is TPortableNetworkGraphic then with TPortableNetworkGraphic(Dest) do begin FImageHeader.Assign(Self.FImageHeader); FPaletteChunk.Assign(Self.FPaletteChunk); FGammaChunk.Assign(Self.FGammaChunk); FTimeChunk.Assign(Self.FTimeChunk); FSignificantBits.Assign(Self.FSignificantBits); FPhysicalDimensions.Assign(Self.FPhysicalDimensions); FChromaChunk.Assign(Self.FChromaChunk); FTransparencyChunk.Assign(Self.FTransparencyChunk); FBackgroundChunk.Assign(Self.FBackgroundChunk); FDataChunkList.Assign(Self.FDataChunkList); FAdditionalChunkList.Assign(Self.FAdditionalChunkList); end else inherited; end; function TPortableNetworkGraphic.CalculateCRC(Stream: TStream): Cardinal; var CrcValue : Cardinal; Value : Byte; begin if Stream is TMemoryStream then Result := CalculateCRC(TMemoryStream(Stream).Memory, Stream.Size) else begin Stream.Position := 0; // initialize CRC CrcValue := $FFFFFFFF; {$IFDEF FPC} Value := 0; {$ENDIF} while Stream.Position < Stream.Size do begin Stream.Read(Value, 1); CrcValue := GCrcTable^[(CrcValue xor Value) and $FF] xor (CrcValue shr 8); end; Result := (CrcValue xor $FFFFFFFF); Stream.Position := 0; end; end; function TPortableNetworkGraphic.CalculateCRC(Buffer: PByte; Count: Cardinal): Cardinal; {$if defined(PUREPASCAL)} var CrcValue : Cardinal; Pos : Cardinal; begin // ignore size (offset by 4 bytes) Pos := 0; // initialize CRC CrcValue := $FFFFFFFF; while Pos < Count do begin CrcValue := GCrcTable^[(CrcValue xor Buffer^) and $FF] xor (CrcValue shr 8); Inc(Buffer); Inc(Pos); end; Result := (CrcValue xor $FFFFFFFF); {$else} asm {$IFDEF Target_x64} PUSH RBX PUSH RDI MOV RCX, R8 JS @Done NEG RCX MOV RBX, $FFFFFFFF {$IFNDEF FPC} MOV RDI, [GCrcTable] {$ELSE} MOV RDI, [RIP + GCrcTable] {$ENDIF} @Start: MOVZX EAX, [RDX].BYTE XOR EAX, EBX AND EAX, $FF MOV EAX, [RDI + 4 * RAX] SHR EBX, 8 XOR EAX, EBX MOV EBX, EAX INC RDX INC RCX JS @Start XOR EBX, $FFFFFFFF MOV RAX, RBX @Done: POP RDI POP RBX {$ELSE} PUSH EBX PUSH EDI JS @Done NEG ECX MOV EBX, $FFFFFFFF MOV EDI, [GCrcTable] @Start: MOVZX EAX, [EDX].BYTE XOR EAX, EBX AND EAX, $FF MOV EAX, [EDI + 4 * EAX] SHR EBX, 8 XOR EAX, EBX MOV EBX, EAX INC EDX INC ECX JS @Start XOR EAX, $FFFFFFFF @Done: POP EDI POP EBX {$ENDIF} {$ifend} end; {$IFDEF CheckCRC} function TPortableNetworkGraphic.CheckCRC(Stream: TStream; CRC: Cardinal): Boolean; begin Result := CalculateCRC(Stream) = CRC; end; {$ENDIF} function TPortableNetworkGraphic.GetBitDepth: Byte; begin Result := FImageHeader.BitDepth; end; function TPortableNetworkGraphic.GetColorType: TColorType; begin Result := FImageHeader.ColorType; end; function TPortableNetworkGraphic.GetCompressionMethod: Byte; begin Result := FImageHeader.CompressionMethod; end; function TPortableNetworkGraphic.GetFilterMethod: TFilterMethod; begin Result := FImageHeader.FilterMethod; end; function TPortableNetworkGraphic.GetFilterMethods: TAvailableAdaptiveFilterMethods; begin Result := FImageHeader.FAdaptiveFilterMethods; end; function TPortableNetworkGraphic.GetGamma: Single; begin if (FGammaChunk <> nil) then Result := FGammaChunk.GammaAsSingle else Result := 1; end; function TPortableNetworkGraphic.GetHeight: Integer; begin Result := FImageHeader.Height; end; function TPortableNetworkGraphic.GetInterlaceMethod: TInterlaceMethod; begin Result := FImageHeader.InterlaceMethod; end; function TPortableNetworkGraphic.GetModifiedTime: TDateTime; begin if (FTimeChunk <> nil) then Result := EncodeDate(FTimeChunk.Year, FTimeChunk.Month, FTimeChunk.Day) + EncodeTime(FTimeChunk.Hour, FTimeChunk.Minute, FTimeChunk.Second, 0) else Result := 0; end; function TPortableNetworkGraphic.GetPaletteEntry(Index: Integer): TRGB24; begin if (FPaletteChunk <> nil) then Result := FPaletteChunk.PaletteEntry[Index] else raise EPngError.CreateFmt(RCStrIndexOutOfBounds, [Index]); end; function TPortableNetworkGraphic.GetPaletteEntryCount: Integer; begin if (FPaletteChunk <> nil) then Result := FPaletteChunk.Count else Result := 0; end; function TPortableNetworkGraphic.GetPixelsPerUnitX: Cardinal; begin if (FPhysicalDimensions <> nil) then Result := FPhysicalDimensions.PixelsPerUnitX else Result := 1; end; function TPortableNetworkGraphic.GetPixelsPerUnitY: Cardinal; begin if (FPhysicalDimensions <> nil) then Result := FPhysicalDimensions.PixelsPerUnitY else Result := 1; end; function TPortableNetworkGraphic.GetPixelUnit: Byte; begin if (FPhysicalDimensions <> nil) then Result := FPhysicalDimensions.PixelUnit else Result := 0; end; function TPortableNetworkGraphic.GetWidth: Integer; begin Result := FImageHeader.Width; end; function TPortableNetworkGraphic.HasGammaInformation: Boolean; begin Result := (FGammaChunk <> nil); end; function TPortableNetworkGraphic.HasModifiedTimeInformation: Boolean; begin Result := (FTimeChunk <> nil); end; function TPortableNetworkGraphic.HasPhysicalPixelDimensionsInformation: Boolean; begin Result := (FPhysicalDimensions <> nil); end; procedure TPortableNetworkGraphic.Clear; begin // clear chunk lists FDataChunkList.Clear; FAdditionalChunkList.Clear; // reset image header to default FImageHeader.ResetToDefault; FreeAndNil(FPaletteChunk); FreeAndNil(FGammaChunk); FreeAndNil(FChromaChunk); FreeAndNil(FTransparencyChunk); FreeAndNil(FBackgroundChunk); FreeAndNil(FTimeChunk); FreeAndNil(FSignificantBits); FreeAndNil(FPhysicalDimensions); end; { TPngNonInterlacedToAdam7Transcoder } procedure TPngNonInterlacedToAdam7Transcoder.Transcode; var CurrentRow : Integer; RowByteSize : Integer; PixelPerRow : Integer; PixelByteSize : Integer; CurrentPass : Integer; Index : Integer; PassRow : Integer; Source : PByte; Destination : PByte; TempData : PByteArray; OutputRow : PByteArray; TempBuffer : PByteArray; begin // initialize variables CurrentRow := 0; PixelByteSize := FHeader.PixelByteSize; GetMem(TempData, FHeader.Height * FHeader.BytesPerRow); Destination := PByte(TempData); try /////////////////////////////////// // decode image (non-interlaced) // /////////////////////////////////// // clear previous row FillChar(FRowBuffer[1 - CurrentRow]^[0], FHeader.BytesPerRow + 1, 0); for Index := 0 to FHeader.Height - 1 do begin // read data from stream if FStream.Read(FRowBuffer[CurrentRow][0], FHeader.BytesPerRow + 1) <> FHeader.BytesPerRow + 1 then raise EPngError.Create(RCStrDataIncomplete); // filter current row DecodeFilterRow(TAdaptiveFilterMethod(FRowBuffer[CurrentRow]^[0]), FRowBuffer[CurrentRow], FRowBuffer[1 - CurrentRow], FHeader.BytesPerRow, PixelByteSize); // transfer data from row to temp data Move(FRowBuffer[CurrentRow][1], Destination^, PixelByteSize * FHeader.Width); Inc(Destination, FHeader.Width * PixelByteSize); // flip current row CurrentRow := 1 - CurrentRow; end; // reset position to zero FStream.Seek(0, soFromBeginning); // The Adam7 interlacer uses 7 passes to create the complete image for CurrentPass := 0 to 6 do begin // calculate some intermediate variables PixelPerRow := (FHeader.Width - CColumnStart[CurrentPass] + CColumnIncrement[CurrentPass] - 1) div CColumnIncrement[CurrentPass]; case FHeader.ColorType of ctGrayscale : RowByteSize := (PixelPerRow * FHeader.BitDepth + 7) div 8; ctIndexedColor : RowByteSize := (PixelPerRow * FHeader.BitDepth + 7) div 8; ctTrueColor : RowByteSize := (PixelPerRow * FHeader.BitDepth * 3) div 8; ctGrayscaleAlpha : RowByteSize := (PixelPerRow * FHeader.BitDepth * 2) div 8; ctTrueColorAlpha : RowByteSize := (PixelPerRow * FHeader.BitDepth * 4) div 8; else Continue; end; PassRow := CRowStart[CurrentPass]; // clear previous row FillChar(FRowBuffer[1 - CurrentRow]^[0], RowByteSize + 1, 0); // check if pre filter is used and eventually calculate pre filter if (FHeader.ColorType <> ctIndexedColor) and not (FHeader.AdaptiveFilterMethods = []) then begin GetMem(OutputRow, RowByteSize + 1); GetMem(TempBuffer, RowByteSize + 1); try while PassRow < FHeader.Height do begin Index := CColumnStart[CurrentPass]; Source := @TempData[PassRow * FHeader.BytesPerRow + Index * PixelByteSize]; Destination := @FRowBuffer[CurrentRow][1]; repeat // copy bytes per pixels Move(Source^, Destination^, PixelByteSize); Inc(Source, CColumnIncrement[CurrentPass] * PixelByteSize); Inc(Destination, PixelByteSize); Inc(Index, CColumnIncrement[CurrentPass]); until Index >= FHeader.Width; // filter current row EncodeFilterRow(FRowBuffer[CurrentRow], FRowBuffer[1 - CurrentRow], OutputRow, TempBuffer, RowByteSize, FHeader.PixelByteSize); Assert(OutputRow[0] in [0..4]); // write data to data stream FStream.Write(OutputRow[0], RowByteSize + 1); // prepare for the next pass Inc(PassRow, CRowIncrement[CurrentPass]); CurrentRow := 1 - CurrentRow; end; finally Dispose(OutputRow); Dispose(TempBuffer); end; end else while PassRow < FHeader.Height do begin Index := CColumnStart[CurrentPass]; Source := @TempData[PassRow * FHeader.BytesPerRow + Index * PixelByteSize]; Destination := @FRowBuffer[CurrentRow][1]; repeat // copy bytes per pixels Move(Source^, Destination^, PixelByteSize); Inc(Source, CColumnIncrement[CurrentPass] * PixelByteSize); Inc(Destination, PixelByteSize); Inc(Index, CColumnIncrement[CurrentPass]); until Index >= FHeader.Width; // set filter method 0 FRowBuffer[CurrentRow][0] := 0; // write data to data stream FStream.Write(FRowBuffer[CurrentRow][0], RowByteSize + 1); // prepare for the next pass Inc(PassRow, CRowIncrement[CurrentPass]); CurrentRow := 1 - CurrentRow; end; end; finally Dispose(TempData); end; end; { TPngAdam7ToNonInterlacedTranscoder } procedure TPngAdam7ToNonInterlacedTranscoder.Transcode; var CurrentRow : Integer; RowByteSize : Integer; PixelPerRow : Integer; PixelByteSize : Integer; CurrentPass : Integer; Index : Integer; PassRow : Integer; Source : PByte; Destination : PByte; TempData : PByteArray; OutputRow : PByteArray; TempBuffer : PByteArray; begin // initialize variables CurrentRow := 0; PixelByteSize := FHeader.PixelByteSize; GetMem(TempData, FHeader.Height * FHeader.BytesPerRow); try ///////////////////////////////////// // decode image (Adam7-interlaced) // ///////////////////////////////////// // The Adam7 deinterlacer uses 7 passes to create the complete image for CurrentPass := 0 to 6 do begin // calculate some intermediate variables PixelPerRow := (FHeader.Width - CColumnStart[CurrentPass] + CColumnIncrement[CurrentPass] - 1) div CColumnIncrement[CurrentPass]; case FHeader.ColorType of ctGrayscale : RowByteSize := (PixelPerRow * FHeader.BitDepth + 7) div 8; ctIndexedColor : RowByteSize := (PixelPerRow * FHeader.BitDepth + 7) div 8; ctTrueColor : RowByteSize := (PixelPerRow * FHeader.BitDepth * 3) div 8; ctGrayscaleAlpha : RowByteSize := (PixelPerRow * FHeader.BitDepth * 2) div 8; ctTrueColorAlpha : RowByteSize := (PixelPerRow * FHeader.BitDepth * 4) div 8; else Continue; end; PassRow := CRowStart[CurrentPass]; // clear previous row FillChar(FRowBuffer[1 - CurrentRow]^[0], RowByteSize, 0); // process pixels while PassRow < FHeader.Height do begin // get interlaced row data if FStream.Read(FRowBuffer[CurrentRow][0], RowByteSize + 1) <> (RowByteSize + 1) then raise EPngError.Create(RCStrDataIncomplete); DecodeFilterRow(TAdaptiveFilterMethod(FRowBuffer[CurrentRow]^[0]), FRowBuffer[CurrentRow], FRowBuffer[1 - CurrentRow], RowByteSize, PixelByteSize); Index := CColumnStart[CurrentPass]; Source := @FRowBuffer[CurrentRow][1]; Destination := @TempData[PassRow * FHeader.BytesPerRow + Index * PixelByteSize]; repeat // copy bytes per pixels Move(Source^, Destination^, PixelByteSize); Inc(Source, PixelByteSize); Inc(Destination, CColumnIncrement[CurrentPass] * PixelByteSize); Inc(Index, CColumnIncrement[CurrentPass]); until Index >= FHeader.Width; // prepare for the next pass Inc(PassRow, CRowIncrement[CurrentPass]); CurrentRow := 1 - CurrentRow; end; end; // reset position to zero FStream.Seek(0, soFromBeginning); ///////////////////////////////// // encode image non-interlaced // ///////////////////////////////// // clear previous row buffer FillChar(FRowBuffer[1 - CurrentRow]^[0], FHeader.BytesPerRow, 0); Source := PByte(TempData); // check if pre filter is used and eventually calculate pre filter if (FHeader.ColorType <> ctIndexedColor) and not (FHeader.AdaptiveFilterMethods = []) then begin GetMem(OutputRow, FHeader.BytesPerRow + 1); GetMem(TempBuffer, FHeader.BytesPerRow + 1); try for Index := 0 to FHeader.Height - 1 do begin // copy bytes per pixels Move(Source^, FRowBuffer[CurrentRow][1], FHeader.Width * PixelByteSize); Inc(Source, FHeader.Width * PixelByteSize); // filter current row EncodeFilterRow(FRowBuffer[CurrentRow], FRowBuffer[1 - CurrentRow], OutputRow, TempBuffer, FHeader.BytesPerRow, FHeader.PixelByteSize); // write data to data stream FStream.Write(OutputRow[0], FHeader.BytesPerRow + 1); // flip current row used CurrentRow := 1 - CurrentRow; end; finally Dispose(OutputRow); Dispose(TempBuffer); end; end else for Index := 0 to FHeader.Height - 1 do begin // copy bytes per pixels Move(Source^, FRowBuffer[CurrentRow][1], FHeader.Width * PixelByteSize); Inc(Source, FHeader.Width * PixelByteSize); // set filter method to none FRowBuffer[CurrentRow][0] := 0; // write data to data stream FStream.Write(FRowBuffer[CurrentRow][0], FHeader.BytesPerRow + 1); // flip current row used CurrentRow := 1 - CurrentRow; end; finally Dispose(TempData); end; end; procedure BuildCrcTable(Polynomial: Cardinal); var c : Cardinal; n, k : Integer; begin // allocate CRC table memory GetMem(GCrcTable, 256 * SizeOf(Cardinal)); // fill CRC table for n := 0 to 255 do begin c := n; for k := 0 to 7 do begin if (c and 1) <> 0 then c := Polynomial xor (c shr 1) else c := c shr 1; end; GCrcTable^[n] := c; end; end; initialization BuildCrcTable($EDB88320); RegisterPngChunks([TChunkPngImageData, TChunkPngPalette, TChunkPngGamma, TChunkPngStandardColorSpaceRGB, TChunkPngPrimaryChromaticities, TChunkPngTime, TChunkPngTransparency, TChunkPngEmbeddedIccProfile, TChunkPngPhysicalPixelDimensions, TChunkPngText, TChunkPngCompressedText, TChunkPngImageHistogram, TChunkPngBackgroundColor, TChunkPngSignificantBits, TChunkPngImageOffset, TChunkPngPixelCalibrator]); {$ifdef PNG_CHUNK_SUGGESTED_PALETTE} RegisterPngChunks([TChunkPngSuggestedPalette]); {$endif PNG_CHUNK_SUGGESTED_PALETTE} {$ifdef PNG_CHUNK_INTERNATIONAL_TEXT} RegisterPngChunks([TChunkPngInternationalText]); {$endif PNG_CHUNK_INTERNATIONAL_TEXT} finalization if (GCrcTable <> nil) then Dispose(GCrcTable); end.