sxpngutils.pas

skin components for design of your applicastions

  const ChunkName:TChunkName;Size:Integer):Boolean;
var
  ErrorOutput:String;
  CompressionMethod:Byte;
  Output:Pointer;
  OutputSize:Integer;
begin
  Result:=inherited LoadFromStream(Stream,ChunkName,Size);
  if not Result or (Size<4) then exit;
  fKeyword:=PChar(Data);
  CompressionMethod:=PByte(Longint(fKeyword)+Length(fKeyword))^;
  fText:='';
  if CompressionMethod=0 then
  begin
    Output:=nil;
    if DecompressZLIB(PChar(Longint(Data)+Length(fKeyword)+2),
      Size-Length(fKeyword)-2,Output,OutputSize,ErrorOutput) then
    begin
      SetLength(fText,OutputSize);
      CopyMemory(@fText[1],Output,OutputSize);
    end;
    FreeMem(Output);
  end;
end;

function TChunkztXt.SaveToStream(Stream:TStream):Boolean;
var
  Output:Pointer;
  OutputSize:Integer;
  ErrorOutput:String;
begin
  Output:=nil;
  if fText='' then fText:=' ';
  if CompressZLIB(@fText[1],Length(fText),Owner.CompressionLevel,Output,
    OutputSize,ErrorOutput) then
  begin
    ResizeData(Length(fKeyword)+2+OutputSize);
    FillChar(Data^,DataSize,#0);
    if Keyword<>'' then
      CopyMemory(Data,@fKeyword[1],Length(Keyword));
    PByte(Ptr(Longint(Data)+Length(Keyword)+1))^:=0;
    if OutputSize>0 then
      CopyMemory(Ptr(Longint(Data)+Length(Keyword)+2),Output,OutputSize);
    Result:=SaveData(Stream);
  end else Result:=False;
  if Output<>nil then FreeMem(Output)
end;

procedure TChunktEXt.Assign(Source:TChunk);
begin
  fKeyword:=TChunktEXt(Source).fKeyword;
  fText:=TChunktEXt(Source).fText;
end;

function TChunktEXt.LoadFromStream(Stream:TStream;
  const ChunkName:TChunkName;Size:Integer):Boolean;
begin
  Result:=inherited LoadFromStream(Stream,ChunkName,Size);
  if not Result or (Size<3) then exit;
  fKeyword:=PChar(Data);
  SetLength(fText,Size-Length(fKeyword)-1);
  CopyMemory(@fText[1],Ptr(Longint(Data)+Length(fKeyword)+1),
    Length(fText));
end;

function TChunktEXt.SaveToStream(Stream:TStream):Boolean;
begin
  ResizeData(Length(fKeyword)+1+Length(fText));
  FillChar(Data^,DataSize,#0);
  if Keyword<>'' then
    CopyMemory(Data,@fKeyword[1],Length(Keyword));
  if Text<>'' then
    CopyMemory(Ptr(Longint(Data)+Length(Keyword)+1),@fText[1],
      Length(Text));
  Result:=inherited SaveToStream(Stream);
end;

constructor TChunkIHDR.Create(Owner:TPNGObject);
begin
 inherited Create(Owner);
end;

destructor TChunkIHDR.Destroy;
begin
  FreeImageData;
  inherited Destroy;
end;

procedure TChunkIHDR.Assign(Source:TChunk);
begin
  if Source is TChunkIHDR then
  begin
    IHDRData:=TChunkIHDR(Source).IHDRData;
    PrepareImageData;
    CopyMemory(ImageData,TChunkIHDR(Source).ImageData,
      BytesPerRow*Integer(Height));
    CopyMemory(ImageAlpha,TChunkIHDR(Source).ImageAlpha,
      Integer(Width)*Integer(Height));
    BitmapInfo.bmiColors:=TChunkIHDR(Source).BitmapInfo.bmiColors;
  end
  else
    Owner.RaiseError(EPNGError,EPNGCannotAssignChunkText);
end;

procedure TChunkIHDR.FreeImageData;
begin
  if ImageHandle<>0  then DeleteObject(ImageHandle);
  if ImageDC    <>0  then DeleteDC(ImageDC);
  if ImageAlpha<>nil then FreeMem(ImageAlpha);
  ImageHandle:=0;ImageDC:=0;ImageAlpha:=nil;ImageData:=nil;
end;

function TChunkIHDR.LoadFromStream(Stream:TStream;const ChunkName:TChunkName;
  Size:Integer):Boolean;
begin
  Result:=inherited LoadFromStream(Stream,ChunkName,Size);
  if not Result then exit;
  if (fDataSize<sizeof(TIHdrData)) then
  begin
    Result:=False;
    Owner.RaiseError(EPNGInvalidIHDR,EPNGInvalidIHDRText);
    exit;
  end;
  IHDRData:=PIHDRData(fData)^;
  IHDRData.Width:=ByteSwap(IHDRData.Width);
  IHDRData.Height:=ByteSwap(IHDRData.Height);
  if (IHDRData.Width>High(Word)) or (IHDRData.Height>High(Word)) then
  begin
    Result:=False;
    Owner.RaiseError(EPNGSizeExceeds,EPNGSizeExceedsText);
    exit;
  end;
  if (IHDRData.CompressionMethod<>0) then
  begin
    Result:=False;
    Owner.RaiseError(EPNGUnknownCompression,EPNGUnknownCompressionText);
    exit;
  end;
  if (IHDRData.InterlaceMethod<>0) and (IHDRData.InterlaceMethod<>1) then
  begin
    Result:=False;
    Owner.RaiseError(EPNGUnknownInterlace,EPNGUnknownInterlaceText);
    exit;
  end;
  Owner.InterlaceMethod:=TInterlaceMethod(IHDRData.InterlaceMethod);
  PrepareImageData;
end;

function TChunkIHDR.SaveToStream(Stream:TStream):Boolean;
begin
 if BitDepth=2 then BitDepth:=4;
 ResizeData(sizeof(TIHDRData));
 PIHDRData(fData)^:=IHDRData;
 PIHDRData(fData)^.Width:=ByteSwap(PIHDRData(fData)^.Width);
 PIHDRData(fData)^.Height:=ByteSwap(PIHDRData(fData)^.Height);
 PIHDRData(fData)^.InterlaceMethod:=Byte(Owner.InterlaceMethod);
 Result:=inherited SaveToStream(Stream);
end;

procedure TChunkIHDR.PrepareImageData;

 procedure SetInfo(const Bitdepth:Integer;const Palette:Boolean);
 begin
  HasPalette:=Palette;
  FillChar(BitmapInfo,sizeof(BitmapInfo),#0);
  with BitmapInfo.bmiHeader do
   begin
    biSize:=sizeof(TBitmapInfoHeader);
    biHeight:=Height;
    biWidth:=Width;
    biPlanes:=1;
    biBitCount:=BitDepth;
    biCompression:=BI_RGB;
   end;
 end;

begin
  FillChar(BitmapInfo,sizeof(TMaxBitmapInfo),#0);
  FreeImageData;
  case ColorType of
    COLOR_GRAYSCALE,COLOR_PALETTE,COLOR_GRAYSCALEALPHA:
      case BitDepth of
        1,4,8:SetInfo(BitDepth,True);
        2:SetInfo(4,True);
        16:SetInfo(8,True);
      end;
    COLOR_RGB,COLOR_RGBALPHA: SetInfo(24,False);
  end;
  BytesPerRow:=(((BitmapInfo.bmiHeader.biBitCount*Width)+31)
    and not 31) div 8;
  if (ColorType=COLOR_RGBALPHA) or (ColorType=COLOR_GRAYSCALEALPHA) then
  begin
    GetMem(ImageAlpha,Integer(Width)*Integer(Height));
    FillChar(ImageAlpha^,Integer(Width)*Integer(Height),#0);
  end;
  ImageDC:=CreateCompatibleDC(0);
  ImageHandle:=CreateDIBSection(ImageDC,PBitmapInfo(@BitmapInfo)^,
    DIB_RGB_COLORS,ImageData,0,0);
  with Owner do
    if  TempPalette<>0 then
    begin
      DeleteObject(TempPalette);
      TempPalette:=0;
    end;
  zeromemory(ImageData,BytesPerRow*Integer(Height));
end;

procedure TChunktRNS.SetTransparentColor(const Value:ColorRef);
var
  i:Byte;
  LookColor:TRGBQuad;
begin
  FillChar(PaletteValues,sizeof(PaletteValues),#0);
  fBitTransparency:=True;
  with Header do
    case ColorType of
      COLOR_GRAYSCALE:
      begin
        Self.ResizeData(2);
        PWord(@PaletteValues[0])^:=ByteSwap16(GetRValue(Value));
      end;
      COLOR_RGB:
      begin
        Self.ResizeData(6);
        PWord(@PaletteValues[0])^:=ByteSwap16(GetRValue(Value));
        PWord(@PaletteValues[2])^:=ByteSwap16(GetGValue(Value));
        PWord(@PaletteValues[4])^:=ByteSwap16(GetBValue(Value));
      end;
      COLOR_PALETTE:
      begin
        LookColor.rgbRed:=GetRValue(Value);
        LookColor.rgbGreen:=GetGValue(Value);
        LookColor.rgbBlue:=GetBValue(Value);
        for i:=0 to 255 do
          if CompareMem(@BitmapInfo.bmiColors[i],@LookColor,3) then
            Break;
        FillChar(PaletteValues,i,255);
        Self.ResizeData(i+1)
      end;
    end;
end;

function TChunktRNS.GetTransparentColor:ColorRef;
var PaletteChunk:TChunkPLTE;
               i:Integer;
begin
 Result:=0;
 with Header do
  case ColorType of
   COLOR_GRAYSCALE: Result:=RGB(PaletteValues[0],PaletteValues[0],PaletteValues[0]);
   COLOR_RGB:       Result:=RGB(PaletteValues[1],PaletteValues[3],PaletteValues[5]);
   COLOR_PALETTE:   begin
                     PaletteChunk:=Owner.Chunks.ItemFromClass(TChunkPLTE) as TChunkPLTE;
                     for i:=0 to Self.DataSize-1 do
                      if PaletteValues[i]=0 then
                       with PaletteChunk.GetPaletteItem(i) do
                        begin
                         Result:=RGB(rgbRed,rgbGreen,rgbBlue);
                         break;
                        end;
                    end;
  end;
end;

function TChunktRNS.SaveToStream(Stream:TStream):Boolean;
begin
 if DataSize<=256 then
  CopyMemory(fData,@PaletteValues[0],DataSize);
 Result:=inherited SaveToStream(Stream);
end;

procedure TChunktRNS.Assign(Source:TChunk);
begin
 CopyMemory(@PaletteValues[0],@TChunkTrns(Source).PaletteValues[0],256);
 fBitTransparency:=TChunkTrns(Source).fBitTransparency;
 inherited Assign(Source);
end;

function TChunktRNS.LoadFromStream(Stream:TStream;const ChunkName:TChunkName;Size:Integer):Boolean;
var i,Differ255:Integer;
begin
 Result:=inherited LoadFromStream(Stream,ChunkName,Size);
 if not Result then exit;
 if Size>256 then Owner.RaiseError(EPNGInvalidPalette,EPNGInvalidPaletteText);
 FillChar(PaletteValues[0],256,255);
 CopyMemory(@PaletteValues[0],fData,Size);
 case Header.ColorType of
  COLOR_RGB,
  COLOR_GRAYSCALE: fBitTransparency:=True;
  COLOR_PALETTE:   begin
                    Differ255:=0;
                    for i:=0 to Size-1 do
                     if PaletteValues[i]<>255 then Inc(Differ255);
                    fBitTransparency:=(Differ255=1);
                   end;
 end;
end;

procedure TChunkIDAT.PreparePalette;
var Entries:Word;
          J:Integer;
begin
 with Header do
  if (ColorType=COLOR_GRAYSCALE) or (ColorType=COLOR_GRAYSCALEALPHA) then
   begin
    Entries:=(1 shl Byte(BitmapInfo.bmiHeader.biBitCount));
    for J:=0 to Entries-1 do
     with BitmapInfo.bmiColors[j] do
      begin
       rgbRed:=fOwner.GammaTable[MulDiv(j,255,Entries-1)];
       rgbGreen:=rgbRed;
       rgbBlue:=rgbRed;
      end;
   end;
end;

function TChunkIDAT.IDATZlibRead(var ZLIBStream:TZStreamRec2;
  Buffer:Pointer;Count:Integer;var EndPos:Integer;
  var crcfile:Cardinal):Integer;
var
  ProcResult:Integer;
  IDATHeader:array[0..3]of Char;
  IDATCRC:Cardinal;
begin
  with ZLIBStream,ZLIBStream.zlib do
  begin
    next_out:=Buffer;
    avail_out:=Count;
    while avail_out>0 do
    begin
      if (fStream.Position=EndPos) and (avail_out>0) and
        (avail_in=0) then
      begin
        fStream.Read(IDATCRC,4);

        if crcfile xor $ffffffff<>Cardinal(ByteSwap(IDATCRC)) then
        begin
          Result:=-1;
          Owner.RaiseError(EPNGInvalidCRC,EPNGInvalidCRCText);
          exit;
        end;
        fStream.Read(EndPos,4);
        fStream.Read(IDATHeader[0],4);
        if IDATHeader<>'IDAT' then
        begin
          Owner.RaiseError(EPNGMissingMultipleIDAT,EPNGMissingMultipleIDATText);
          result:=-1;
          exit;
        end;
        crcfile:=update_crc($ffffffff,@IDATHeader[0],4);
        EndPos:=fStream.Position+ByteSwap(EndPos);
      end;
      if avail_in=0 then
      begin
        if fStream.Position+ZLIBAllocate>EndPos then
          avail_in:=fStream.Read(Data^,EndPos-fStream.Position)
         else
          avail_in:=fStream.Read(Data^,ZLIBAllocate);
        crcfile:=update_crc(crcfile,Data,avail_in);
        if avail_in=0 then
        begin
          Result:=Count-avail_out;
          exit;
        end;
        next_in:=Data;
      end;
      ProcResult:=inflate(zlib,0);
      if (ProcResult<0) then
      begin
        Result:=-1;
        Owner.RaiseError(EPNGZLIBError,
          EPNGZLIBErrorText+zliberrors[procresult]);
        exit;
      end;
    end;
  end;
  Result:=Count;
end;

const   RowStart:array[0..6]of Integer=(0,0,4,0,2,0,1);
     ColumnStart:array[0..6]of Integer=(0,4,0,2,0,1,0);
    RowIncrement:array[0..6]of Integer=(8,8,8,4,4,2,2);
 ColumnIncrement:array[0..6]of Integer=(8,8,4,4,2,2,1);

procedure TChunkIDAT.CopyInterlacedRGB8(const Pass:Byte;Src,Dest,Trans:PChar);
var Col:Integer;
begin
 Col:=ColumnStart[Pass];
 Dest:=PChar(Longint(Dest)+Col*3);
 repeat
  Byte(Dest^):=fOwner.GammaTable[PByte(Longint(Src)+2)^]; Inc(Dest);
  Byte(Dest^):=fOwner.GammaTable[PByte(Longint(Src)+1)^]; Inc(Dest);
  Byte(Dest^):=fOwner.GammaTable[PByte(Longint(Src))^]; Inc(Dest);
  Inc(Src,3);
  Inc(Dest,ColumnIncrement[Pass]*3-3);
  Inc(Col,ColumnIncrement[Pass]);
 until Col>=ImageWidth;
end;

procedure TChunkIDAT.CopyInterlacedRGB16(const Pass:Byte;Src,Dest,Trans:PChar);
var Col:Integer;
begin
 Col:=ColumnStart[Pass];
 Dest:=PChar(Longint(Dest)+Col*3);