* Patch from Mattias Gaertner:

  - extends the tiff writer with some default values to write
  tiffs out of the box like the other fpimage writers.
  - progress events
  - basic CMYK support
  - allow reading non standard planarconfiguration attributes as created
  by some scanners
  - allow to create the image after reading the header - needed for big
  tiffs
  - removed TGA dependency
  - LZW-decompression was started. There is a bug I didn't found yet.

git-svn-id: trunk@12258 -

packages/fcl-image/src/fpreadtiff.pas

@@ -18,11 +18,11 @@
     RGB 8,16bit (optional alpha),
     Orientation,
     skipping Thumbnail to read first image,
-    compression: packbits,
+    compression: packbits, (LZW started)
     endian
 
   ToDo:
-    Compression: deflate, jpeg, ...
+    Compression: LZW, deflate, jpeg, ...
     Planar
     ColorMap
     multiple images
@@ -38,14 +38,19 @@ unit FPReadTiff;
 interface
 
 uses
-  Classes, SysUtils, FPimage, ctypes, FPTiffCmn;
+  Math, Classes, SysUtils, FPimage, ctypes, QVFPTiffCmn;
 
 type
+  TFPReaderTiff = class;
+
+  TTiffCreateCompatibleImgEvent = procedure(Sender: TFPReaderTiff;
+                                        var NewImage: TFPCustomImage) of object;
 
   { TFPReaderTiff }
 
   TFPReaderTiff = class(TFPCustomImageReader)
   private
+    FOnCreateImage: TTiffCreateCompatibleImgEvent;
     FReverserEndian: boolean;
     IDF: TTiffIDF;
     FDebug: boolean;
@@ -76,6 +81,7 @@ type
     function FixEndian(w: Word): Word; inline;
     function FixEndian(d: DWord): DWord; inline;
     procedure DecompressPackBits(var Buffer: Pointer; var Count: PtrInt);
+    procedure DecompressLZW(var Buffer: Pointer; var Count: PtrInt);
   protected
     procedure InternalRead(Str: TStream; AnImage: TFPCustomImage); override;
     function InternalCheck(Str: TStream): boolean; override;
@@ -89,6 +95,8 @@ type
     property StartPos: int64 read fStartPos;
     property ReverserEndian: boolean read FReverserEndian;
     property TheStream: TStream read s;
+    property OnCreateImage: TTiffCreateCompatibleImgEvent read FOnCreateImage
+                                                          write FOnCreateImage;
   end;
 
 implementation
@@ -115,8 +123,12 @@ procedure TFPReaderTiff.LoadFromStream(aStream: TStream);
 var
   IFDStart: LongWord;
   i: Integer;
+  aContinue: Boolean;
 begin
   Clear;
+  aContinue:=true;
+  Progress(psStarting, 0, False, Rect(0,0,0,0), '', aContinue);
+  if not aContinue then exit;
   s:=aStream;
   fStartPos:=s.Position;
   ReadTiffHeader(false,IFDStart);
@@ -126,6 +138,7 @@ begin
     ReadImage(i);
     inc(i);
   end;
+  Progress(psEnding, 100, False, Rect(0,0,0,0), '', aContinue);
 end;
 
 function TFPReaderTiff.ReadTiffHeader(QuickTest: boolean; out IFD: DWord): boolean;
@@ -200,6 +213,7 @@ var
   EntryStart: LongWord;
   NewEntryTag: Word;
   UValue: LongWord;
+  SValue: integer;
   WordBuffer: PWord;
   Count: DWord;
   i: Integer;
@@ -255,18 +269,17 @@ begin
       // BitsPerSample
       IDF.BitsPerSample:=DWord(s.Position-fStartPos-2);
       ReadShortValues(IDF.BitsPerSample,WordBuffer,Count);
-      try
-        SetLength(IDF.BitsPerSampleArray,Count);
-        for i:=0 to Count-1 do
-          IDF.BitsPerSampleArray[i]:=WordBuffer[i];
-      finally
-        ReAllocMem(WordBuffer,0);
-      end;
       if Debug then begin
         write('TFPReaderTiff.ReadDirectoryEntry BitsPerSample: ');
         for i:=0 to Count-1 do
           write(IntToStr(WordBuffer[i]),' ');
         writeln;
+      end;
+      try
+        SetLength(IDF.BitsPerSampleArray,Count);
+        for i:=0 to Count-1 do
+          IDF.BitsPerSampleArray[i]:=WordBuffer[i];
+      finally
         ReAllocMem(WordBuffer,0);
       end;
     end;
@@ -313,6 +326,7 @@ begin
       2: ; // RGB 0,0,0 is black
       3: ; // Palette color
       4: ; // Transparency Mask
+      5: ; // CMYK
       else
         TiffError('expected PhotometricInterpretation, but found '+IntToStr(UValue));
       end;
@@ -325,6 +339,7 @@ begin
         2: write('2=RGB 0,0,0 is black');
         3: write('3=Palette color');
         4: write('4=Transparency Mask');
+        5: write('5=CMYK 8bit');
         end;
         writeln;
       end;
@@ -395,7 +410,8 @@ begin
     begin
       // Make - scanner manufacturer
       IDF.Make_ScannerManufacturer:=ReadEntryString;
-      writeln('TFPReaderTiff.ReadDirectoryEntry Make_ScannerManufacturer=',IDF.Make_ScannerManufacturer);
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry Make_ScannerManufacturer=',IDF.Make_ScannerManufacturer);
     end;
   272:
     begin
@@ -492,17 +508,17 @@ begin
   284:
     begin
       // PlanarConfiguration
-      UValue:=ReadEntryUnsigned;
-      case UValue of
+      SValue:=ReadEntrySigned;
+      case SValue of
       1: ; // chunky format
       2: ; // planar format
       else
-        TiffError('expected PlanarConfiguration, but found '+IntToStr(UValue));
+        TiffError('expected PlanarConfiguration, but found '+IntToStr(SValue));
       end;
-      IDF.PlanarConfiguration:=UValue;
+      IDF.PlanarConfiguration:=SValue;
       if Debug then begin
         write('TFPReaderTiff.ReadDirectoryEntry PlanarConfiguration=');
-        case UValue of
+        case SValue of
         1: write('chunky format');
         2: write('planar format');
         end;
@@ -673,6 +689,18 @@ begin
       // long: 32bit unsigned long
       Result:=cint32(ReadDWord);
     end;
+  6: begin
+      // sbyte: 8bit signed
+      Result:=cint8(ReadByte);
+    end;
+  8: begin
+      // sshort: 16bit signed
+      Result:=cint16(ReadWord);
+    end;
+  9: begin
+      // slong: 32bit signed long
+      Result:=cint32(ReadDWord);
+    end;
   else
     TiffError('expected single signed value, but found type='+IntToStr(EntryType));
   end;
@@ -829,6 +857,7 @@ begin
   p:=nil;
   try
     ReadValues(StreamPos,EntryType,Count,p,ByteCount);
+    //writeln('ReadShortValues ',FReverseEndian,' ',EntryType,' Count=',Count,' ByteCount=',ByteCount);
     if Count=0 then exit;
     if EntryType=3 then begin
       // short
@@ -837,6 +866,7 @@ begin
       if FReverseEndian then
         for i:=0 to Count-1 do
           Buffer[i]:=FixEndian(Buffer[i]);
+      //for i:=0 to Count-1 do writeln(i,' ',Buffer[i]);
     end else
       TiffError('only short allowed, but found '+IntToStr(EntryType));
   finally
@@ -859,7 +889,7 @@ var
   y: DWord;
   y2: DWord;
   x: DWord;
-  Pixel: DWord;
+  GrayValue: DWord;
   dx: LongInt;
   dy: LongInt;
   SampleCnt: DWord;
@@ -879,7 +909,11 @@ var
   BlueBits: Word;
   AlphaBits: Word;
   BytesPerPixel: Integer;
+  aContinue: Boolean;
 begin
+  CurImg:=nil;
+  if Debug then
+    writeln('TFPReaderTiff.ReadImage Index=',Index);
   if IDF.PhotoMetricInterpretation=High(IDF.PhotoMetricInterpretation) then
     TiffError('missing PhotometricInterpretation');
   if IDF.RowsPerStrip=0 then
@@ -894,32 +928,8 @@ begin
     // Image already read
     exit;
   end;
-  CurImg:=FirstImg.Img;
-  FirstImg.Assign(IDF);
-
-  ClearTiffExtras(CurImg);
-  // set Tiff extra attributes
-  CurImg.Extra[TiffPhotoMetric]:=IntToStr(IDF.PhotoMetricInterpretation);
-  //writeln('TFPReaderTiff.ReadImage PhotoMetric=',CurImg.Extra[TiffPhotoMetric]);
-  if IDF.Artist<>'' then
-    CurImg.Extra[TiffArtist]:=IDF.Artist;
-  if IDF.Copyright<>'' then
-    CurImg.Extra[TiffCopyright]:=IDF.Copyright;
-  if IDF.DocumentName<>'' then
-    CurImg.Extra[TiffDocumentName]:=IDF.DocumentName;
-  if IDF.DateAndTime<>'' then
-    CurImg.Extra[TiffDateTime]:=IDF.DateAndTime;
-  if IDF.ImageDescription<>'' then
-    CurImg.Extra[TiffImageDescription]:=IDF.ImageDescription;
-  if IDF.Orientation<>0 then
-    CurImg.Extra[TiffOrientation]:=IntToStr(IDF.Orientation);
-  if IDF.ResolutionUnit<>0 then
-    CurImg.Extra[TiffResolutionUnit]:=IntToStr(IDF.ResolutionUnit);
-  if (IDF.XResolution.Numerator<>0) or (IDF.XResolution.Denominator<>0) then
-    CurImg.Extra[TiffXResolution]:=TiffRationalToStr(IDF.XResolution);
-  if (IDF.YResolution.Numerator<>0) or (IDF.YResolution.Denominator<>0) then
-    CurImg.Extra[TiffYResolution]:=TiffRationalToStr(IDF.YResolution);
-  //WriteTiffExtras('ReadImage',CurImg);
+  if Debug then
+    writeln('TFPReaderTiff.ReadImage reading ...');
 
   StripCount:=((IDF.ImageHeight-1) div IDF.RowsPerStrip)+1;
   StripOffsets:=nil;
@@ -946,13 +956,15 @@ begin
 
     case IDF.PhotoMetricInterpretation of
     0,1: if SampleCnt-ExtraSampleCnt<>1 then
-      TiffError('gray images expects one sample per pixel, but found '+IntToStr(SampleCnt));
+      TiffError('gray images expect one sample per pixel, but found '+IntToStr(SampleCnt));
     2: if SampleCnt-ExtraSampleCnt<>3 then
-      TiffError('rgb images expects three samples per pixel, but found '+IntToStr(SampleCnt));
+      TiffError('rgb images expect three samples per pixel, but found '+IntToStr(SampleCnt));
     3: if SampleCnt-ExtraSampleCnt<>1 then
-      TiffError('palette images expects one sample per pixel, but found '+IntToStr(SampleCnt));
+      TiffError('palette images expect one sample per pixel, but found '+IntToStr(SampleCnt));
     4: if SampleCnt-ExtraSampleCnt<>1 then
-      TiffError('mask images expects one sample per pixel, but found '+IntToStr(SampleCnt));
+      TiffError('mask images expect one sample per pixel, but found '+IntToStr(SampleCnt));
+    5: if SampleCnt-ExtraSampleCnt<>4 then
+      TiffError('cmyk images expect four samples per pixel, but found '+IntToStr(SampleCnt));
     end;
 
     GrayBits:=0;
@@ -965,29 +977,46 @@ begin
     0,1:
       begin
         GrayBits:=SampleBits[0];
-        CurImg.Extra[TiffGrayBits]:=IntToStr(GrayBits);
+        IDF.GrayBits:=GrayBits;
         for i:=0 to ExtraSampleCnt-1 do
           if ExtraSamples[i]=2 then begin
-            AlphaBits:=SampleBits[3+i];
-            CurImg.Extra[TiffAlphaBits]:=IntToStr(AlphaBits);
+            AlphaBits:=SampleBits[1+i];
+            IDF.AlphaBits:=AlphaBits;
           end;
       end;
     2:
       begin
         RedBits:=SampleBits[0];
-        GreenBits:=SampleBits[0];
-        BlueBits:=SampleBits[0];
-        CurImg.Extra[TiffRedBits]:=IntToStr(RedBits);
-        CurImg.Extra[TiffGreenBits]:=IntToStr(GreenBits);
-        CurImg.Extra[TiffBlueBits]:=IntToStr(BlueBits);
+        GreenBits:=SampleBits[1];
+        BlueBits:=SampleBits[2];
+        IDF.RedBits:=RedBits;
+        IDF.GreenBits:=GreenBits;
+        IDF.BlueBits:=BlueBits;
         for i:=0 to ExtraSampleCnt-1 do
           if ExtraSamples[i]=2 then begin
             AlphaBits:=SampleBits[3+i];
-            CurImg.Extra[TiffAlphaBits]:=IntToStr(AlphaBits);
+            IDF.AlphaBits:=AlphaBits;
+          end;
+      end;
+    5:
+      begin
+        RedBits:=SampleBits[0];
+        GreenBits:=SampleBits[1];
+        BlueBits:=SampleBits[2];
+        GrayBits:=SampleBits[3];
+        IDF.RedBits:=RedBits;
+        IDF.GreenBits:=GreenBits;
+        IDF.BlueBits:=BlueBits;
+        IDF.GrayBits:=GrayBits;
+        for i:=0 to ExtraSampleCnt-1 do
+          if ExtraSamples[i]=2 then begin
+            AlphaBits:=SampleBits[4+i];
+            IDF.AlphaBits:=AlphaBits;
           end;
       end;
     end;
     BytesPerPixel:=(GrayBits+RedBits+GreenBits+BlueBits+AlphaBits) div 8;
+    IDF.BytesPerPixel:=BytesPerPixel;
 
     if not (IDF.FillOrder in [0,1]) then
       TiffError('FillOrder unsupported: '+IntToStr(IDF.FillOrder));
@@ -997,14 +1026,58 @@ begin
         TiffError('SampleBits unsupported: '+IntToStr(SampleBits[StripIndex]));
     end;
 
+    // get image
+    FirstImg.Assign(IDF);
+    CurImg:=FirstImg.Img;
+    if Assigned(OnCreateImage) then begin
+      OnCreateImage(Self,CurImg);
+      FirstImg.Img:=CurImg;
+    end;
     if CurImg=nil then exit;
+
+    ClearTiffExtras(CurImg);
+    // set Tiff extra attributes
+    CurImg.Extra[TiffPhotoMetric]:=IntToStr(IDF.PhotoMetricInterpretation);
+    //writeln('TFPReaderTiff.ReadImage PhotoMetric=',CurImg.Extra[TiffPhotoMetric]);
+    if IDF.Artist<>'' then
+      CurImg.Extra[TiffArtist]:=IDF.Artist;
+    if IDF.Copyright<>'' then
+      CurImg.Extra[TiffCopyright]:=IDF.Copyright;
+    if IDF.DocumentName<>'' then
+      CurImg.Extra[TiffDocumentName]:=IDF.DocumentName;
+    if IDF.DateAndTime<>'' then
+      CurImg.Extra[TiffDateTime]:=IDF.DateAndTime;
+    if IDF.ImageDescription<>'' then
+      CurImg.Extra[TiffImageDescription]:=IDF.ImageDescription;
+    if not (IDF.Orientation in [1..8]) then
+      IDF.Orientation:=1;
+    CurImg.Extra[TiffOrientation]:=IntToStr(IDF.Orientation);
+    if IDF.ResolutionUnit<>0 then
+      CurImg.Extra[TiffResolutionUnit]:=IntToStr(IDF.ResolutionUnit);
+    if (IDF.XResolution.Numerator<>0) or (IDF.XResolution.Denominator<>0) then
+      CurImg.Extra[TiffXResolution]:=TiffRationalToStr(IDF.XResolution);
+    if (IDF.YResolution.Numerator<>0) or (IDF.YResolution.Denominator<>0) then
+      CurImg.Extra[TiffYResolution]:=TiffRationalToStr(IDF.YResolution);
+    CurImg.Extra[TiffRedBits]:=IntToStr(IDF.RedBits);
+    CurImg.Extra[TiffGreenBits]:=IntToStr(IDF.GreenBits);
+    CurImg.Extra[TiffBlueBits]:=IntToStr(IDF.BlueBits);
+    CurImg.Extra[TiffGrayBits]:=IntToStr(IDF.GrayBits);
+    CurImg.Extra[TiffAlphaBits]:=IntToStr(IDF.AlphaBits);
+    //WriteTiffExtras('ReadImage',CurImg);
+
     case IDF.Orientation of
     0,1..4: CurImg.SetSize(IDF.ImageWidth,IDF.ImageHeight);
     5..8: CurImg.SetSize(IDF.ImageHeight,IDF.ImageWidth);
     end;
 
+
     y:=0;
     for StripIndex:=0 to StripCount-1 do begin
+      // progress
+      aContinue:=true;
+      Progress(psRunning, 0, false, Rect(0,0,0,0), '', aContinue);
+      if not aContinue then break;
+
       CurOffset:=StripOffsets[StripIndex];
       CurByteCnt:=StripByteCounts[StripIndex];
       //writeln('TFPReaderTiff.ReadImage CurOffset=',CurOffset,' CurByteCnt=',CurByteCnt);
@@ -1017,6 +1090,7 @@ begin
       case IDF.Compression of
       1: ; // not compressed
       2: DecompressPackBits(Strip,CurByteCnt); // packbits
+      5: DecompressLZW(Strip,CurByteCnt); // LZW
       else
         TiffError('compression '+IntToStr(IDF.Compression)+' not supported yet');
       end;
@@ -1037,20 +1111,20 @@ begin
           0,1:
             begin
               if GrayBits=8 then begin
-                Pixel:=PCUInt8(Strip)[Run];
-                Pixel:=Pixel shl 8+Pixel;
+                GrayValue:=PCUInt8(Strip)[Run];
+                GrayValue:=GrayValue shl 8+GrayValue;
                 inc(Run);
               end else if GrayBits=16 then begin
-                Pixel:=FixEndian(PCUInt16(@Strip[Run])^);
+                GrayValue:=FixEndian(PCUInt16(@Strip[Run])^);
                 inc(Run,2);
               end else
                 TiffError('gray image only supported with BitsPerSample 8 or 16 not yet supported');
               if IDF.PhotoMetricInterpretation=0 then
-                Pixel:=$ffff-Pixel;
+                GrayValue:=$ffff-GrayValue;
               AlphaValue:=alphaOpaque;
               for i:=0 to ExtraSampleCnt-1 do begin
                 if ExtraSamples[i]=2 then begin
-                  if SampleBits[3+i]=8 then begin
+                  if SampleBits[1+i]=8 then begin
                     AlphaValue:=PCUInt8(Strip)[Run];
                     AlphaValue:=AlphaValue shl 8+AlphaValue;
                     inc(Run);
@@ -1062,10 +1136,10 @@ begin
                   inc(Run,ExtraSamples[i] div 8);
                 end;
               end;
-              Col:=FPColor(Pixel,Pixel,Pixel,AlphaValue);
+              Col:=FPColor(GrayValue,GrayValue,GrayValue,AlphaValue);
             end;
 
-          2:
+          2: // RGB(A)
             begin
               if RedBits=8 then begin
                 RedValue:=PCUInt8(Strip)[Run];
@@ -1108,6 +1182,64 @@ begin
               end;
               Col:=FPColor(RedValue,GreenValue,BlueValue,AlphaValue);
             end;
+
+          5: // CMYK plus optional alpha
+            begin
+              if RedBits=8 then begin
+                RedValue:=PCUInt8(Strip)[Run];
+                RedValue:=RedValue shl 8+RedValue;
+                inc(Run);
+              end else begin
+                RedValue:=FixEndian(PCUInt16(@Strip[Run])^);
+                inc(Run,2);
+              end;
+              if GreenBits=8 then begin
+                GreenValue:=PCUInt8(Strip)[Run];
+                GreenValue:=GreenValue shl 8+GreenValue;
+                inc(Run);
+              end else begin
+                GreenValue:=FixEndian(PCUInt16(@Strip[Run])^);
+                inc(Run,2);
+              end;
+              if BlueBits=8 then begin
+                BlueValue:=PCUInt8(Strip)[Run];
+                BlueValue:=BlueValue shl 8+BlueValue;
+                inc(Run);
+              end else begin
+                BlueValue:=FixEndian(PCUInt16(@Strip[Run])^);
+                inc(Run,2);
+              end;
+              if GrayBits=8 then begin
+                GrayValue:=PCUInt8(Strip)[Run];
+                GrayValue:=GrayValue shl 8+GrayValue;
+                inc(Run);
+              end else begin
+                GrayValue:=FixEndian(PCUInt16(@Strip[Run])^);
+                inc(Run,2);
+              end;
+              AlphaValue:=alphaOpaque;
+              for i:=0 to ExtraSampleCnt-1 do begin
+                if ExtraSamples[i]=2 then begin
+                  if SampleBits[4+i]=8 then begin
+                    AlphaValue:=PCUInt8(Strip)[Run];
+                    AlphaValue:=AlphaValue shl 8+AlphaValue;
+                    inc(Run);
+                  end else begin
+                    AlphaValue:=FixEndian(PCUInt16(@Strip[Run])^);
+                    inc(Run,2);
+                  end;
+                end else begin
+                  inc(Run,ExtraSamples[i] div 8);
+                end;
+              end;
+              // CMYK to RGB
+              RedValue:=Max(0,integer($ffff)-RedValue-GrayBits);
+              GreenValue:=Max(0,integer($ffff)-GreenValue-GrayBits);
+              BlueValue:=Max(0,integer($ffff)-BlueValue-GrayBits);
+              // set color
+              Col:=FPColor(RedValue,GreenValue,BlueValue,AlphaValue);
+            end;
+
           else
             TiffError('PhotometricInterpretation='+IntToStr(IDF.PhotoMetricInterpretation)+' not supported');
           end;
@@ -1222,6 +1354,220 @@ begin
   Count:=NewCount;
 end;
 
+procedure TFPReaderTiff.DecompressLZW(var Buffer: Pointer; var Count: PtrInt);
+type
+  TLZWString = packed record
+    Count: integer;
+    Data: PByte;
+  end;
+  PLZWString = ^TLZWString;
+const
+  EoiCode = 257;
+  ClearCode = 256;
+var
+  NewBuffer: PByte;
+  NewCount: PtrInt;
+  NewCapacity: PtrInt;
+  SrcPos: PtrInt;
+  SrcPosBit: integer;
+  CurBitLength: integer;
+  Code: Word;
+  Table: PLZWString;
+  TableCapacity: integer;
+  TableCount: integer;
+  OldCode: Word;
+
+  function GetNextCode: Word;
+  var
+    v: Integer;
+  begin
+    Result:=0;
+    // CurBitLength can be 9 to 12
+    writeln('GetNextCode CurBitLength=',CurBitLength,' SrcPos=',SrcPos,' SrcPosBit=',SrcPosBit,' ',hexstr(PByte(Buffer)[SrcPos],2),' ',hexstr(PByte(Buffer)[SrcPos+1],2),' ',hexstr(PByte(Buffer)[SrcPos+2],2));
+    // read two or three bytes
+    if CurBitLength+SrcPosBit>16 then begin
+      // read from three bytes
+      if SrcPos+3>Count then TiffError('LZW stream overrun');
+      v:=PByte(Buffer)[SrcPos];
+      inc(SrcPos);
+      v:=(v shl 8)+PByte(Buffer)[SrcPos];
+      inc(SrcPos);
+      v:=(v shl 8)+PByte(Buffer)[SrcPos];
+      v:=v shr (24-CurBitLength-SrcPosBit);
+    end else begin
+      // read from two bytes
+      if SrcPos+2>Count then TiffError('LZW stream overrun');
+      v:=PByte(Buffer)[SrcPos];
+      inc(SrcPos);
+      v:=(v shl 8)+PByte(Buffer)[SrcPos];
+      if CurBitLength+SrcPosBit=16 then
+        inc(SrcPos);
+      v:=v shr (16-CurBitLength-SrcPosBit);
+    end;
+    Result:=v and ((1 shl CurBitLength)-1);
+    SrcPosBit:=(SrcPosBit+CurBitLength) and 7;
+    writeln('GetNextCode END SrcPos=',SrcPos,' SrcPosBit=',SrcPosBit,' Result=',Result,' Result=',hexstr(Result,4));
+  end;
+
+  procedure ClearTable;
+  var
+    i: Integer;
+  begin
+    for i:=0 to TableCount-1 do
+      ReAllocMem(Table[i].Data,0);
+    TableCount:=0;
+  end;
+
+  procedure InitializeTable;
+  begin
+    CurBitLength:=9;
+    ClearTable;
+  end;
+
+  function IsInTable(Code: word): boolean;
+  begin
+    Result:=Code<258+TableCount;
+  end;
+
+  procedure WriteStringFromCode(Code: integer; AddFirstChar: boolean = false);
+  var
+    s: TLZWString;
+    b: byte;
+    i: Integer;
+  begin
+    WriteLn('WriteStringFromCode Code=',Code,' AddFirstChar=',AddFirstChar);
+    if Code<256 then begin
+      // write byte
+      b:=Code;
+      s.Data:=@b;
+      s.Count:=1;
+    end else begin
+      // write string
+      if Code-258>=TableCount then
+        TiffError('LZW code out of bounds');
+      s:=Table[Code-258];
+    end;
+    if NewCount+s.Count+1>NewCapacity then begin
+      NewCapacity:=NewCapacity*2+8;
+      ReAllocMem(NewBuffer,NewCapacity);
+    end;
+    System.Move(s.Data^,NewBuffer[NewCount],s.Count);
+    for i:=0 to s.Count-1 do
+      write(HexStr(NewBuffer[NewCount+i],2));
+    inc(NewCount,s.Count);
+    if AddFirstChar then begin
+      NewBuffer[NewCount]:=s.Data^;
+      write(HexStr(NewBuffer[NewCount],2));
+      inc(NewCount);
+    end;
+    writeln(',WriteStringFromCode');
+  end;
+
+  procedure AddStringToTable(Code, AddFirstCharFromCode: integer);
+  // add string from code plus first character of string from code as new string
+  var
+    b: byte;
+    s1, s2: TLZWString;
+    p: PByte;
+  begin
+    WriteLn('AddStringToTable Code=',Code,' FCFCode=',AddFirstCharFromCode,' TableCount=',TableCount,' TableCapacity=',TableCapacity);
+    // grow table
+    if TableCount>=TableCapacity then begin
+      TableCapacity:=TableCapacity*2+128;
+      ReAllocMem(Table,TableCapacity*SizeOf(TLZWString));
+    end;
+    // find string 1
+    if Code<256 then begin
+      // string is byte
+      b:=Code;
+      s1.Data:=@b;
+      s1.Count:=1;
+    end else begin
+      // normal string
+      if Code-258>=TableCount then
+        TiffError('LZW code out of bounds');
+      s1:=Table[Code-258];
+    end;
+    // find string 2
+    if AddFirstCharFromCode<256 then begin
+      // string is byte
+      b:=AddFirstCharFromCode;
+      s2.Data:=@b;
+      s2.Count:=1;
+    end else begin
+      // normal string
+      if AddFirstCharFromCode-258>=TableCount then
+        TiffError('LZW code out of bounds');
+      s2:=Table[AddFirstCharFromCode-258];
+    end;
+    // set new table entry
+    Table[TableCount].Count:=s1.Count+1;
+    p:=nil;
+    GetMem(p,s1.Count+1);
+    Table[TableCount].Data:=p;
+    System.Move(s1.Data^,p^,s1.Count);
+    // add first character from string 2
+    p[s1.Count]:=s2.Data^;
+    // increase TableCount
+    inc(TableCount);
+    case TableCount+259 of
+    512,1024,2048: inc(CurBitLength);
+    4096: TiffError('LZW too many codes');
+    end;
+  end;
+
+begin
+  WriteLn('TFPReaderTiff.DecompressLZW START Count=',Count);
+  for SrcPos:=0 to 19 do
+    write(HexStr(PByte(Buffer)[SrcPos],2));
+  writeln();
+
+  NewBuffer:=nil;
+  NewCount:=0;
+  NewCapacity:=Count*2;
+  ReAllocMem(NewBuffer,NewCapacity);
+
+  SrcPos:=0;
+  SrcPosBit:=0;
+  CurBitLength:=9;
+  Table:=nil;
+  TableCount:=0;
+  TableCapacity:=0;
+  try
+    repeat
+      Code:=GetNextCode;
+      WriteLn('TFPReaderTiff.DecompressLZW Code=',Code);
+      if Code=EoiCode then break;
+      if Code=ClearCode then begin
+        InitializeTable;
+        Code:=GetNextCode;
+        if Code=EoiCode then break;
+        WriteStringFromCode(Code);
+        OldCode:=Code;
+      end else begin
+        if Code<TableCount+258 then begin
+          WriteStringFromCode(Code);
+          AddStringToTable(OldCode,Code);
+          OldCode:=Code;
+        end else if Code=TableCount+258 then begin
+          WriteStringFromCode(OldCode,true);
+          AddStringToTable(OldCode,OldCode);
+          OldCode:=Code;
+        end else
+          TiffError('LZW code out of bounds');
+      end;
+    until false;
+  finally
+    ClearTable;
+    ReAllocMem(Table,0);
+  end;
+
+  ReAllocMem(NewBuffer,NewCount);
+  FreeMem(Buffer);
+  Buffer:=NewBuffer;
+  Count:=NewCount;
+end;
+
 procedure TFPReaderTiff.InternalRead(Str: TStream; AnImage: TFPCustomImage);
 begin
   FirstImg.Img:=AnImage;

packages/fcl-image/src/fptiffcmn.pas

@@ -29,14 +29,15 @@ type
 
 const
   TiffRational0: TTiffRational = (Numerator: 0; Denominator: 0);
+  TiffRational72: TTiffRational = (Numerator: 72; Denominator: 1);
 
   // TFPCustomImage.Extra properties used by TFPReaderTiff and TFPWriterTiff
   TiffExtraPrefix = 'Tiff';
   TiffPhotoMetric = TiffExtraPrefix+'PhotoMetricInterpretation';
-  TiffGrayBits = TiffExtraPrefix+'GrayBits';
-  TiffRedBits = TiffExtraPrefix+'RedBits';
-  TiffGreenBits = TiffExtraPrefix+'GreenBits';
-  TiffBlueBits = TiffExtraPrefix+'BlueBits';
+  TiffGrayBits = TiffExtraPrefix+'GrayBits'; // CMYK: key plate
+  TiffRedBits = TiffExtraPrefix+'RedBits'; // CMYK: cyan
+  TiffGreenBits = TiffExtraPrefix+'GreenBits'; // CMYK: magenta
+  TiffBlueBits = TiffExtraPrefix+'BlueBits'; // CMYK: yellow
   TiffAlphaBits = TiffExtraPrefix+'AlphaBits';
   TiffArtist = TiffExtraPrefix+'Artist';
   TiffCopyright = TiffExtraPrefix+'Copyright';
@@ -87,7 +88,14 @@ type
     Treshholding: DWord;
     XResolution: TTiffRational;
     YResolution: TTiffRational;
+    // image
     Img: TFPCustomImage;
+    RedBits: word;
+    GreenBits: word;
+    BlueBits: word;
+    GrayBits: word;
+    AlphaBits: word;
+    BytesPerPixel: Word;
     procedure Clear;
     procedure Assign(IDF: TTiffIDF);
   end;
@@ -180,6 +188,13 @@ begin
   FillOrder:=0;
   Orientation:=0;
   Treshholding:=0;
+
+  RedBits:=0;
+  GreenBits:=0;
+  BlueBits:=0;
+  GrayBits:=0;
+  AlphaBits:=0;
+  BytesPerPixel:=0;
 end;
 
 procedure TTiffIDF.Assign(IDF: TTiffIDF);
@@ -214,6 +229,11 @@ begin
   FillOrder:=IDF.FillOrder;
   Orientation:=IDF.Orientation;
   Treshholding:=IDF.Treshholding;
+  RedBits:=IDF.RedBits;
+  GreenBits:=IDF.GreenBits;
+  BlueBits:=IDF.BlueBits;
+  GrayBits:=IDF.GrayBits;
+  AlphaBits:=IDF.AlphaBits;
   if (Img<>nil) and (IDF.Img<>nil) then
     Img.Assign(IDF.Img);
 end;

packages/fcl-image/src/fpwritetiff.pas

@@ -19,7 +19,7 @@
     Orientation,
 
   ToDo:
-    Compression: packbits, deflate, jpeg, ...
+    Compression: LZW, packbits, deflate, jpeg, ...
     thumbnail
     Planar
     ColorMap
@@ -39,7 +39,7 @@ unit FPWriteTiff;
 interface
 
 uses
-  Math, Classes, SysUtils, FPimage, FPTiffCmn, FPWriteTGA;
+  Math, Classes, SysUtils, FPimage, QVFPTiffCmn;
 
 type
 
@@ -77,6 +77,7 @@ type
 
   TFPWriterTiff = class(TFPCustomImageWriter)
   private
+    FSaveCMYKAsRGB: boolean;
     fStartPos: Int64;
     FEntries: TFPList; // list of TFPList of TTiffWriteEntry
     fStream: TStream;
@@ -108,6 +109,7 @@ type
     procedure Clear;
     procedure AddImage(Img: TFPCustomImage);
     procedure SaveToStream(Stream: TStream);
+    property SaveCMYKAsRGB: boolean read FSaveCMYKAsRGB write FSaveCMYKAsRGB;
   end;
 
 function CompareTiffWriteEntries(Entry1, Entry2: Pointer): integer;
@@ -315,9 +317,15 @@ begin
     CurEntries:=TFPList.Create;
     FEntries.Add(CurEntries);
 
-    IDF.PhotoMetricInterpretation:=StrToInt64Def(Img.Extra[TiffPhotoMetric],High(IDF.PhotoMetricInterpretation));
+    if Img.Extra[TiffPhotoMetric]='' then
+      IDF.PhotoMetricInterpretation:=2
+    else begin
+      IDF.PhotoMetricInterpretation:=StrToInt64Def(Img.Extra[TiffPhotoMetric],High(IDF.PhotoMetricInterpretation));
+      if SaveCMYKAsRGB and (IDF.PhotoMetricInterpretation=5) then
+        IDF.PhotoMetricInterpretation:=2;
+    end;
     if not (IDF.PhotoMetricInterpretation in [0,1,2]) then
-      TiffError('PhotoMetricInterpretation='+IntToStr(IDF.PhotometricInterpretation)+' not supported');
+      TiffError('PhotoMetricInterpretation="'+Img.Extra[TiffPhotoMetric]+'" not supported');
     IDF.Artist:=Img.Extra[TiffArtist];
     IDF.Copyright:=Img.Extra[TiffCopyright];
     IDF.DocumentName:=Img.Extra[TiffDocumentName];
@@ -329,14 +337,14 @@ begin
     IDF.ResolutionUnit:=StrToIntDef(Img.Extra[TiffResolutionUnit],2);
     if not (IDF.ResolutionUnit in [1..3]) then
       IDF.ResolutionUnit:=2;
-    IDF.XResolution:=StrToTiffRationalDef(Img.Extra[TiffXResolution],TiffRational0);
-    IDF.YResolution:=StrToTiffRationalDef(Img.Extra[TiffYResolution],TiffRational0);
-
-    GrayBits:=StrToIntDef(Img.Extra[TiffGrayBits],0);
-    RedBits:=StrToIntDef(Img.Extra[TiffRedBits],0);
-    GreenBits:=StrToIntDef(Img.Extra[TiffGreenBits],0);
-    BlueBits:=StrToIntDef(Img.Extra[TiffBlueBits],0);
-    AlphaBits:=StrToIntDef(Img.Extra[TiffAlphaBits],0);
+    IDF.XResolution:=StrToTiffRationalDef(Img.Extra[TiffXResolution],TiffRational72);
+    IDF.YResolution:=StrToTiffRationalDef(Img.Extra[TiffYResolution],TiffRational72);
+
+    GrayBits:=StrToIntDef(Img.Extra[TiffGrayBits],8);
+    RedBits:=StrToIntDef(Img.Extra[TiffRedBits],8);
+    GreenBits:=StrToIntDef(Img.Extra[TiffGreenBits],8);
+    BlueBits:=StrToIntDef(Img.Extra[TiffBlueBits],8);
+    AlphaBits:=StrToIntDef(Img.Extra[TiffAlphaBits],8);
     ImgWidth:=Img.Width;
     ImgHeight:=Img.Height;
     Compression:=1;
@@ -612,6 +620,7 @@ constructor TFPWriterTiff.Create;
 begin
   inherited Create;
   FEntries:=TFPList.Create;
+  FSaveCMYKAsRGB:=true;
 end;
 
 destructor TFPWriterTiff.Destroy;