pngimage1.pas

查看html文件的控件

{:Returns an item from the list}
function TChunkClasses.GetItem(Index: Integer): TChunkClassInfo;
begin
  {Test if the index is valid}
  if (Index < 0) or (Index > Count - 1) then
    CallError(PNG_ERROR_INVALID_CHUNK_CLASS_INDEX);

    Result := pChunkClassInfo(fList[Index])^;

end;


{Returns the number of items in the list}
function TChunkClasses.GetCount: Integer;
begin
  {If the list object exists, then return the count from it}
  {otherwise returns 0                                     }
  if Assigned(fList) then
    Result := fList.Count
  else
    Result := 0;
end;

{:Add a new chunk class to the list of classes}
procedure TChunkClasses.Add(ChunkType: TChunkType;
  ChunkClass: TChunkClass);
var
  NewItem: pChunkClassInfo;
begin
  {Create the list if it does not exists}
  if not Assigned(fList) then
    fList := TList.Create;

  {Allocate memory for the new item}
  New(NewItem);

  {Set the new item properties}
  NewItem^.ChunkType := ChunkType;
  NewItem^.ChunkClass := ChunkClass;

  {Add to the list}
  fList.Add(NewItem);

end;

{Do the action when the chunk is read}
procedure TChunk.DoAction;
begin
  inherited;
end;

{Returns a pointer to the png image owner}
function TChunk.GetBitmap: TPNGImage;
begin
  Result := Owner.Owner;
end;

{Returns a pointer to the GAMA}
function TChunk.GetGAMA: TChunkGAMA;
var
  Pos: Integer;
begin
  {Position of the chunk}
  Pos := Owner.IndexOfClass(TChunkGAMA); { Paul }

  {Returns nil if the chunk does not exists}
  if Pos = -1 then
    Result := nil
  else
    Result := TChunkGAMA(Owner[Pos]);

end;

{Returns a pointer to the IHDR}
function TChunk.GetIHDR: TChunkIHDR;
begin
  Result := TChunkIHDR(Owner[0]);
end;

{:Assign from another chunk}
procedure TChunk.Assign(Source: TChunk);
begin
  {Clear the current stream}
  fStream.Clear;
  {Copy data from the other stream}
  fStream.CopyFrom(Source.fStream, 0);

  {Copy the chunk name}
  fType := Source.fType;
end;

{:Returns the chunk size}
function TChunk.GetSize: Integer;
begin
  Result := fStream.Size;
end;

{:Saves the chunk data to the stream}
procedure TChunk.SaveToStream(Stream: TStream);
var
  ChunkLen: Cardinal;
  ChunkCRC: Cardinal;
begin
  {The chunk is not safe-to-copy}
  (*if ChunkType[3] = LowerCase(ChunkType[3]) then *)
  if fType[3] = LowerCase(fType[3]) then  //LDB  C++Builder fix
    exit;

  {First the chunk length}
  ChunkLen := SwapLong(fStream.Size);
  Stream.Write(ChunkLen, 4);

  {Now write the chunk type}
  Stream.Write(fType, 4);

  {Write the chunk data}
  Stream.CopyFrom(fStream, 0);

  {Calculate and write the CRC}
  ChunkCRC := SwapLong(CRC(fType, fStream.Memory, fStream.Size));
  Stream.Write(ChunkCRC, 4);
end;

{Retrieve the chunk index inside the list}
function TChunk.GetIndex: Integer;
begin
  Result := Owner.IndexOfChunk(Self); { Paul }
end;

{:Called when the object is being created}
constructor TChunk.Create(AOwner: TChunkList);
var
  ClassPos: Integer;
begin
  {Create the stream containg the memory data}
  fStream := TMemoryStream.Create;
  fList := AOwner;

  {Default class name}
  ClassPos := ChunkClasses.IndexOfClass(TChunkClass(ClassType)); { Paul }
  if ClassPos <> -1 then
    fType := ChunkClasses[ClassPos].ChunkType;
end;

{:Called when the object is being destroyed}
destructor TChunk.Destroy;
begin
  {Free the stream containing the memory data}
  fStream.Free;

  inherited;
end;

{:Move one chunk position in the list}
procedure TChunkList.Move(Index1, Index2: Integer);
begin
  {Test for index}
  if (Index1 < 0) or (Index1 >= Count) then
    CallError(PNG_ERROR_INVALID_CHUNK_INDEX);

  FList.Move(Index1, Index2);
end;

{Returns the number of items in the list (Used with Count property)}
function TChunkList.GetCount: Integer;
begin
  Result := fList.Count;
end;

{Returns an item from the list (Used with Item property)}
function TChunkList.GetItem(Index: Integer): TChunk;
begin
  {Test if the chunk index is valid}
  if (Index < 0) or (Index > Count - 1) then
    CallError(PNG_ERROR_INVALID_CHUNK_INDEX);

  {If so, return the item}
  Result := fList[Index];
end;

{:Removes a chunk}
procedure TChunkList.Remove(Item: TChunk);
begin
  {Makes sure that the list contains the chunk}
  if Item.Owner <> Self then
    CallError(CHUNK_NOT_CHILD);

  {Delete the chunk}
  FList.Delete(Item.Index);
  Item.Free;

end;

{:Add a chunk to the list when the chunk object ALREADY EXISTS}
function TChunkList.AddItem(Item: TChunk): TChunk; { Paul }
begin
  {Add the item to the list}
  fList.Add(Item);
  Result := Item;
end;


{:Returns the index of the first chunk of the type in the parameter}
function TChunkList.IndexOfClass(ChunkClass: TChunkClass): Integer; { Paul }
var
  I: Integer;
begin
  {Returns -1 if none found}
  Result := -1;

  {If there are items in the list, test each item}
  if Count > 0 then
    FOR i := 0 TO Count - 1 DO
      if Item[I].ClassType = ChunkClass then
      begin
        result := i;
        break;
      end;
end;

{:Returns the position of a chunk inside the list}
function TChunkList.IndexOfChunk(Chunk: TChunk): Integer; { Paul }
begin
  Result := fList.IndexOf(Chunk);
end;

{:Add a chunk to the list when the chunk object DOES NOT EXISTS
  but it already knows which chunk class to create}
function TChunkList.AddClass(ChunkClass: TChunkClass): TChunk; { Paul }
begin
  Result := AddItem(ChunkClass.Create(Self));
end;

{:Add a chunk to the list when the chunk data needs to be readed
 from a stream.                                                }
function TChunkList.AddStream(Stream: TStream): TChunk; { Paul }
var
  CLength: Cardinal;
  CType  : TChunkType;
  CCRC   : Cardinal;
  i, p   : Integer;
begin
  {First read the chunk length}
  Stream.Read(CLength, 4);
  CLength := SwapLong(CLength);
  {Now read the chunk type}
  Stream.Read(CType, 4);

  {Look for chunk classes supporting the given chunk type}
  i := ChunkClasses.IndexOfType(CType); { Paul }

  {Test if the chunk is critical but unknown}
  if ((Byte(CType[0]) AND $20) = 0) and (i = -1) then
    CallError(PNG_ERROR_UNKOWN_CRITICAL_CHUNK);

  {If the chunk type exists in the list, then create an object  }
  {using the class found, otherwise use the generic TChunk class}
  if i <> - 1 then
    Result := ChunkClasses[I].ChunkClass.Create(Self)
  else
    Result := TChunk.Create(Self);

  {Copy the chunk type}
  Result.fType := CType;

  {Read the data if the chunk contains data}
  if CLength > 0 then
    Result.fStream.CopyFrom(Stream, CLength);

  {Read the CRC for checking}
  Stream.Read(CCRC, 4);
  CCRC := SwapLong(CCRC);

  {Test if the CRC is valid}
  if CRC(CType, Result.fStream.Memory, CLength) <> CCRC then
    CallError(PNG_ERROR_CHUNK_INVALID_CRC);

  {If there are already IDAT chunks, then mix the actual IDAT}
  {being readed with the previous IDAT}
  if (Result is TChunkIDAT) then
    p := IndexOfClass(TChunkIDAT) { Paul }
  else
    p := -1;

  if (Result is TChunkIDAT) and (p <> -1) then
  begin
    {Copy data to the old stream}
    Item[p].fStream.CopyFrom(Result.fStream, 0);

    {Free the actual IDAT stream and returns the last}
    Result.Free;
    Result := Item[p];
  end
  else {Add the item to the list}
    Result := AddItem(Result); { Paul }
end;

{:Clear all the chunks in the list}
procedure TChunkList.Clear;
var
  i: Integer;
begin
  {If there are items in the list, delete each one}
  if Count > 0 then
    FOR i := Count - 1 DOWNTO 0 DO
    BEGIN
      {Free the chunk and delete from the list}
      Item[i].Free;
      FList.Delete(I);
    END;

end;

{:Called when the object is being created}
constructor TChunkList.Create(AOwner: TPNGImage);
begin
  {Copy the TPNGImage owner pointer}
  fImage := AOwner;

  {Create the TList}
  fList := TList.Create;
end;

{:Called when the object is being destroyed}
destructor TChunkList.Destroy;
begin
  {Clear and free the TList}
  Clear;
  fList.Free;

  inherited;
end;


{:Special override for assigning other TPNGImages}
procedure TPNGImage.Assign(Source: TPersistent);
var
  SourcePNG: TPNGImage;
  i, j     : Integer;
begin
  {If the source is also a TPNGImage, copy the chunks}
  if Source is TPNGImage then
  begin
    SourcePNG := TPNGImage(Source);
    {Clear current chunks}
    Chunks.Clear;

    {Copy the chunks}
    if SourcePNG.Chunks.Count > 0 then
    FOR i := 0 TO SourcePNG.Chunks.Count - 1 DO
    begin
      j := Chunkclasses.IndexOfType(SourcePNG.Chunks[i].fType); { Paul }
      {If the class is a know class, create it using that class}
      {otherwise with the default TChunk class}
      if j <> -1 then
        Chunks.AddItem(Chunkclasses[j].ChunkClass.Create(Chunks)).Assign(SourcePNG.Chunks[i]) { Paul }
      else
        Chunks.AddItem(TChunk.Create(Chunks)).Assign(SourcePNG.Chunks[i]); { Paul }
    end;

    {Copy other info}
    Filter := SourcePNG.fEncodeFilter;
    Interlacing := SourcePNG.fInterlacing;
  end;

  inherited;

end;

{:Called when the object is being created}
constructor TPNGImage.Create;
begin
  inherited;
  fMask := nil;

  {Create the list of chunks object}
  fChunkList := TChunkList.Create(Self);
  fInterlacing := FALSE;

  Filter := [efNone, efSub, efAverage, efPaeth];

  {Create the standard chunks}
  Clear;
end;

{:Called when the object is being destroyed}
destructor TPNGImage.Destroy;
begin
  {Free the mask if assigned}
  if Assigned(fMask) then
    fMask.Free;

  {Destroy the list of chunks object}
  fChunkList.Free;
  inherited;
end;

{Set the filters that are going to be used when encoding}
procedure TPNGImage.SetFilter(Value: TEncodeFilterSet);
begin
  {efNone is the only value that the set must have}
  if not (efNone in Value) then
    Include(Value, efNone);

  fEncodeFilter := Value;
end;

{:Clears the current image}
procedure TPNGImage.Clear;
begin
  {Clear the current chunks}
  Chunks.Clear;

  with TChunkIHDR(Chunks.AddClass(TChunkIHDR)) do { Paul }
  begin
    Width := 0;
    Height := 0;
    BitDepth := 2;
    ColorType := 3;
    Compression := 0;
    Filter := 0;
    Interlaced := 0;
  end;

  {Clears the palette}
  Palette := 0;

  {Add IDAT chunk}
  Chunks.AddClass(TChunkIDAT); { Paul }

  {Add IEND chunk}
  Chunks.AddClass(TChunkIEND); { Paul }
end;

{:Saves the current PNG image to the stream}
procedure TPNGImage.SaveToStream(Stream: TStream);
var
  i: Integer;
begin
  {Do the actual writting}
  with Stream do
  begin
    {Write the valid header}
    Write(PNGHeader, 8);

    {If there are no chunks, then create the standard ones}
    if Chunks.Count = 0 then
      Clear;

    {Ensure that there is a IHDR chunk}
    if (Chunks.Count = 0) or (not (Chunks[0] is TChunkIHDR)) then
      Chunks.Move(Chunks.AddClass(TChunkIHDR).Index, 0); { Paul }

    {PLTE chunk needed}
    if ((PixelFormat = pf1bit) or (PixelFormat = pf4bit) or
      (PixelFormat = pf8bit)) and (Chunks.IndexOfClass(TChunkPLTE) = -1) then { Paul }
      Chunks.M