fcl-image: tiff: reader+writer: deflate compression

git-svn-id: trunk@21549 -

packages/fcl-image/src/fpreadtiff.pas

@@ -18,13 +18,13 @@
    RGB 8,16bit (optional alpha),
    Orientation,
    skipping Thumbnail to read first image,
-   compression: packbits, LZW
+   compression: packbits, LZW, deflate
    endian
    multiple images
    strips and tiles
 
  ToDo:
-   Compression: deflate, jpeg, ...
+   Compression: jpeg, ...
    PlanarConfiguration 2
    ColorMap
    separate mask
@@ -43,7 +43,7 @@ unit FPReadTiff;
 interface
 
 uses
-  Math, Classes, SysUtils, FPimage, ctypes, FPTiffCmn;
+  Math, Classes, SysUtils, ctypes, zinflate, zbase, FPimage, FPTiffCmn;
 
 type
   TFPReaderTiff = class;
@@ -104,7 +104,7 @@ type
     procedure SetFPImgExtras(CurImg: TFPCustomImage);
     procedure DecodePackBits(var Buffer: Pointer; var Count: PtrInt);
     procedure DecodeLZW(var Buffer: Pointer; var Count: PtrInt);
-    procedure DecodeDeflatePKZip(var Buffer: Pointer; var Count: PtrInt);
+    procedure DecodeDeflate(var Buffer: Pointer; var Count: PtrInt; ExpectedCount: PtrInt);
   protected
     procedure InternalRead(Str: TStream; AnImage: TFPCustomImage); override;
     function InternalCheck(Str: TStream): boolean; override;
@@ -138,8 +138,9 @@ procedure DecompressPackBits(Buffer: Pointer; Count: PtrInt;
   out NewBuffer: Pointer; out NewCount: PtrInt);
 procedure DecompressLZW(Buffer: Pointer; Count: PtrInt;
   out NewBuffer: PByte; out NewCount: PtrInt);
-procedure DecompressDeflatePKZip(Buffer: Pointer; Count: PtrInt;
-  out NewBuffer: PByte; out NewCount: PtrInt);
+function DecompressDeflate(Compressed: PByte; CompressedCount: cardinal;
+  out Decompressed: PByte; var DecompressedCount: cardinal;
+  ErrorMsg: PAnsiString = nil): boolean;
 
 implementation
 
@@ -340,11 +341,14 @@ begin
     CurImg.Extra[TiffPageNumber]:=IntToStr(IFD.PageNumber);
     CurImg.Extra[TiffPageCount]:=IntToStr(IFD.PageCount);
   end;
-  CurImg.Extra[TiffPageName]:=IFD.PageName;
+  if IFD.PageName<>'' then
+    CurImg.Extra[TiffPageName]:=IFD.PageName;
   if IFD.ImageIsThumbNail then
     CurImg.Extra[TiffIsThumbnail]:='1';
   if IFD.ImageIsMask then
     CurImg.Extra[TiffIsMask]:='1';
+  if IFD.Compression<>TiffCompressionNone then
+    CurImg.Extra[TiffCompression]:=IntToStr(IFD.Compression);
 
   {$ifdef FPC_Debug_Image}
   if Debug then
@@ -679,7 +683,7 @@ begin
       TiffCompressionIT8BL,
       TiffCompressionPixarFilm,
       TiffCompressionPixarLog,
-      TiffCompressionDeflatePKZip,
+      TiffCompressionDeflateZLib,
       TiffCompressionDCS,
       TiffCompressionJBIG,
       TiffCompressionSGILog,
@@ -1690,15 +1694,22 @@ begin
       s.Read(Chunk^,CurByteCnt);
 
       // decompress
+      if ChunkType=tctTile then
+        ExpectedChunkLength:=(SampleBitsPerPixel*IFD.TileWidth+7) div 8*IFD.TileLength
+      else
+        ExpectedChunkLength:=((SampleBitsPerPixel*IFD.ImageWidth+7) div 8)*IFD.RowsPerStrip;
       case IFD.Compression of
-      TiffCompressionNone: ; // not compressed
-      TiffCompressionPackBits: DecodePackBits(Chunk,CurByteCnt); // packbits
-      TiffCompressionLZW: DecodeLZW(Chunk,CurByteCnt); // LZW
-      TiffCompressionDeflatePKZip: DecodeDeflatePKZip(Chunk,CurByteCnt); // Deflate
+      TiffCompressionNone: ;
+      TiffCompressionPackBits: DecodePackBits(Chunk,CurByteCnt);
+      TiffCompressionLZW: DecodeLZW(Chunk,CurByteCnt);
+      TiffCompressionDeflateAdobe,
+      TiffCompressionDeflateZLib: DecodeDeflate(Chunk,CurByteCnt,ExpectedChunkLength);
       else
         TiffError('compression '+TiffCompressionName(IFD.Compression)+' not supported yet');
       end;
       if CurByteCnt<=0 then continue;
+
+      // compute current chunk area
       if ChunkType=tctTile then begin
         ChunkLeft:=(ChunkIndex mod TilesAcross)*IFD.TileWidth;
         ChunkTop:=(ChunkIndex div TilesAcross)*IFD.TileLength;
@@ -1875,15 +1886,26 @@ begin
   Count:=NewCount;
 end;
 
-procedure TFPReaderTiff.DecodeDeflatePKZip(var Buffer: Pointer; var Count: PtrInt);
+procedure TFPReaderTiff.DecodeDeflate(var Buffer: Pointer; var Count: PtrInt;
+  ExpectedCount: PtrInt);
 var
-  NewBuffer: Pointer;
-  NewCount: PtrInt;
+  NewBuffer: PByte;
+  NewCount: cardinal;
+  ErrorMsg: String;
 begin
-  DecompressDeflatePKZip(Buffer,Count,NewBuffer,NewCount);
-  FreeMem(Buffer);
-  Buffer:=NewBuffer;
-  Count:=NewCount;
+  ErrorMsg:='';
+  NewBuffer:=nil;
+  try
+    NewCount:=ExpectedCount;
+    if not DecompressDeflate(Buffer,Count,NewBuffer,NewCount,@ErrorMsg) then
+      TiffError(ErrorMsg);
+    FreeMem(Buffer);
+    Buffer:=NewBuffer;
+    Count:=NewCount;
+    NewBuffer:=nil;
+  finally
+    ReAllocMem(NewBuffer,0);
+  end;
 end;
 
 procedure TFPReaderTiff.InternalRead(Str: TStream; AnImage: TFPCustomImage);
@@ -2258,13 +2280,77 @@ begin
   ReAllocMem(NewBuffer,NewCount);
 end;
 
-procedure DecompressDeflatePKZip(Buffer: Pointer; Count: PtrInt; out
-  NewBuffer: PByte; out NewCount: PtrInt);
+function DecompressDeflate(Compressed: PByte; CompressedCount: cardinal;
+  out Decompressed: PByte; var DecompressedCount: cardinal;
+  ErrorMsg: PAnsiString = nil): boolean;
+var
+  stream : z_stream;
+  err : integer;
 begin
-  NewBuffer:=nil;
-  NewCount:=0;
-  if Count=0 then exit;
-  raise Exception.Create('decompressing Deflate PKZip not yet supported');
+  Result:=false;
+  //writeln('DecompressDeflate START');
+  Decompressed:=nil;
+  if CompressedCount=0 then begin
+    DecompressedCount:=0;
+    exit;
+  end;
+
+  err := inflateInit(stream{%H-});
+  if err <> Z_OK then begin
+    if ErrorMsg<>nil then
+      ErrorMsg^:='inflateInit failed';
+    exit;
+  end;
+
+  // set input = compressed data
+  stream.avail_in := CompressedCount;
+  stream.next_in  := Compressed;
+
+  // set output = decompressed data
+  if DecompressedCount=0 then
+    DecompressedCount:=CompressedCount;
+  Getmem(Decompressed,DecompressedCount);
+  stream.avail_out := DecompressedCount;
+  stream.next_out := Decompressed;
+
+  // Finish the stream
+  while TRUE do begin
+    //writeln('run: total_in=',stream.total_in,' avail_in=',stream.avail_in,' total_out=',stream.total_out,' avail_out=',stream.avail_out);
+    if (stream.avail_out=0) then begin
+      // need more space
+      if DecompressedCount<128 then
+        DecompressedCount:=DecompressedCount+128
+      else if DecompressedCount>High(DecompressedCount)-1024 then begin
+        if ErrorMsg<>nil then
+          ErrorMsg^:='inflate decompression failed, because not enough space';
+        exit;
+      end else
+        DecompressedCount:=DecompressedCount*2;
+      ReAllocMem(Decompressed,DecompressedCount);
+      stream.next_out:=Decompressed+stream.total_out;
+      stream.avail_out:=DecompressedCount-stream.total_out;
+    end;
+    err := inflate(stream, Z_NO_FLUSH);
+    if err = Z_STREAM_END then
+      break;
+    if err<>Z_OK then begin
+      if ErrorMsg<>nil then
+        ErrorMsg^:='inflate finish failed';
+      exit;
+    end;
+  end;
+
+  //writeln('decompressed: total_in=',stream.total_in,' total_out=',stream.total_out);
+  DecompressedCount:=stream.total_out;
+  ReAllocMem(Decompressed,DecompressedCount);
+
+  err := inflateEnd(stream);
+  if err<>Z_OK then begin
+    if ErrorMsg<>nil then
+      ErrorMsg^:='inflateEnd failed';
+    exit;
+  end;
+  Result:=true;
 end;
 
 initialization

packages/fcl-image/src/fptiffcmn.pas

@@ -61,6 +61,7 @@ const
   TiffIsMask = TiffExtraPrefix+'IsMask';
   TiffTileWidth = TiffExtraPrefix+'TileWidth';
   TiffTileLength = TiffExtraPrefix+'TileLength';
+  TiffCompression = TiffExtraPrefix+'Compression'; // number
 
   TiffCompressionNone = 1; { No Compression, but pack data into bytes as tightly as possible,
        leaving no unused bits (except at the end of a row). The component
@@ -87,7 +88,7 @@ const
   TiffCompressionIT8BL = 32898; { IT8BL }
   TiffCompressionPixarFilm = 32908; { PIXARFILM }
   TiffCompressionPixarLog = 32909; { PIXARLOG }
-  TiffCompressionDeflatePKZip = 32946; { DeflatePKZip }
+  TiffCompressionDeflateZLib = 32946; { DeflatePKZip }
   TiffCompressionDCS = 32947; { DCS }
   TiffCompressionJBIG = 34661; { JBIG }
   TiffCompressionSGILog = 34676; { SGILOG }
@@ -240,7 +241,7 @@ begin
   32898: Result:='IT8BL';
   32908: Result:='PIXARFILM';
   32909: Result:='PIXARLOG';
-  32946: Result:='Deflate PKZip';
+  32946: Result:='Deflate ZLib';
   32947: Result:='DCS';
   34661: Result:='JBIG';
   34676: Result:='SGILOG';
@@ -258,7 +259,7 @@ begin
   IFDNext:=0;
   PhotoMetricInterpretation:=High(PhotoMetricInterpretation);
   PlanarConfiguration:=0;
-  Compression:=0;
+  Compression:=TiffCompressionNone;
   Predictor:=1;
   ImageHeight:=0;
   ImageWidth:=0;
@@ -399,6 +400,7 @@ begin
   ImageIsMask:=Src.Extra[TiffIsMask]<>'';
   TileWidth:=StrToIntDef(Src.Extra[TiffTileWidth],0);
   TileLength:=StrToIntDef(Src.Extra[TiffTileLength],0);
+  Compression:=StrToIntDef(Src.Extra[TiffCompression],TiffCompressionNone);
 end;
 
 function TTiffIFD.ImageLength: DWord;

packages/fcl-image/src/fpwritetiff.pas

@@ -19,9 +19,10 @@
    Orientation,
    multiple images, pages
    thumbnail
+   Compression: deflate
 
  ToDo:
-   Compression: LZW, packbits, deflate, jpeg, ...
+   Compression: LZW, packbits, jpeg, ...
    Planar
    ColorMap
    separate mask
@@ -37,7 +38,7 @@ unit FPWriteTiff;
 interface
 
 uses
-  Math, Classes, SysUtils, FPimage, FPTiffCmn;
+  Math, Classes, SysUtils, zbase, zdeflate, FPimage, FPTiffCmn;
 
 type
 
@@ -102,6 +103,7 @@ type
                        CopyData: boolean = true);
     procedure AddEntry(Entry: TTiffWriterEntry);
     procedure TiffError(Msg: string);
+    procedure EncodeDeflate(var Buffer: Pointer; var Count: DWord);
   public
     constructor Create; override;
     destructor Destroy; override;
@@ -113,6 +115,10 @@ type
 
 function CompareTiffWriteEntries(Entry1, Entry2: Pointer): integer;
 
+function CompressDeflate(InputData: PByte; InputCount: cardinal;
+  out Compressed: PByte; var CompressedCount: cardinal;
+  ErrorMsg: PAnsiString = nil): boolean;
+
 implementation
 
 function CompareTiffWriteEntries(Entry1, Entry2: Pointer): integer;
@@ -120,6 +126,85 @@ begin
   Result:=integer(TTiffWriterEntry(Entry1).Tag)-integer(TTiffWriterEntry(Entry2).Tag);
 end;
 
+function CompressDeflate(InputData: PByte; InputCount: cardinal; out
+  Compressed: PByte; var CompressedCount: cardinal; ErrorMsg: PAnsiString
+  ): boolean;
+var
+  stream : z_stream;
+  err : integer;
+begin
+  Result:=false;
+  //writeln('CompressDeflate START');
+  Compressed:=nil;
+  if InputCount=0 then begin
+    CompressedCount:=0;
+    exit(true);
+  end;
+
+  err := deflateInit(stream{%H-}, Z_DEFAULT_COMPRESSION);
+  if err <> Z_OK then begin
+    if ErrorMsg<>nil then
+      ErrorMsg^:='deflateInit failed';
+    exit;
+  end;
+
+  // set input = InputData data
+  stream.avail_in := InputCount;
+  stream.next_in  := InputData;
+
+  // set output = compressed data
+  if CompressedCount=0 then
+    CompressedCount:=InputCount;
+  GetMem(Compressed,CompressedCount);
+  stream.avail_out := CompressedCount;
+  stream.next_out := Compressed;
+
+  err := deflate(stream, Z_NO_FLUSH);
+  if err<>Z_OK then begin
+    if ErrorMsg<>nil then
+      ErrorMsg^:='deflate failed';
+    exit;
+  end;
+
+  while TRUE do begin
+    //writeln('run: total_in=',stream.total_in,' avail_in=',stream.avail_in,' total_out=',stream.total_out,' avail_out=',stream.avail_out);
+    if (stream.avail_out=0) then begin
+      // need more space
+      if CompressedCount<128 then
+        CompressedCount:=CompressedCount+128
+      else if CompressedCount>High(CompressedCount)-1024 then begin
+        if ErrorMsg<>nil then
+          ErrorMsg^:='deflate compression failed, because not enough space';
+        exit;
+      end else
+        CompressedCount:=CompressedCount+1024;
+      ReAllocMem(Compressed,CompressedCount);
+      stream.next_out:=Compressed+stream.total_out;
+      stream.avail_out:=CompressedCount-stream.total_out;
+    end;
+    err := deflate(stream, Z_FINISH);
+    if err = Z_STREAM_END then
+      break;
+    if err<>Z_OK then begin
+      if ErrorMsg<>nil then
+        ErrorMsg^:='deflate finish failed';
+      exit;
+    end;
+  end;
+
+  //writeln('compressed: total_in=',stream.total_in,' total_out=',stream.total_out);
+  CompressedCount:=stream.total_out;
+  ReAllocMem(Compressed,CompressedCount);
+
+  err := deflateEnd(stream);
+  if err<>Z_OK then begin
+    if ErrorMsg<>nil then
+      ErrorMsg^:='deflateEnd failed';
+    exit;
+  end;
+  Result:=true;
+end;
+
 { TFPWriterTiff }
 
 procedure TFPWriterTiff.WriteWord(w: Word);
@@ -301,7 +386,8 @@ var
   CurEntries: TFPList;
   Shorts: array[0..3] of Word;
   NewSubFileType: DWord;
-  cx,cy,dx,dy,x,y,sx: integer;
+  cx,cy,x,y,sx: DWord;
+  dx,dy: integer;
   ChunkBytesPerLine: DWord;
 begin
   ChunkOffsets:=nil;
@@ -349,7 +435,16 @@ begin
 
     ImgWidth:=Img.Width;
     ImgHeight:=Img.Height;
-    Compression:=1;
+    Compression:=IFD.Compression;
+    case Compression of
+    TiffCompressionNone,
+    TiffCompressionDeflateZLib: ;
+    else
+      {$ifdef FPC_DEBUG_IMAGE}
+      writeln('TFPWriterTiff.AddImage unsupported compression '+TiffCompressionName(Compression)+', using deflate instead.');
+      {$endif}
+      Compression:=TiffCompressionDeflateZLib;
+    end;
 
     if IFD.Orientation in [1..4] then begin
       OrientedWidth:=ImgWidth;
@@ -368,7 +463,7 @@ begin
     writeln('TFPWriterTiff.AddImage XResolution=',TiffRationalToStr(IFD.XResolution));
     writeln('TFPWriterTiff.AddImage YResolution=',TiffRationalToStr(IFD.YResolution));
     writeln('TFPWriterTiff.AddImage GrayBits=',GrayBits,' RedBits=',RedBits,' GreenBits=',GreenBits,' BlueBits=',BlueBits,' AlphaBits=',AlphaBits);
-    writeln('TFPWriterTiff.AddImage Compression=',Compression);
+    writeln('TFPWriterTiff.AddImage Compression=',TiffCompressionName(Compression));
     writeln('TFPWriterTiff.AddImage Page=',IFD.PageNumber,'/',IFD.PageCount);
     {$ENDIF}
 
@@ -454,14 +549,14 @@ begin
     AddEntry(ChunkOffsets.ChunkByteCounts);
     if (OrientedHeight>0) and (OrientedWidth>0) then begin
       if ChunkType=tctTile then begin
-        TilesAcross:=(OrientedWidth+IFD.TileWidth-1) div IFD.TileWidth;
-        TilesDown:=(OrientedHeight+IFD.TileLength-1) div IFD.TileLength;
+        TilesAcross:=(OrientedWidth+IFD.TileWidth{%H-}-1) div IFD.TileWidth;
+        TilesDown:=(OrientedHeight+IFD.TileLength{%H-}-1) div IFD.TileLength;
         ChunkCount:=TilesAcross*TilesDown;
         {$IFDEF FPC_Debug_Image}
         writeln('TFPWriterTiff.AddImage BitsPerPixel=',BitsPerPixel,' OrientedWidth=',OrientedWidth,' OrientedHeight=',OrientedHeight,' TileWidth=',IFD.TileWidth,' TileLength=',IFD.TileLength,' TilesAcross=',TilesAcross,' TilesDown=',TilesDown,' ChunkCount=',ChunkCount);
         {$ENDIF}
       end else begin
-        ChunkCount:=(OrientedHeight+IFD.RowsPerStrip-1) div IFD.RowsPerStrip;
+        ChunkCount:=(OrientedHeight+IFD.RowsPerStrip{%H-}-1) div IFD.RowsPerStrip;
       end;
       ChunkOffsets.SetCount(ChunkCount);
       // create chunks
@@ -484,9 +579,7 @@ begin
           ChunkBytes:=ChunkBytesPerLine*ChunkHeight;
         end;
         GetMem(Chunk,ChunkBytes);
-        FillByte(Chunk^,ChunkBytes,0);
-        ChunkOffsets.Chunks[ChunkIndex].Data:=Chunk;
-        ChunkOffsets.Chunks[ChunkIndex].Bytes:=ChunkBytes;
+        FillByte(Chunk^,ChunkBytes,0); // fill unused bytes with 0 to help compression
 
         // Orientation
         if IFD.Orientation in [1..4] then begin
@@ -575,6 +668,14 @@ begin
           // next y
           inc(y,dy);
         end;
+
+        // compress
+        case Compression of
+        TiffCompressionDeflateZLib: EncodeDeflate(Chunk,ChunkBytes);
+        end;
+
+        ChunkOffsets.Chunks[ChunkIndex].Data:=Chunk;
+        ChunkOffsets.Chunks[ChunkIndex].Bytes:=ChunkBytes;
         // next chunk
       end;
       // created chunks
@@ -671,6 +772,27 @@ begin
   raise Exception.Create('TFPWriterTiff.TiffError: '+Msg);
 end;
 
+procedure TFPWriterTiff.EncodeDeflate(var Buffer: Pointer; var Count: DWord);
+var
+  NewBuffer: PByte;
+  NewCount: cardinal;
+  ErrorMsg: String;
+begin
+  ErrorMsg:='';
+  NewBuffer:=nil;
+  try
+    NewCount:=Count;
+    if not CompressDeflate(Buffer,Count,NewBuffer,NewCount,@ErrorMsg) then
+      TiffError(ErrorMsg);
+    FreeMem(Buffer);
+    Buffer:=NewBuffer;
+    Count:=NewCount;
+    NewBuffer:=nil;
+  finally
+    ReAllocMem(NewBuffer,0);
+  end;
+end;
+
 constructor TFPWriterTiff.Create;
 begin
   inherited Create;