pngimage.pas

This PNG Delphi version 1.56 documentation (this version is a major rewrite intended to replace the

{Add a new item}
function TPNGList.Add(ChunkClass: TChunkClass): TChunk;
var
  IHDR: TChunkIHDR;
  IEND: TChunkIEND;

  IDAT: TChunkIDAT;
  PLTE: TChunkPLTE;
begin
  Result := nil; {Default result}
  {Adding these is not allowed}
  if ((ChunkClass = TChunkIHDR) or (ChunkClass = TChunkIDAT) or
    (ChunkClass = TChunkPLTE) or (ChunkClass = TChunkIEND)) and not
    (Owner.BeingCreated) then
    fOwner.RaiseError(EPngError, EPNGCannotAddChunkText)
  {Two of these is not allowed}
  else if ((ChunkClass = TChunkgAMA) and (ItemFromClass(TChunkgAMA) <> nil)) or
     ((ChunkClass = TChunktRNS) and (ItemFromClass(TChunktRNS) <> nil)) or
     ((ChunkClass = TChunkpHYs) and (ItemFromClass(TChunkpHYs) <> nil)) then
    fOwner.RaiseError(EPngError, EPNGCannotAddChunkText)
  {There must have an IEND and IHDR chunk}
  else if ((ItemFromClass(TChunkIEND) = nil) or
    (ItemFromClass(TChunkIHDR) = nil)) and not Owner.BeingCreated then
    fOwner.RaiseError(EPngError, EPNGCannotAddInvalidImageText)
  else
  begin
    {Get common chunks}
    IHDR := ItemFromClass(TChunkIHDR) as TChunkIHDR;
    IEND := ItemFromClass(TChunkIEND) as TChunkIEND;
    {Create new chunk}
    Result := ChunkClass.Create(Owner);
    {Add to the list}
    if (ChunkClass = TChunkgAMA) or (ChunkClass = TChunkpHYs) or
      (ChunkClass = TChunkPLTE) then
      Insert(Result, IHDR.Index + 1)
    {Header and end}
    else if (ChunkClass = TChunkIEND) then
      Insert(Result, Count)
    else if (ChunkClass = TChunkIHDR) then
      Insert(Result, 0)
    {Transparency chunk (fix by Ian Boyd)}
    else if (ChunkClass = TChunktRNS) then
    begin
      {Transparecy chunk must be after PLTE; before IDAT}
      IDAT := ItemFromClass(TChunkIDAT) as TChunkIDAT;
      PLTE := ItemFromClass(TChunkPLTE) as TChunkPLTE;

      if Assigned(PLTE) then
        Insert(Result, PLTE.Index + 1)
      else if Assigned(IDAT) then
        Insert(Result, IDAT.Index)
      else
        Insert(Result, IHDR.Index + 1)
    end
    else {All other chunks}
      Insert(Result, IEND.Index);
  end {if}
end;

{Returns item from the list}
function TPNGList.GetItem(Index: Cardinal): TChunk;
begin
  Result := inherited GetItem(Index);
end;

{Returns first item from the list using the class from parameter}
function TPNGList.ItemFromClass(ChunkClass: TChunkClass): TChunk;
var
  i: Integer;
begin
  Result := nil; {Initial result}
  FOR i := 0 TO Count - 1 DO
    {Test if this item has the same class}
    if Item[i] is ChunkClass then
    begin
      {Returns this item and exit}
      Result := Item[i];
      break;
    end {if}
end;

{$IFNDEF UseDelphi}

  {TStream implementation}

  {Copies all from another stream}
  function TStream.CopyFrom(Source: TStream; Count: Cardinal): Cardinal;
  const
    MaxBytes = $f000;
  var
    Buffer:  PChar;
    BufSize, N: Cardinal;
  begin
    {If count is zero, copy everything from Source}
    if Count = 0 then
    begin
      Source.Seek(0, soFromBeginning);
      Count := Source.Size;
    end;

    Result := Count; {Returns the number of bytes readed}
    {Allocates memory}
    if Count > MaxBytes then BufSize := MaxBytes else BufSize := Count;
    GetMem(Buffer, BufSize);

    {Copy memory}
    while Count > 0 do
    begin
      if Count > BufSize then N := BufSize else N := Count;
      Source.Read(Buffer^, N);
      Write(Buffer^, N);
      dec(Count, N);
    end;

    {Deallocates memory}
    FreeMem(Buffer, BufSize);
  end;

{Set current stream position}
procedure TStream.SetPosition(const Value: Longint);
begin
  Seek(Value, soFromBeginning);
end;

{Returns position}
function TStream.GetPosition: Longint;
begin
  Result := Seek(0, soFromCurrent);
end;

  {Returns stream size}
function TStream.GetSize: Longint;
  var
    Pos: Cardinal;
  begin
    Pos := Seek(0, soFromCurrent);
    Result := Seek(0, soFromEnd);
    Seek(Pos, soFromCurrent);
  end;

  {TFileStream implementation}

  {Filestream object being created}
  constructor TFileStream.Create(Filename: String; Mode: TFileStreamModeSet);
    {Makes file mode}
    function OpenMode: DWORD;
    begin
      Result := 0;
      if fsmRead in Mode then Result := GENERIC_READ;
      if (fsmWrite in Mode) or (fsmCreate in Mode) then
        Result := Result OR GENERIC_WRITE;
    end;
  const
    IsCreate: Array[Boolean] of Integer = (OPEN_ALWAYS, CREATE_ALWAYS);
  begin
    {Call ancestor}
    inherited Create;

    {Create handle}
    fHandle := CreateFile(PChar(Filename), OpenMode, FILE_SHARE_READ or
      FILE_SHARE_WRITE, nil, IsCreate[fsmCreate in Mode], 0, 0);
    {Store mode}
    FileMode := Mode;
  end;

  {Filestream object being destroyed}
  destructor TFileStream.Destroy;
  begin
    {Terminates file and close}
    if FileMode = [fsmWrite] then
      SetEndOfFile(fHandle);
    CloseHandle(fHandle);

    {Call ancestor}
    inherited Destroy;
  end;

  {Writes data to the file}
  function TFileStream.Write(const Buffer; Count: Longint): Cardinal;
  begin
    if not WriteFile(fHandle, Buffer, Count, Result, nil) then
      Result := 0;
  end;

  {Reads data from the file}
  function TFileStream.Read(var Buffer; Count: Longint): Cardinal;
  begin
    if not ReadFile(fHandle, Buffer, Count, Result, nil) then
      Result := 0;
  end;

  {Seeks the file position}
  function TFileStream.Seek(Offset: Integer; Origin: Word): Longint;
  begin
    Result := SetFilePointer(fHandle, Offset, nil, Origin);
  end;

  {Sets the size of the file}
  procedure TFileStream.SetSize(const Value: Longint);
  begin
    Seek(Value, soFromBeginning);
    SetEndOfFile(fHandle);
  end;

  {TResourceStream implementation}

  {Creates the resource stream}
  constructor TResourceStream.Create(Instance: HInst; const ResName: String;
    ResType: PChar);
  var
    ResID: HRSRC;
    ResGlobal: HGlobal;
  begin
    {Obtains the resource ID}
    ResID := FindResource(hInstance, PChar(ResName), RT_RCDATA);
    if ResID = 0 then raise EPNGError.Create('');
    {Obtains memory and size}
    ResGlobal := LoadResource(hInstance, ResID);
    Size := SizeOfResource(hInstance, ResID);
    Memory := LockResource(ResGlobal);
    if (ResGlobal = 0) or (Memory = nil) then EPNGError.Create('');
  end;


  {Setting resource stream size is not supported}
  procedure TResourceStream.SetSize(const Value: Integer);
  begin
  end;

  {Writing into a resource stream is not supported}
  function TResourceStream.Write(const Buffer; Count: Integer): Cardinal;
  begin
    Result := 0;
  end;

  {Reads data from the stream}
  function TResourceStream.Read(var Buffer; Count: Integer): Cardinal;
  begin
    //Returns data
    CopyMemory(@Buffer, Ptr(Longint(Memory) + Position), Count);
    //Update position
    inc(Position, Count);
    //Returns
    Result := Count;
  end;

  {Seeks data}
  function TResourceStream.Seek(Offset: Integer; Origin: Word): Longint;
  begin
    {Move depending on the origin}
    case Origin of
      soFromBeginning: Position := Offset;
      soFromCurrent: inc(Position, Offset);
      soFromEnd: Position := Size + Offset;
    end;

    {Returns the current position}
    Result := Position;
  end;

{$ENDIF}

{TChunk implementation}

{Resizes the data}
procedure TChunk.ResizeData(const NewSize: Cardinal);
begin
  fDataSize := NewSize;
  ReallocMem(fData, NewSize + 1);
end;

{Returns index from list}
function TChunk.GetIndex: Integer;
var
  i: Integer;
begin
  Result := -1; {Avoiding warnings}
  {Searches in the list}
  FOR i := 0 TO Owner.Chunks.Count - 1 DO
    if Owner.Chunks.Item[i] = Self then
    begin
      {Found match}
      Result := i;
      exit;
    end {for i}
end;

{Returns pointer to the TChunkIHDR}
function TChunk.GetHeader: TChunkIHDR;
begin
  Result := Owner.Chunks.Item[0] as TChunkIHDR;
end;

{Assigns from another TChunk}
procedure TChunk.Assign(Source: TChunk);
begin
  {Copy properties}
  fName := Source.fName;
  {Set data size and realloc}
  ResizeData(Source.fDataSize);

  {Copy data (if there's any)}
  if fDataSize > 0 then CopyMemory(fData, Source.fData, fDataSize);
end;

{Chunk being created}
constructor TChunk.Create(Owner: TPngObject);
var
  ChunkName: String;
begin
  {Ancestor create}
  inherited Create;

  {If it's a registered class, set the chunk name based on the class}
  {name. For instance, if the class name is TChunkgAMA, the GAMA part}
  {will become the chunk name}
  ChunkName := Copy(ClassName, Length('TChunk') + 1, Length(ClassName));
  if Length(ChunkName) = 4 then CopyMemory(@fName[0], @ChunkName[1], 4);

  {Initialize data holder}
  GetMem(fData, 1);
  fDataSize := 0;
  {Record owner}
  fOwner := Owner;
end;

{Chunk being destroyed}
destructor TChunk.Destroy;
begin
  {Free data holder}
  FreeMem(fData, fDataSize + 1);
  {Let ancestor destroy}
  inherited Destroy;
end;

{Returns the chunk name 1}
function TChunk.GetChunkName: String;
begin
  Result := fName
end;

{Returns the chunk name 2}
class function TChunk.GetName: String;
begin
  {For avoid writing GetName for each TChunk descendent, by default for}
  {classes which don't declare GetName, it will look for the class name}
  {to extract the chunk kind. Example, if the class name is TChunkIEND }
  {this method extracts and returns IEND}
  Result := Copy(ClassName, Length('TChunk') + 1, Length(ClassName));
end;

{Saves the data to the stream}
function TChunk.SaveData(Stream: TStream): Boolean;
var
  ChunkSize, ChunkCRC: Cardinal;
begin
  {First, write the size for the following data in the chunk}
  ChunkSize := ByteSwap(DataSize);
  Stream.Write(ChunkSize, 4);
  {The chunk name}
  Stream.Write(fName, 4);
  {If there is data for the chunk, write it}
  if DataSize > 0 then Stream.Write(Data^, DataSize);
  {Calculates and write CRC}
  ChunkCRC := update_crc($ffffffff, @fName[0], 4);
  ChunkCRC := Byteswap(update_crc(ChunkCRC, Data, DataSize) xor $ffffffff);
  Stream.Write(ChunkCRC, 4);

  {Returns that everything went ok}
  Result := TRUE;
end;

{Saves the chunk to the stream}
function TChunk.SaveToStream(Stream: TStream): Boolean;
begin
  Result := SaveData(Stream)
end;


{Loads the chunk from a stream}
function TChunk.LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
  Size: Integer): Boolean;
var
  CheckCRC: Cardinal;
  {$IFDEF CheckCRC}RightCRC: Cardinal;{$ENDIF}
begin
  {Copies data from source}
  ResizeData(Size);
  if Size > 0 then Stream.Read(fData^, Size);
  {Reads CRC}
  Stream.Read(CheckCRC, 4);
  CheckCrc := ByteSwap(CheckCRC);