* Added TIFF reader/Writer from Mattias gaertner

git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@11990 3ad0048d-3df7-0310-abae-a5850022a9f2

3 files changed, 2175 insertions, 0 deletions

diff --git a/packages/fcl-image/src/fpreadtiff.pas b/packages/fcl-image/src/fpreadtiff.pas
new file mode 100644
index 0000000000..4e90cdc5f1
--- /dev/null
+++ b/packages/fcl-image/src/fpreadtiff.pas
@@ -0,0 +1,1272 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2008 by the Free Pascal development team
+
+    Tiff reader for fpImage.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************
+
+  Working:
+    Grayscale 8,16bit (optional alpha),
+    RGB 8,16bit (optional alpha),
+    Orientation,
+    skipping Thumbnail to read first image,
+    compression: packbits,
+    endian
+
+  ToDo:
+    Compression: deflate, jpeg, ...
+    Planar
+    ColorMap
+    multiple images
+    separate mask
+    pages
+    fillorder - not needed by baseline tiff reader
+    bigtiff 64bit offsets
+}
+unit FPReadTiff;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FPimage, ctypes, FPTiffCmn;
+
+type
+
+  { TFPReaderTiff }
+
+  TFPReaderTiff = class(TFPCustomImageReader)
+  private
+    FReverserEndian: boolean;
+    IDF: TTiffIDF;
+    FDebug: boolean;
+    fIFDStarts: TFPList;
+    FReverseEndian: Boolean;
+    fStartPos: int64;
+    s: TStream;
+    procedure TiffError(Msg: string);
+    procedure SetStreamPos(p: DWord);
+    function ReadTiffHeader(QuickTest: boolean; out IFD: DWord): boolean; // returns IFD: offset to first IFD
+    function ReadIFD(Start: dword): DWord;// Image File Directory
+    procedure ReadDirectoryEntry(var EntryTag: Word);
+    function ReadEntryUnsigned: DWord;
+    function ReadEntrySigned: Cint32;
+    function ReadEntryRational: TTiffRational;
+    function ReadEntryString: string;
+    function ReadByte: Byte;
+    function ReadWord: Word;
+    function ReadDWord: DWord;
+    procedure ReadValues(StreamPos: DWord;
+                         out EntryType: word; out EntryCount: DWord;
+                         out Buffer: Pointer; out ByteCount: PtrUInt);
+    procedure ReadShortOrLongValues(StreamPos: DWord;
+                                    out Buffer: PDWord; out Count: DWord);
+    procedure ReadShortValues(StreamPos: DWord;
+                              out Buffer: PWord; out Count: DWord);
+    procedure ReadImage(Index: integer);
+    function FixEndian(w: Word): Word; inline;
+    function FixEndian(d: DWord): DWord; inline;
+    procedure DecompressPackBits(var Buffer: Pointer; var Count: PtrInt);
+  protected
+    procedure InternalRead(Str: TStream; AnImage: TFPCustomImage); override;
+    function InternalCheck(Str: TStream): boolean; override;
+  public
+    FirstImg: TTiffIDF;
+    constructor Create; override;
+    destructor Destroy; override;
+    procedure Clear;
+    procedure LoadFromStream(aStream: TStream);
+    property Debug: boolean read FDebug write FDebug;
+    property StartPos: int64 read fStartPos;
+    property ReverserEndian: boolean read FReverserEndian;
+    property TheStream: TStream read s;
+  end;
+
+implementation
+
+procedure TFPReaderTiff.TiffError(Msg: string);
+begin
+  Msg:=Msg+' at position '+IntToStr(s.Position);
+  if fStartPos>0 then
+    Msg:=Msg+'(TiffPosition='+IntToStr(fStartPos)+')';
+  raise Exception.Create(Msg);
+end;
+
+procedure TFPReaderTiff.SetStreamPos(p: DWord);
+var
+  NewPosition: int64;
+begin
+  NewPosition:=Int64(p)+fStartPos;
+  if NewPosition>s.Size then
+    TiffError('Offset outside of stream');
+  s.Position:=NewPosition;
+end;
+
+procedure TFPReaderTiff.LoadFromStream(aStream: TStream);
+var
+  IFDStart: LongWord;
+  i: Integer;
+begin
+  Clear;
+  s:=aStream;
+  fStartPos:=s.Position;
+  ReadTiffHeader(false,IFDStart);
+  i:=0;
+  while IFDStart>0 do begin
+    IFDStart:=ReadIFD(IFDStart);
+    ReadImage(i);
+    inc(i);
+  end;
+end;
+
+function TFPReaderTiff.ReadTiffHeader(QuickTest: boolean; out IFD: DWord): boolean;
+var
+  ByteOrder: String;
+  BigEndian: Boolean;
+  FortyTwo: Word;
+begin
+  Result:=false;
+  // read byte order  II low endian, MM big endian
+  ByteOrder:='  ';
+  s.Read(ByteOrder[1],2);
+  //debugln(['TForm1.ReadTiffHeader ',dbgstr(ByteOrder)]);
+  if ByteOrder='II' then
+    BigEndian:=false
+  else if ByteOrder='MM' then
+    BigEndian:=true
+  else if QuickTest then
+    exit
+  else
+    TiffError('expected II or MM');
+  FReverseEndian:={$IFDEF FPC_BIG_ENDIAN}not{$ENDIF} BigEndian;
+  if Debug then
+    writeln('TFPReaderTiff.ReadTiffHeader Endian Big=',BigEndian,' ReverseEndian=',FReverseEndian);
+  // read magic number 42
+  FortyTwo:=ReadWord;
+  if FortyTwo<>42 then begin
+    if QuickTest then
+      exit
+    else
+      TiffError('expected 42, because of its deep philosophical impact, but found '+IntToStr(FortyTwo));
+  end;
+  // read offset to first IDF
+  IFD:=ReadDWord;
+  //debugln(['TForm1.ReadTiffHeader IFD=',IFD]);
+  Result:=true;
+end;
+
+function TFPReaderTiff.ReadIFD(Start: dword): DWord;
+var
+  Count: Word;
+  i: Integer;
+  EntryTag: Word;
+  p: Int64;
+begin
+  Result:=0;
+  SetStreamPos(Start);
+  Count:=ReadWord;
+  EntryTag:=0;
+  p:=s.Position;
+  for i:=1 to Count do begin
+    ReadDirectoryEntry(EntryTag);
+    inc(p,12);
+    s.Position:=p;
+  end;
+  // read start of next IFD
+  Result:=ReadDWord;
+  if (Result<>0) and (Result<Start) then begin
+    // backward jump: check for loops
+    if fIFDStarts=nil then
+      fIFDStarts:=TFPList.Create
+    else if fIFDStarts.IndexOf(Pointer(PtrUInt(Result)))>0 then
+      TiffError('endless loop in Image File Descriptors');
+    fIFDStarts.Add(Pointer(PtrUInt(Result)));
+  end;
+end;
+
+procedure TFPReaderTiff.ReadDirectoryEntry(var EntryTag: Word);
+var
+  EntryType: Word;
+  EntryCount: LongWord;
+  EntryStart: LongWord;
+  NewEntryTag: Word;
+  UValue: LongWord;
+  WordBuffer: PWord;
+  Count: DWord;
+  i: Integer;
+begin
+  NewEntryTag:=ReadWord;
+  if NewEntryTag<EntryTag then
+    TiffError('Tags must be in ascending order');
+  EntryTag:=NewEntryTag;
+  case EntryTag of
+  254:
+    begin
+      // NewSubFileType
+      UValue:=ReadEntryUnsigned;
+      IDF.ImageIsThumbNail:=UValue and 1<>0;
+      IDF.ImageIsPage:=UValue and 2<>0;
+      IDF.ImageIsMask:=UValue and 4<>0;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry NewSubFileType ThumbNail=',IDF.ImageIsThumbNail,' Page=',IDF.ImageIsPage,' Mask=',IDF.ImageIsMask);
+    end;
+  255:
+    begin
+      // SubFileType (deprecated)
+      UValue:=ReadEntryUnsigned;
+      IDF.ImageIsThumbNail:=false;
+      IDF.ImageIsPage:=false;
+      IDF.ImageIsMask:=false;
+      case UValue of
+      1: ;
+      2: IDF.ImageIsThumbNail:=true;
+      3: IDF.ImageIsPage:=true;
+      else
+        TiffError('SubFileType expected, but found '+IntToStr(UValue));
+      end;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry SubFileType ThumbNail=',IDF.ImageIsThumbNail,' Page=',IDF.ImageIsPage,' Mask=',IDF.ImageIsMask);
+    end;
+  256:
+    begin
+      // fImageWidth
+      IDF.ImageWidth:=ReadEntryUnsigned;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry ImageWidth=',IDF.ImageWidth);
+    end;
+  257:
+    begin
+      // ImageLength
+      IDF.ImageHeight:=ReadEntryUnsigned;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry ImageHeight=',IDF.ImageHeight);
+    end;
+  258:
+    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;
+        ReAllocMem(WordBuffer,0);
+      end;
+    end;
+  259:
+    begin
+      // fCompression
+      UValue:=ReadEntryUnsigned;
+      case UValue of
+      1: ; { No fCompression, but pack data into bytes as tightly as possible,
+           leaving no unused bits (except at the end of a row). The component
+           values are stored as an array of type BYTE. Each scan line (row)
+           is padded to the next BYTE boundary. }
+      2: ; { CCITT Group 3 1-Dimensional Modified Huffman run length encoding. }
+      5: ; { LZW }
+      7: ; { JPEG }
+      32946: ; { Deflate }
+      32773: ; { PackBits fCompression, a simple byte-oriented run length scheme.
+               See the PackBits section for details. Data fCompression applies
+               only to raster image data. All other TIFF fields are unaffected. }
+      else
+        TiffError('expected Compression, but found '+IntToStr(UValue));
+      end;
+      IDF.Compression:=UValue;
+      if Debug then begin
+        write('TFPReaderTiff.ReadDirectoryEntry Compression=',IntToStr(IDF.Compression),'=');
+        case IDF.Compression of
+        1: write('no compression');
+        2: write('CCITT Group 3 1-Dimensional Modified Huffman run length encoding');
+        5: write('LZW');
+        7: write('JPEG');
+        32946: write('Deflate');
+        32773: write('PackBits');
+        end;
+        writeln;
+      end;
+    end;
+  262:
+    begin
+      // PhotometricInterpretation
+      UValue:=ReadEntryUnsigned;
+      case UValue of
+      0: ; // bilevel grayscale 0 is white
+      1: ; // bilevel grayscale 0 is black
+      2: ; // RGB 0,0,0 is black
+      3: ; // Palette color
+      4: ; // Transparency Mask
+      else
+        TiffError('expected PhotometricInterpretation, but found '+IntToStr(UValue));
+      end;
+      IDF.PhotoMetricInterpretation:=UValue;
+      if Debug then begin
+        write('TFPReaderTiff.ReadDirectoryEntry PhotometricInterpretation=');
+        case IDF.PhotoMetricInterpretation of
+        0: write('0=bilevel grayscale 0 is white');
+        1: write('1=bilevel grayscale 0 is black');
+        2: write('2=RGB 0,0,0 is black');
+        3: write('3=Palette color');
+        4: write('4=Transparency Mask');
+        end;
+        writeln;
+      end;
+    end;
+  263:
+    begin
+      // Treshholding
+      UValue:=ReadEntryUnsigned;
+      case UValue of
+      1: ; // no dithering or halftoning was applied
+      2: ; // an ordered dithering or halftoning was applied
+      3: ; // a randomized dithering or halftoning was applied
+      else
+        TiffError('expected Treshholding, but found '+IntToStr(UValue));
+      end;
+      IDF.Treshholding:=UValue;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry Treshholding=',IDF.Treshholding);
+    end;
+  264:
+    begin
+      // CellWidth
+      IDF.CellWidth:=ReadEntryUnsigned;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry CellWidth=',IDF.CellWidth);
+    end;
+  265:
+    begin
+      // CellLength
+      IDF.CellLength:=ReadEntryUnsigned;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry CellLength=',IDF.CellLength);
+    end;
+  266:
+    begin
+      // FillOrder
+      UValue:=ReadEntryUnsigned;
+      case UValue of
+      1: IDF.FillOrder:=1; // left to right = high to low
+      2: IDF.FillOrder:=2; // left to right = low to high
+      else
+        TiffError('expected FillOrder, but found '+IntToStr(UValue));
+      end;
+      if Debug then begin
+        write('TFPReaderTiff.ReadDirectoryEntry FillOrder=',IntToStr(IDF.FillOrder),'=');
+        case IDF.FillOrder of
+        1: write('left to right = high to low');
+        2: write('left to right = low to high');
+        end;
+        writeln;
+      end;
+    end;
+  269:
+    begin
+      // DocumentName
+      IDF.DocumentName:=ReadEntryString;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry DocumentName=',IDF.DocumentName);
+    end;
+  270:
+    begin
+      // ImageDescription
+      IDF.ImageDescription:=ReadEntryString;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry ImageDescription=',IDF.ImageDescription);
+    end;
+  271:
+    begin
+      // Make - scanner manufacturer
+      IDF.Make_ScannerManufacturer:=ReadEntryString;
+      writeln('TFPReaderTiff.ReadDirectoryEntry Make_ScannerManufacturer=',IDF.Make_ScannerManufacturer);
+    end;
+  272:
+    begin
+      // Model - scanner model
+      IDF.Model_Scanner:=ReadEntryString;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry Model_Scanner=',IDF.Model_Scanner);
+    end;
+  273:
+    begin
+      // StripOffsets
+      IDF.StripOffsets:=DWord(s.Position-fStartPos-2);
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry StripOffsets=',IDF.StripOffsets);
+    end;
+  274:
+    begin
+      // Orientation
+      UValue:=ReadEntryUnsigned;
+      case UValue of
+      1: ;// 0,0 is left, top
+      2: ;// 0,0 is right, top
+      3: ;// 0,0 is right, bottom
+      4: ;// 0,0 is left, bottom
+      5: ;// 0,0 is top, left (rotated)
+      6: ;// 0,0 is top, right (rotated)
+      7: ;// 0,0 is bottom, right (rotated)
+      8: ;// 0,0 is bottom, left (rotated)
+      else
+        TiffError('expected Orientation, but found '+IntToStr(UValue));
+      end;
+      IDF.Orientation:=UValue;
+      if Debug then begin
+        write('TFPReaderTiff.ReadDirectoryEntry Orientation=',IntToStr(IDF.Orientation),'=');
+        case IDF.Orientation of
+        1: write('0,0 is left, top');
+        2: write('0,0 is right, top');
+        3: write('0,0 is right, bottom');
+        4: write('0,0 is left, bottom');
+        5: write('0,0 is top, left (rotated)');
+        6: write('0,0 is top, right (rotated)');
+        7: write('0,0 is bottom, right (rotated)');
+        8: write('0,0 is bottom, left (rotated)');
+        end;
+        writeln;
+      end;
+    end;
+  277:
+    begin
+      // SamplesPerPixel
+      IDF.SamplesPerPixel:=ReadEntryUnsigned;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry SamplesPerPixel=',IDF.SamplesPerPixel);
+    end;
+  278:
+    begin
+      // RowsPerStrip
+      UValue:=ReadEntryUnsigned;
+      if UValue=0 then
+        TiffError('expected RowsPerStrip, but found '+IntToStr(UValue));
+      IDF.RowsPerStrip:=UValue;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry RowsPerStrip=',IDF.RowsPerStrip);
+    end;
+  279:
+    begin
+      // StripByteCounts
+      IDF.StripByteCounts:=DWord(s.Position-fStartPos-2);
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry StripByteCounts=',IDF.StripByteCounts);
+    end;
+  280:
+    begin
+      // MinSampleValue
+    end;
+  281:
+    begin
+      // MaxSampleValue
+    end;
+  282:
+    begin
+      // XResolution
+      IDF.XResolution:=ReadEntryRational;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry XResolution=',IDF.XResolution.Numerator,',',IDF.XResolution.Denominator);
+    end;
+  283:
+    begin
+      // YResolution
+      IDF.YResolution:=ReadEntryRational;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry YResolution=',IDF.YResolution.Numerator,',',IDF.YResolution.Denominator);
+    end;
+  284:
+    begin
+      // PlanarConfiguration
+      UValue:=ReadEntryUnsigned;
+      case UValue of
+      1: ; // chunky format
+      2: ; // planar format
+      else
+        TiffError('expected PlanarConfiguration, but found '+IntToStr(UValue));
+      end;
+      IDF.PlanarConfiguration:=UValue;
+      if Debug then begin
+        write('TFPReaderTiff.ReadDirectoryEntry PlanarConfiguration=');
+        case UValue of
+        1: write('chunky format');
+        2: write('planar format');
+        end;
+        writeln;
+      end;
+    end;
+  288:
+    begin
+      // FreeOffsets
+      // The free bytes in a tiff file are described with FreeByteCount and FreeOffsets
+    end;
+  289:
+    begin
+      // FreeByteCount
+      // The free bytes in a tiff file are described with FreeByteCount and FreeOffsets
+    end;
+  290:
+    begin
+      // GrayResponseUnit
+      // precision of GrayResponseCurve
+    end;
+  291:
+    begin
+      // GrayResponseCurve
+      // the optical density for each possible pixel value
+    end;
+  296:
+    begin
+      // fResolutionUnit
+      UValue:=ReadEntryUnsigned;
+      case UValue of
+      1: IDF.ResolutionUnit:=1; // none
+      2: IDF.ResolutionUnit:=2; // inch
+      3: IDF.ResolutionUnit:=3; // centimeter
+      else
+        TiffError('expected ResolutionUnit, but found '+IntToStr(UValue));
+      end;
+      if Debug then begin
+        write('TFPReaderTiff.ReadDirectoryEntry ResolutionUnit=');
+        case IDF.ResolutionUnit of
+        1: write('none');
+        2: write('inch');
+        3: write('centimeter');
+        end;
+        writeln;
+      end;
+    end;
+  305:
+    begin
+      // Software
+      IDF.Software:=ReadEntryString;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry Software="',IDF.Software,'"');
+    end;
+  306:
+    begin
+      // DateAndTime
+      IDF.DateAndTime:=ReadEntryString;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry DateAndTime="',IDF.DateAndTime,'"');
+    end;
+  315:
+    begin
+      // Artist
+      IDF.Artist:=ReadEntryString;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry Artist="',IDF.Artist,'"');
+    end;
+  316:
+    begin
+      // HostComputer
+      IDF.HostComputer:=ReadEntryString;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry HostComputer="',IDF.HostComputer,'"');
+    end;
+  320:
+    begin
+      // ColorMap: N = 3*2^BitsPerSample
+      IDF.ColorMap:=DWord(s.Position-fStartPos-2);
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry ColorMap');
+    end;
+  338:
+    begin
+      // ExtraSamples: if SamplesPerPixel is bigger than PhotometricInterpretation
+      // then ExtraSamples is an array defining the extra samples
+      // 0=unspecified
+      // 1=alpha (premultiplied)
+      // 2=alpha (unassociated)
+      IDF.ExtraSamples:=DWord(s.Position-fStartPos-2);
+      if Debug then begin
+        ReadShortValues(IDF.ExtraSamples,WordBuffer,Count);
+        write('TFPReaderTiff.ReadDirectoryEntry ExtraSamples: ');
+        for i:=0 to Count-1 do
+          write(IntToStr(WordBuffer[i]),' ');
+        writeln;
+        ReAllocMem(WordBuffer,0);
+      end;
+    end;
+  33432:
+    begin
+      // Copyright
+      IDF.Copyright:=ReadEntryString;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry Copyright="',IDF.Copyright,'"');
+    end;
+  else
+    begin
+      EntryType:=ReadWord;
+      EntryCount:=ReadDWord;
+      EntryStart:=ReadDWord;
+      if Debug then
+        writeln('TFPReaderTiff.ReadDirectoryEntry Tag=',EntryTag,' Type=',EntryType,' Count=',EntryCount,' ValuesStart=',EntryStart);
+    end;
+  end;
+end;
+
+function TFPReaderTiff.ReadEntryUnsigned: DWord;
+var
+  EntryCount: LongWord;
+  EntryType: Word;
+begin
+  Result:=0;
+  EntryType:=ReadWord;
+  EntryCount:=ReadDWord;
+  if EntryCount<>1 then
+    TiffError('EntryCount=1 expected, but found '+IntToStr(EntryCount));
+  //writeln('TFPReaderTiff.ReadEntryUnsigned Tag=',EntryTag,' Type=',EntryType,' Count=',EntryCount,' ValuesStart=',EntryStart]);
+  case EntryType of
+  1: begin
+      // byte: 8bit unsigned
+      Result:=ReadByte;
+    end;
+  3: begin
+      // short: 16bit unsigned
+      Result:=ReadWord;
+    end;
+  4: begin
+      // long: 32bit unsigned long
+      Result:=ReadDWord;
+    end;
+  else
+    TiffError('expected single unsigned value, but found type='+IntToStr(EntryType));
+  end;
+end;
+
+function TFPReaderTiff.ReadEntrySigned: Cint32;
+var
+  EntryCount: LongWord;
+  EntryType: Word;
+begin
+  Result:=0;
+  EntryType:=ReadWord;
+  EntryCount:=ReadDWord;
+  if EntryCount<>1 then
+    TiffError('EntryCount+1 expected, but found '+IntToStr(EntryCount));
+  //writeln('TFPReaderTiff.ReadEntrySigned Tag=',EntryTag,' Type=',EntryType,' Count=',EntryCount,' ValuesStart=',EntryStart]);
+  case EntryType of
+  1: begin
+      // byte: 8bit unsigned
+      Result:=cint8(ReadByte);
+    end;
+  3: begin
+      // short: 16bit unsigned
+      Result:=cint16(ReadWord);
+    end;
+  4: begin
+      // long: 32bit unsigned long
+      Result:=cint32(ReadDWord);
+    end;
+  else
+    TiffError('expected single signed value, but found type='+IntToStr(EntryType));
+  end;
+end;
+
+function TFPReaderTiff.ReadEntryRational: TTiffRational;
+var
+  EntryCount: LongWord;
+  EntryStart: LongWord;
+  EntryType: Word;
+begin
+  Result:=TiffRational0;
+  EntryType:=ReadWord;
+  EntryCount:=ReadDWord;
+  if EntryCount<>1 then
+    TiffError('EntryCount+1 expected, but found '+IntToStr(EntryCount));
+  //writeln('TFPReaderTiff.ReadEntryUnsigned Tag=',EntryTag,' Type=',EntryType,' Count=',EntryCount,' ValuesStart=',EntryStart]);
+  case EntryType of
+  1: begin
+      // byte: 8bit unsigned
+      Result.Numerator:=ReadByte;
+    end;
+  3: begin
+      // short: 16bit unsigned
+      Result.Numerator:=ReadWord;
+    end;
+  4: begin
+      // long: 32bit unsigned long
+      Result.Numerator:=ReadDWord;
+    end;
+  5: begin
+      // rational: Two longs: numerator + denominator
+      // this does not fit into 4 bytes
+      EntryStart:=ReadDWord;
+      SetStreamPos(EntryStart);
+      Result.Numerator:=ReadDWord;
+      Result.Denominator:=ReadDWord;
+    end;
+  else
+    TiffError('expected rational unsigned value, but found type='+IntToStr(EntryType));
+  end;
+end;
+
+function TFPReaderTiff.ReadEntryString: string;
+var
+  EntryType: Word;
+  EntryCount: LongWord;
+  EntryStart: LongWord;
+begin
+  Result:='';
+  EntryType:=ReadWord;
+  if EntryType<>2 then
+    TiffError('asciiz expected, but found '+IntToStr(EntryType));
+  EntryCount:=ReadDWord;
+  EntryStart:=ReadDWord;
+  SetStreamPos(EntryStart);
+  SetLength(Result,EntryCount-1);
+  if EntryCount>1 then
+    s.Read(Result[1],EntryCount-1);
+end;
+
+function TFPReaderTiff.ReadByte: Byte;
+begin
+  Result:=s.ReadByte;
+end;
+
+function TFPReaderTiff.ReadWord: Word;
+begin
+  Result:=FixEndian(s.ReadWord);
+end;
+
+function TFPReaderTiff.ReadDWord: DWord;
+begin
+  Result:=FixEndian(s.ReadDWord);
+end;
+
+procedure TFPReaderTiff.ReadValues(StreamPos: DWord;
+  out EntryType: word; out EntryCount: DWord;
+  out Buffer: Pointer; out ByteCount: PtrUint);
+var
+  EntryStart: DWord;
+begin
+  Buffer:=nil;
+  ByteCount:=0;
+  EntryType:=0;
+  EntryCount:=0;
+  SetStreamPos(StreamPos);
+  ReadWord; // skip tag
+  EntryType:=ReadWord;
+  EntryCount:=ReadDWord;
+  if EntryCount=0 then exit;
+  case EntryType of
+  1,6,7: ByteCount:=EntryCount; // byte
+  2: ByteCount:=EntryCount; // asciiz
+  3,8: ByteCount:=2*EntryCount; // short
+  4,9: ByteCount:=4*EntryCount; // long
+  5,10: ByteCount:=8*EntryCount; // rational
+  11: ByteCount:=4*EntryCount; // single
+  12: ByteCount:=8*EntryCount; // double
+  else
+    TiffError('invalid EntryType '+IntToStr(EntryType));
+  end;
+  if ByteCount>4 then begin
+    EntryStart:=ReadDWord;
+    SetStreamPos(EntryStart);
+  end;
+  GetMem(Buffer,ByteCount);
+  s.Read(Buffer^,ByteCount);
+end;
+
+procedure TFPReaderTiff.ReadShortOrLongValues(StreamPos: DWord; out
+  Buffer: PDWord; out Count: DWord);
+var
+  p: Pointer;
+  ByteCount: PtrUInt;
+  EntryType: word;
+  i: DWord;
+begin
+  Buffer:=nil;
+  Count:=0;
+  p:=nil;
+  try
+    ReadValues(StreamPos,EntryType,Count,p,ByteCount);
+    if Count=0 then exit;
+    if EntryType=3 then begin
+      // short
+      GetMem(Buffer,SizeOf(DWord)*Count);
+      for i:=0 to Count-1 do
+        Buffer[i]:=FixEndian(PWord(p)[i]);
+    end else if EntryType=4 then begin
+      // long
+      Buffer:=p;
+      p:=nil;
+      if FReverseEndian then
+        for i:=0 to Count-1 do
+          Buffer[i]:=FixEndian(PDWord(Buffer)[i]);
+    end else
+      TiffError('only short or long allowed');
+  finally
+    if p<>nil then FreeMem(p);
+  end;
+end;
+
+procedure TFPReaderTiff.ReadShortValues(StreamPos: DWord; out Buffer: PWord;
+  out Count: DWord);
+var
+  p: Pointer;
+  ByteCount: PtrUInt;
+  EntryType: word;
+  i: DWord;
+begin
+  Buffer:=nil;
+  Count:=0;
+  p:=nil;
+  try
+    ReadValues(StreamPos,EntryType,Count,p,ByteCount);
+    if Count=0 then exit;
+    if EntryType=3 then begin
+      // short
+      Buffer:=p;
+      p:=nil;
+      if FReverseEndian then
+        for i:=0 to Count-1 do
+          Buffer[i]:=FixEndian(Buffer[i]);
+    end else
+      TiffError('only short allowed, but found '+IntToStr(EntryType));
+  finally
+    if p<>nil then FreeMem(p);
+  end;
+end;
+
+procedure TFPReaderTiff.ReadImage(Index: integer);
+var
+  StripCount: DWord;
+  StripOffsets: PDWord;
+  StripByteCounts: PDWord;
+  StripIndex: Dword;
+  SOCount: DWord;
+  SBCCount: DWord;
+  CurOffset: DWord;
+  CurByteCnt: PtrInt;
+  Strip: PByte;
+  Run: Dword;
+  y: DWord;
+  y2: DWord;
+  x: DWord;
+  Pixel: DWord;
+  dx: LongInt;
+  dy: LongInt;
+  SampleCnt: DWord;
+  SampleBits: PWord;
+  ExtraSampleCnt: DWord;
+  ExtraSamples: PWord;
+  RedValue: Word;
+  GreenValue: Word;
+  BlueValue: Word;
+  AlphaValue: Word;
+  Col: TFPColor;
+  i: Integer;
+  CurImg: TFPCustomImage;
+  GrayBits: Word;
+  RedBits: Word;
+  GreenBits: Word;
+  BlueBits: Word;
+  AlphaBits: Word;
+  BytesPerPixel: Integer;
+begin
+  if IDF.PhotoMetricInterpretation=High(IDF.PhotoMetricInterpretation) then
+    TiffError('missing PhotometricInterpretation');
+  if IDF.RowsPerStrip=0 then
+    TiffError('missing RowsPerStrip');
+  if IDF.BitsPerSample=0 then
+    TiffError('missing BitsPerSample');
+  if (IDF.ImageWidth=0) or (IDF.ImageHeight=0) then begin
+    exit;
+  end;
+
+  if (Index>0) and (not FirstImg.ImageIsThumbNail) then 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);
+
+  StripCount:=((IDF.ImageHeight-1) div IDF.RowsPerStrip)+1;
+  StripOffsets:=nil;
+  StripByteCounts:=nil;
+  Strip:=nil;
+  ExtraSamples:=nil;
+  SampleBits:=nil;
+  ExtraSampleCnt:=0;
+  try
+    ReadShortOrLongValues(IDF.StripOffsets,StripOffsets,SOCount);
+    if SOCount<>StripCount then
+      TiffError('number of StripCounts is wrong');
+    ReadShortOrLongValues(IDF.StripByteCounts,StripByteCounts,SBCCount);
+    if SBCCount<>StripCount then
+      TiffError('number of StripByteCounts is wrong');
+
+    ReadShortValues(IDF.BitsPerSample,SampleBits,SampleCnt);
+    if SampleCnt<>IDF.SamplesPerPixel then
+      TiffError('Samples='+IntToStr(SampleCnt)+' <> SamplesPerPixel='+IntToStr(IDF.SamplesPerPixel));
+    if IDF.ExtraSamples>0 then
+      ReadShortValues(IDF.ExtraSamples,ExtraSamples,ExtraSampleCnt);
+    if ExtraSampleCnt>=SampleCnt then
+      TiffError('Samples='+IntToStr(SampleCnt)+' ExtraSampleCnt='+IntToStr(ExtraSampleCnt));
+
+    case IDF.PhotoMetricInterpretation of
+    0,1: if SampleCnt-ExtraSampleCnt<>1 then
+      TiffError('gray images expects 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));
+    3: if SampleCnt-ExtraSampleCnt<>1 then
+      TiffError('palette images expects 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));
+    end;
+
+    GrayBits:=0;
+    RedBits:=0;
+    GreenBits:=0;
+    BlueBits:=0;
+    AlphaBits:=0;
+    BytesPerPixel:=0;
+    case IDF.PhotoMetricInterpretation of
+    0,1:
+      begin
+        GrayBits:=SampleBits[0];
+        CurImg.Extra[TiffGrayBits]:=IntToStr(GrayBits);
+        for i:=0 to ExtraSampleCnt-1 do
+          if ExtraSamples[i]=2 then begin
+            AlphaBits:=SampleBits[3+i];
+            CurImg.Extra[TiffAlphaBits]:=IntToStr(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);
+        for i:=0 to ExtraSampleCnt-1 do
+          if ExtraSamples[i]=2 then begin
+            AlphaBits:=SampleBits[3+i];
+            CurImg.Extra[TiffAlphaBits]:=IntToStr(AlphaBits);
+          end;
+      end;
+    end;
+    BytesPerPixel:=(GrayBits+RedBits+GreenBits+BlueBits+AlphaBits) div 8;
+
+    if not (IDF.FillOrder in [0,1]) then
+      TiffError('FillOrder unsupported: '+IntToStr(IDF.FillOrder));
+
+    for StripIndex:=0 to SampleCnt-1 do begin
+      if not (SampleBits[StripIndex] in [8,16]) then
+        TiffError('SampleBits unsupported: '+IntToStr(SampleBits[StripIndex]));
+    end;
+
+    if CurImg=nil then exit;
+    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
+      CurOffset:=StripOffsets[StripIndex];
+      CurByteCnt:=StripByteCounts[StripIndex];
+      //writeln('TFPReaderTiff.ReadImage CurOffset=',CurOffset,' CurByteCnt=',CurByteCnt);
+      if CurByteCnt<=0 then continue;
+      ReAllocMem(Strip,CurByteCnt);
+      SetStreamPos(CurOffset);
+      s.Read(Strip^,CurByteCnt);
+
+      // decompress
+      case IDF.Compression of
+      1: ; // not compressed
+      2: DecompressPackBits(Strip,CurByteCnt); // packbits
+      else
+        TiffError('compression '+IntToStr(IDF.Compression)+' not supported yet');
+      end;
+      if CurByteCnt<=0 then continue;
+
+      Run:=0;
+      dx:=0;
+      dy:=0;
+      for y2:=0 to IDF.RowsPerStrip-1 do begin
+        if y>=IDF.ImageHeight then break;
+        //writeln('TFPReaderTiff.ReadImage y=',y,' IDF.ImageWidth=',IDF.ImageWidth);
+        for x:=0 to IDF.ImageWidth-1 do begin
+          if PtrInt(Run)+BytesPerPixel>CurByteCnt then begin
+            TiffError('TFPReaderTiff.ReadImage Strip too short Run='+IntToStr(Run)+' CurByteCnt='+IntToStr(CurByteCnt)+' x='+IntToStr(x)+' y='+IntToStr(y)+' y2='+IntToStr(y2));
+            break;
+          end;
+          case IDF.PhotoMetricInterpretation of
+          0,1:
+            begin
+              if GrayBits=8 then begin
+                Pixel:=PCUInt8(Strip)[Run];
+                Pixel:=Pixel shl 8+Pixel;
+                inc(Run);
+              end else if GrayBits=16 then begin
+                Pixel:=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;
+              AlphaValue:=alphaOpaque;
+              for i:=0 to ExtraSampleCnt-1 do begin
+                if ExtraSamples[i]=2 then begin
+                  if SampleBits[3+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;
+              Col:=FPColor(Pixel,Pixel,Pixel,AlphaValue);
+            end;
+
+          2:
+            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;
+              AlphaValue:=alphaOpaque;
+              for i:=0 to ExtraSampleCnt-1 do begin
+                if ExtraSamples[i]=2 then begin
+                  if SampleBits[3+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;
+              Col:=FPColor(RedValue,GreenValue,BlueValue,AlphaValue);
+            end;
+          else
+            TiffError('PhotometricInterpretation='+IntToStr(IDF.PhotoMetricInterpretation)+' not supported');
+          end;
+
+          // Orientation
+          case IDF.Orientation of
+          1: begin dx:=x; dy:=y; end;// 0,0 is left, top
+          2: begin dx:=IDF.ImageWidth-x-1; dy:=y; end;// 0,0 is right, top
+          3: begin dx:=IDF.ImageWidth-x-1; dy:=IDF.ImageHeight-y-1; end;// 0,0 is right, bottom
+          4: begin dx:=x; dy:=IDF.ImageHeight-y; end;// 0,0 is left, bottom
+          5: begin dx:=y; dy:=x; end;// 0,0 is top, left (rotated)
+          6: begin dx:=IDF.ImageHeight-y-1; dy:=x; end;// 0,0 is top, right (rotated)
+          7: begin dx:=IDF.ImageHeight-y-1; dy:=IDF.ImageWidth-x-1; end;// 0,0 is bottom, right (rotated)
+          8: begin dx:=y; dy:=IDF.ImageWidth-x-1; end;// 0,0 is bottom, left (rotated)
+          end;
+          CurImg.Colors[dx,dy]:=Col;
+        end;
+        inc(y);
+      end;
+    end;
+  finally
+    ReAllocMem(ExtraSamples,0);
+    ReAllocMem(SampleBits,0);
+    ReAllocMem(StripOffsets,0);
+    ReAllocMem(StripByteCounts,0);
+    ReAllocMem(Strip,0);
+    FirstImg.Assign(IDF);
+  end;
+end;
+
+function TFPReaderTiff.FixEndian(w: Word): Word; inline;
+begin
+  Result:=w;
+  if FReverseEndian then
+    Result:=((Result and $ff) shl 8) or (Result shr 8);
+end;
+
+function TFPReaderTiff.FixEndian(d: DWord): DWord; inline;
+begin
+  Result:=d;
+  if FReverseEndian then
+    Result:=((Result and $ff) shl 24)
+          or ((Result and $ff00) shl 8)
+          or ((Result and $ff0000) shr 8)
+          or (Result shr 24);
+end;
+
+procedure TFPReaderTiff.DecompressPackBits(var Buffer: Pointer; var Count: PtrInt
+  );
+var
+  p: Pcint8;
+  n: cint8;
+  NewBuffer: Pcint8;
+  SrcStep: PtrInt;
+  NewCount: Integer;
+  i: PtrInt;
+  d: pcint8;
+  j: ShortInt;
+begin
+  // compute NewCount
+  NewCount:=0;
+  p:=Pcint8(Buffer);
+  i:=Count;
+  while i>0 do begin
+    n:=p^;
+    case n of
+    0..127:   begin inc(NewCount,n+1);  SrcStep:=n+2; end; // copy the next n+1 bytes
+    -127..-1: begin inc(NewCount,-n+1); SrcStep:=2;   end; // copy the next byte n+1 times
+    else SrcStep:=1; // noop
+    end;
+    inc(p,SrcStep);
+    dec(i,SrcStep);
+  end;
+
+  // decompress
+  if NewCount=0 then begin
+    NewBuffer:=nil;
+  end else begin
+    GetMem(NewBuffer,NewCount);
+    i:=Count;
+    p:=Pcint8(Buffer);
+    d:=Pcint8(NewBuffer);
+    while i>0 do begin
+      n:=p^;
+      case n of
+      0..127:
+        begin
+          // copy the next n+1 bytes
+          inc(NewCount,n+1);  SrcStep:=n+2;
+          System.Move(p[1],d^,n+1);
+          inc(d,n+1);
+        end;
+      -127..-1:
+        begin
+          // copy the next byte n+1 times
+          inc(NewCount,-n+1); SrcStep:=2;
+          j:=-n;
+          n:=p[1];
+          while j>=0 do begin
+            d[j]:=n;
+            dec(j);
+          end;
+        end;
+      else SrcStep:=1; // noop
+      end;
+      inc(p,SrcStep);
+      dec(i,SrcStep);
+    end;
+  end;
+  FreeMem(Buffer);
+  Buffer:=NewBuffer;
+  Count:=NewCount;
+end;
+
+procedure TFPReaderTiff.InternalRead(Str: TStream; AnImage: TFPCustomImage);
+begin
+  FirstImg.Img:=AnImage;
+  try
+    LoadFromStream(Str);
+  finally
+    FirstImg.Img:=nil;
+  end;
+end;
+
+function TFPReaderTiff.InternalCheck(Str: TStream): boolean;
+var
+  IFD: DWord;
+begin
+  try
+    s:=Str;
+    fStartPos:=s.Position;
+    Result:=ReadTiffHeader(true,IFD) and (IFD<>0);
+    s.Position:=fStartPos;
+  except
+    Result:=false;
+  end;
+end;
+
+constructor TFPReaderTiff.Create;
+begin
+  IDF:=TTiffIDF.Create;
+  FirstImg:=TTiffIDF.Create;
+end;
+
+destructor TFPReaderTiff.Destroy;
+begin
+  Clear;
+  FreeAndNil(FirstImg);
+  FreeAndNil(IDF);
+  inherited Destroy;
+end;
+
+procedure TFPReaderTiff.Clear;
+begin
+  IDF.Clear;
+  FirstImg.Clear;
+  FReverseEndian:=false;
+  FreeAndNil(fIFDStarts);
+end;
+
+end.
+
diff --git a/packages/fcl-image/src/fptiffcmn.pas b/packages/fcl-image/src/fptiffcmn.pas
new file mode 100644
index 0000000000..22da7d4fac
--- /dev/null
+++ b/packages/fcl-image/src/fptiffcmn.pas
@@ -0,0 +1,222 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2008 by the Free Pascal development team
+
+    Common stuff for Tiff image format.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************
+}
+unit FPTiffCmn;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, sysutils, FPimage;
+
+type
+  TTiffRational = packed record
+    Numerator, Denominator: DWord;
+  end;
+
+const
+  TiffRational0: TTiffRational = (Numerator: 0; Denominator: 0);
+
+  // 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';
+  TiffAlphaBits = TiffExtraPrefix+'AlphaBits';
+  TiffArtist = TiffExtraPrefix+'Artist';
+  TiffCopyright = TiffExtraPrefix+'Copyright';
+  TiffDocumentName = TiffExtraPrefix+'DocumentName';
+  TiffDateTime = TiffExtraPrefix+'DateTime';
+  TiffImageDescription = TiffExtraPrefix+'ImageDescription';
+  TiffOrientation = TiffExtraPrefix+'Orientation';
+  TiffResolutionUnit = TiffExtraPrefix+'ResolutionUnit';
+  TiffXResolution = TiffExtraPrefix+'XResolution';
+  TiffYResolution = TiffExtraPrefix+'YResolution';
+
+type
+
+  { TTiffIDF }
+
+  TTiffIDF = class
+  public
+    Artist: String;
+    BitsPerSample: DWord; // tiff position of entry
+    BitsPerSampleArray: array of Word;
+    CellLength: DWord;
+    CellWidth: DWord;
+    ColorMap: DWord;// tiff position of entry
+    Compression: DWord;
+    Copyright: string;
+    DateAndTime: string;
+    DocumentName: string;
+    ExtraSamples: DWord;// tiff position of entry
+    FillOrder: DWord;
+    HostComputer: string;
+    ImageDescription: string;
+    ImageHeight: DWord;
+    ImageIsMask: Boolean;
+    ImageIsPage: Boolean;
+    ImageIsThumbNail: Boolean;
+    ImageWidth: DWord;
+    Make_ScannerManufacturer: string;
+    Model_Scanner: string;
+    Orientation: DWord;
+    PhotoMetricInterpretation: DWord;
+    PlanarConfiguration: DWord;
+    ResolutionUnit: DWord;
+    RowsPerStrip: DWord;
+    SamplesPerPixel: DWord;
+    Software: string;
+    StripByteCounts: DWord;// tiff position of entry
+    StripOffsets: DWord; // tiff position of entry
+    Treshholding: DWord;
+    XResolution: TTiffRational;
+    YResolution: TTiffRational;
+    Img: TFPCustomImage;
+    procedure Clear;
+    procedure Assign(IDF: TTiffIDF);
+  end;
+
+function TiffRationalToStr(const r: TTiffRational): string;
+function StrToTiffRationalDef(const s: string; const Def: TTiffRational): TTiffRational;
+procedure ClearTiffExtras(Img: TFPCustomImage);
+procedure CopyTiffExtras(SrcImg, DestImg: TFPCustomImage);
+procedure WriteTiffExtras(Msg: string; Img: TFPCustomImage);
+
+implementation
+
+function TiffRationalToStr(const r: TTiffRational): string;
+begin
+  Result:=IntToStr(r.Numerator)+'/'+IntToStr(r.Denominator);
+end;
+
+function StrToTiffRationalDef(const s: string; const Def: TTiffRational
+  ): TTiffRational;
+var
+  p: LongInt;
+begin
+  Result:=Def;
+  p:=System.Pos('/',s);
+  if p<1 then exit;
+  Result.Numerator:=StrToIntDef(copy(s,1,p-1),TiffRational0.Numerator);
+  Result.Denominator:=StrToIntDef(copy(s,p+1,length(s)),TiffRational0.Denominator);
+end;
+
+procedure ClearTiffExtras(Img: TFPCustomImage);
+var
+  i: Integer;
+begin
+  for i:=Img.ExtraCount-1 downto 0 do
+    if SysUtils.CompareText(copy(Img.ExtraKey[i],1,4),'Tiff')=0 then
+      Img.RemoveExtra(Img.ExtraKey[i]);
+end;
+
+procedure CopyTiffExtras(SrcImg, DestImg: TFPCustomImage);
+var
+  i: Integer;
+begin
+  ClearTiffExtras(DestImg);
+  for i:=SrcImg.ExtraCount-1 downto 0 do
+    if SysUtils.CompareText(copy(SrcImg.ExtraKey[i],1,4),'Tiff')=0 then
+      DestImg.Extra[SrcImg.ExtraKey[i]]:=SrcImg.ExtraValue[i];
+end;
+
+procedure WriteTiffExtras(Msg: string; Img: TFPCustomImage);
+var
+  i: Integer;
+begin
+  writeln('WriteTiffExtras ',Msg);
+  for i:=Img.ExtraCount-1 downto 0 do
+    //if SysUtils.CompareText(copy(Img.ExtraKey[i],1,4),'Tiff')=0 then
+      writeln('  ',i,' ',Img.ExtraKey[i],'=',Img.ExtraValue[i]);
+end;
+
+{ TTiffIDF }
+
+procedure TTiffIDF.Clear;
+begin
+  PhotoMetricInterpretation:=High(PhotoMetricInterpretation);
+  PlanarConfiguration:=0;
+  Compression:=0;
+  ImageHeight:=0;
+  ImageWidth:=0;
+  ImageIsThumbNail:=false;
+  ImageIsPage:=false;
+  ImageIsMask:=false;
+  BitsPerSample:=0;
+  SetLength(BitsPerSampleArray,0);
+  ResolutionUnit:=0;
+  XResolution:=TiffRational0;
+  YResolution:=TiffRational0;
+  RowsPerStrip:=0;
+  StripOffsets:=0;
+  StripByteCounts:=0;
+  SamplesPerPixel:=0;
+  Artist:='';
+  HostComputer:='';
+  ImageDescription:='';
+  Make_ScannerManufacturer:='';
+  Model_Scanner:='';
+  Copyright:='';
+  DateAndTime:='';
+  Software:='';
+  CellWidth:=0;
+  CellLength:=0;
+  FillOrder:=0;
+  Orientation:=0;
+  Treshholding:=0;
+end;
+
+procedure TTiffIDF.Assign(IDF: TTiffIDF);
+begin
+  PhotoMetricInterpretation:=IDF.PhotoMetricInterpretation;
+  PlanarConfiguration:=IDF.PlanarConfiguration;
+  Compression:=IDF.Compression;
+  ImageHeight:=IDF.ImageHeight;
+  ImageWidth:=IDF.ImageWidth;
+  ImageIsThumbNail:=IDF.ImageIsThumbNail;
+  ImageIsPage:=IDF.ImageIsPage;
+  ImageIsMask:=IDF.ImageIsMask;
+  BitsPerSample:=IDF.BitsPerSample;
+  BitsPerSampleArray:=IDF.BitsPerSampleArray;
+  ResolutionUnit:=IDF.ResolutionUnit;
+  XResolution:=IDF.XResolution;
+  YResolution:=IDF.YResolution;
+  RowsPerStrip:=IDF.RowsPerStrip;
+  StripOffsets:=IDF.StripOffsets;
+  StripByteCounts:=IDF.StripByteCounts;
+  SamplesPerPixel:=IDF.SamplesPerPixel;
+  Artist:=IDF.Artist;
+  HostComputer:=IDF.HostComputer;
+  ImageDescription:=IDF.ImageDescription;
+  Make_ScannerManufacturer:=IDF.Make_ScannerManufacturer;
+  Model_Scanner:=IDF.Model_Scanner;
+  Copyright:=IDF.Copyright;
+  DateAndTime:=IDF.DateAndTime;
+  Software:=IDF.Software;
+  CellWidth:=IDF.CellWidth;
+  CellLength:=IDF.CellLength;
+  FillOrder:=IDF.FillOrder;
+  Orientation:=IDF.Orientation;
+  Treshholding:=IDF.Treshholding;
+  if (Img<>nil) and (IDF.Img<>nil) then
+    Img.Assign(IDF.Img);
+end;
+
+end.
+
diff --git a/packages/fcl-image/src/fpwritetiff.pas b/packages/fcl-image/src/fpwritetiff.pas
new file mode 100644
index 0000000000..70ad1a7b17
--- /dev/null
+++ b/packages/fcl-image/src/fpwritetiff.pas
@@ -0,0 +1,681 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2008 by the Free Pascal development team
+
+    Tiff reader for fpImage.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************
+
+  Working:
+    Grayscale 8,16bit (optional alpha),
+    RGB 8,16bit (optional alpha),
+    Orientation,
+
+  ToDo:
+    Compression: packbits, deflate, jpeg, ...
+    thumbnail
+    Planar
+    ColorMap
+    multiple images
+    separate mask
+    pages
+    fillorder - not needed by baseline tiff reader
+    bigtiff 64bit offsets
+    endian - currently using system endianess
+}
+unit FPWriteTiff;
+
+{$mode objfpc}{$H+}
+
+{off $DEFINE VerboseTiffWriter}
+
+interface
+
+uses
+  Math, Classes, SysUtils, FPimage, FPTiffCmn, FPWriteTGA;
+
+type
+
+  { TTiffWriteEntry }
+
+  TTiffWriteEntry = class
+  public
+    Tag: Word;
+    EntryType: Word;
+    Count: DWord;
+    Data: Pointer;
+    DataPos: DWord;
+    Bytes: DWord;
+    destructor Destroy; override;
+  end;
+
+  TTiffWriteStrip = record
+    Data: Pointer;
+    Bytes: DWord;
+  end;
+  PTiffWriteStrip = ^TTiffWriteStrip;
+
+  { TTiffWriteStripOffsets }
+
+  TTiffWriteStripOffsets = class(TTiffWriteEntry)
+  public
+    Strips: PTiffWriteStrip;
+    StripByteCounts: TTiffWriteEntry;
+    constructor Create;
+    destructor Destroy; override;
+    procedure SetCount(NewCount: DWord);
+  end;
+
+  { TFPWriterTiff }
+
+  TFPWriterTiff = class(TFPCustomImageWriter)
+  private
+    fStartPos: Int64;
+    FEntries: TFPList; // list of TFPList of TTiffWriteEntry
+    fStream: TStream;
+    fPosition: DWord;
+    procedure ClearEntries;
+    procedure WriteTiff;
+    procedure WriteHeader;
+    procedure WriteIDFs;
+    procedure WriteEntry(Entry: TTiffWriteEntry);
+    procedure WriteData;
+    procedure WriteEntryData(Entry: TTiffWriteEntry);
+    procedure WriteBuf(var Buf; Count: DWord);
+    procedure WriteWord(w: Word);
+    procedure WriteDWord(d: DWord);
+  protected
+    procedure InternalWrite(Stream: TStream; Img: TFPCustomImage); override;
+    procedure AddEntryString(Tag: word; const s: string);
+    procedure AddEntryShort(Tag: word; Value: Word);
+    procedure AddEntryLong(Tag: word; Value: DWord);
+    procedure AddEntryRational(Tag: word; const Value: TTiffRational);
+    procedure AddEntry(Tag: Word; EntryType: Word; EntryCount: DWord;
+                       Data: Pointer; Bytes: DWord;
+                       CopyData: boolean = true);
+    procedure AddEntry(Entry: TTiffWriteEntry);
+    procedure TiffError(Msg: string);
+  public
+    constructor Create; override;
+    destructor Destroy; override;
+    procedure Clear;
+    procedure AddImage(Img: TFPCustomImage);
+    procedure SaveToStream(Stream: TStream);
+  end;
+
+function CompareTiffWriteEntries(Entry1, Entry2: Pointer): integer;
+
+implementation
+
+function CompareTiffWriteEntries(Entry1, Entry2: Pointer): integer;
+begin
+  Result:=integer(TTiffWriteEntry(Entry1).Tag)-integer(TTiffWriteEntry(Entry2).Tag);
+end;
+
+{ TFPWriterTiff }
+
+procedure TFPWriterTiff.WriteWord(w: Word);
+begin
+  if fStream<>nil then
+    fStream.WriteWord(w);
+  inc(fPosition,2);
+end;
+
+procedure TFPWriterTiff.WriteDWord(d: DWord);
+begin
+  if fStream<>nil then
+    fStream.WriteDWord(d);
+  inc(fPosition,4);
+end;
+
+procedure TFPWriterTiff.ClearEntries;
+var
+  i: Integer;
+  List: TFPList;
+  j: Integer;
+begin
+  for i:=FEntries.Count-1 downto 0 do begin
+    List:=TFPList(FEntries[i]);
+    for j:=List.Count-1 downto 0 do
+      TObject(List[j]).Free;
+    List.Free;
+  end;
+  FEntries.Clear;
+end;
+
+procedure TFPWriterTiff.WriteTiff;
+begin
+  {$IFDEF VerboseTiffWriter}
+  writeln('TFPWriterTiff.WriteTiff fStream=',fStream<>nil);
+  {$ENDIF}
+  fPosition:=0;
+  WriteHeader;
+  WriteIDFs;
+  WriteData;
+end;
+
+procedure TFPWriterTiff.WriteHeader;
+var
+  EndianMark: String;
+begin
+  EndianMark:={$IFDEF FPC_BIG_ENDIAN}'MM'{$ELSE}'II'{$ENDIF};
+  WriteBuf(EndianMark[1],2);
+  WriteWord(42);
+  WriteDWord(8);
+end;
+
+procedure TFPWriterTiff.WriteIDFs;
+var
+  i: Integer;
+  List: TFPList;
+  j: Integer;
+  Entry: TTiffWriteEntry;
+  NextIDFPos: DWord;
+begin
+  for i:=0 to FEntries.Count-1 do begin
+    List:=TFPList(FEntries[i]);
+    // write count
+    {$IFDEF VerboseTiffWriter}
+    writeln('TFPWriterTiff.WriteIDFs Count=',List.Count);
+    {$ENDIF}
+    WriteWord(List.Count);
+    // write array of entries
+    for j:=0 to List.Count-1 do begin
+      Entry:=TTiffWriteEntry(List[j]);
+      WriteEntry(Entry);
+    end;
+    // write position of next IDF
+    if i<FEntries.Count-1 then
+      NextIDFPos:=fPosition+4
+    else
+      NextIDFPos:=0;
+    WriteDWord(NextIDFPos);
+  end;
+end;
+
+procedure TFPWriterTiff.WriteEntry(Entry: TTiffWriteEntry);
+var
+  PadBytes: DWord;
+begin
+  {$IFDEF VerboseTiffWriter}
+  writeln('TFPWriterTiff.WriteEntry Tag=',Entry.Tag,' Type=',Entry.EntryType,' Count=',Entry.Count,' Bytes=',Entry.Bytes);
+  {$ENDIF}
+  WriteWord(Entry.Tag);
+  WriteWord(Entry.EntryType);
+  WriteDWord(Entry.Count);
+  if Entry.Bytes<=4 then begin
+    if Entry.Bytes>0 then
+      WriteBuf(Entry.Data^,Entry.Bytes);
+    PadBytes:=0;
+    WriteBuf(PadBytes,4-Entry.Bytes);
+  end else begin
+    WriteDWord(Entry.DataPos);
+  end;
+end;
+
+procedure TFPWriterTiff.WriteData;
+var
+  i: Integer;
+  List: TFPList;
+  j: Integer;
+  Entry: TTiffWriteEntry;
+  Strips: TTiffWriteStripOffsets;
+  k: Integer;
+  Bytes: DWord;
+begin
+  for i:=0 to FEntries.Count-1 do begin
+    List:=TFPList(FEntries[i]);
+    // write entry data
+    for j:=0 to List.Count-1 do begin
+      Entry:=TTiffWriteEntry(List[j]);
+      WriteEntryData(Entry);
+    end;
+    // write strips
+    for j:=0 to List.Count-1 do begin
+      Entry:=TTiffWriteEntry(List[j]);
+      if Entry is TTiffWriteStripOffsets then begin
+        Strips:=TTiffWriteStripOffsets(Entry);
+        // write Strips
+        for k:=0 to Strips.Count-1 do begin
+          PDWord(Strips.Data)[k]:=fPosition;
+          Bytes:=Strips.Strips[k].Bytes;
+          PDWord(Strips.StripByteCounts.Data)[k]:=Bytes;
+          {$IFDEF VerboseTiffWriter}
+          //writeln('TFPWriterTiff.WriteData Strip fPosition=',fPosition,' Bytes=',Bytes);
+          {$ENDIF}
+          if Bytes>0 then
+            WriteBuf(Strips.Strips[k].Data^,Bytes);
+        end;
+      end;
+    end;
+  end;
+end;
+
+procedure TFPWriterTiff.WriteEntryData(Entry: TTiffWriteEntry);
+begin
+  if Entry.Bytes>4 then begin
+    Entry.DataPos:=fPosition;
+    WriteBuf(Entry.Data^,Entry.Bytes);
+  end;
+end;
+
+procedure TFPWriterTiff.WriteBuf(var Buf; Count: DWord);
+begin
+  if Count=0 then exit;
+  if (fStream<>nil) then
+    fStream.Write(Buf,Count);
+  inc(fPosition,Count);
+end;
+
+procedure TFPWriterTiff.AddImage(Img: TFPCustomImage);
+var
+  IDF: TTiffIDF;
+  GrayBits: Word;
+  RedBits: Word;
+  GreenBits: Word;
+  BlueBits: Word;
+  AlphaBits: Word;
+  ImgWidth: DWord;
+  ImgHeight: DWord;
+  Compression: Word;
+  BitsPerSample: array[0..3] of Word;
+  SamplesPerPixel: Integer;
+  BitsPerPixel: DWord;
+  i: Integer;
+  OrientedWidth: DWord;
+  OrientedHeight: DWord;
+  y: integer;
+  x: Integer;
+  StripOffsets: TTiffWriteStripOffsets;
+  Row: DWord;
+  BytesPerLine: DWord;
+  StripBytes: DWord;
+  Strip: PByte;
+  Run: PByte;
+  StripIndex: DWord;
+  Col: TFPColor;
+  Value: Integer;
+  dx: Integer;
+  dy: Integer;
+  CurEntries: TFPList;
+  StripCounts: TTiffWriteEntry;
+begin
+  StripOffsets:=nil;
+  Strip:=nil;
+  IDF:=TTiffIDF.Create;
+  try
+    // add new list of entries
+    CurEntries:=TFPList.Create;
+    FEntries.Add(CurEntries);
+
+    IDF.PhotoMetricInterpretation:=StrToInt64Def(Img.Extra[TiffPhotoMetric],High(IDF.PhotoMetricInterpretation));
+    if not (IDF.PhotoMetricInterpretation in [0,1,2]) then
+      TiffError('PhotoMetricInterpretation='+IntToStr(IDF.PhotometricInterpretation)+' not supported');
+    IDF.Artist:=Img.Extra[TiffArtist];
+    IDF.Copyright:=Img.Extra[TiffCopyright];
+    IDF.DocumentName:=Img.Extra[TiffDocumentName];
+    IDF.DateAndTime:=Img.Extra[TiffDateTime];
+    IDF.ImageDescription:=Img.Extra[TiffImageDescription];
+    IDF.Orientation:=StrToIntDef(Img.Extra[TiffOrientation],1);
+    if not (IDF.Orientation in [1..8]) then
+      IDF.Orientation:=1;
+    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);
+    ImgWidth:=Img.Width;
+    ImgHeight:=Img.Height;
+    Compression:=1;
+
+    if IDF.Orientation in [1..4] then begin
+      OrientedWidth:=ImgWidth;
+      OrientedHeight:=ImgHeight;
+    end else begin
+      OrientedWidth:=ImgHeight;
+      OrientedHeight:=ImgWidth;
+    end;
+
+    {$IFDEF VerboseTiffWriter}
+    writeln('TFPWriterTiff.AddImage PhotoMetricInterpretation=',IDF.PhotoMetricInterpretation);
+    writeln('TFPWriterTiff.AddImage ImageWidth=',ImgWidth,' ImageHeight=',ImgHeight);
+    writeln('TFPWriterTiff.AddImage Orientation=',IDF.Orientation);
+    writeln('TFPWriterTiff.AddImage ResolutionUnit=',IDF.ResolutionUnit);
+    writeln('TFPWriterTiff.AddImage XResolution=',TiffRationalToStr(IDF.XResolution));
+    writeln('TFPWriterTiff.AddImage YResolution=',TiffRationalToStr(IDF.YResolution));
+    writeln('TFPWriterTiff.AddImage GrayBits=',GrayBits,' RedBits=',RedBits,' GreenBits=',GreenBits,' BlueBits=',BlueBits,' AlphaBits=',AlphaBits);
+    writeln('TFPWriterTiff.AddImage Compression=',Compression);
+    {$ENDIF}
+
+    // required meta entries
+    AddEntryShort(262,IDF.PhotoMetricInterpretation);
+    AddEntryLong(256,ImgWidth);
+    AddEntryLong(257,ImgHeight);
+    AddEntryShort(259,Compression);
+    AddEntryShort(274,IDF.Orientation);
+    AddEntryShort(296,IDF.ResolutionUnit);
+    AddEntryRational(282,IDF.XResolution);
+    AddEntryRational(283,IDF.YResolution);
+    case IDF.PhotoMetricInterpretation of
+    0,1:
+      begin
+        BitsPerSample[0]:=GrayBits;
+        SamplesPerPixel:=1;
+      end;
+    2:
+      begin
+        BitsPerSample[0]:=RedBits;
+        BitsPerSample[1]:=GreenBits;
+        BitsPerSample[2]:=BlueBits;
+        SamplesPerPixel:=3;
+      end;
+    end;
+    if AlphaBits>0 then begin
+      BitsPerSample[SamplesPerPixel]:=AlphaBits;
+      inc(SamplesPerPixel);
+      // ExtraSamples
+      AddEntryShort(338,2);// 2=unassociated alpha
+    end;
+    // BitsPerSample (required)
+    AddEntry(258,3,SamplesPerPixel,@BitsPerSample[0],SamplesPerPixel*2);
+    AddEntryShort(277,SamplesPerPixel);
+
+    // RowsPerStrip (required)
+    BitsPerPixel:=0;
+    for i:=0 to SamplesPerPixel-1 do
+      inc(BitsPerPixel,BitsPerSample[i]);
+    BytesPerLine:=(BitsPerPixel*OrientedWidth+7) div 8;
+    if OrientedWidth=0 then
+      IDF.RowsPerStrip:=8
+    else
+      IDF.RowsPerStrip:=8192 div BytesPerLine;
+    if IDF.RowsPerStrip<1 then
+      IDF.RowsPerStrip:=1;
+    {$IFDEF VerboseTiffWriter}
+    writeln('TFPWriterTiff.AddImage BitsPerPixel=',BitsPerPixel,' OrientedWidth=',OrientedWidth,' BytesPerLine=',BytesPerLine,' RowsPerStrip=',IDF.RowsPerStrip);
+    {$ENDIF}
+    AddEntryLong(278,IDF.RowsPerStrip);
+
+    // optional entries
+    if IDF.Artist<>'' then
+      AddEntryString(315,IDF.Artist);
+    if IDF.Copyright<>'' then
+      AddEntryString(33432,IDF.Copyright);
+    if IDF.DocumentName<>'' then
+      AddEntryString(269,IDF.DocumentName);
+    if IDF.DateAndTime<>'' then
+      AddEntryString(306,IDF.DateAndTime);
+    if IDF.ImageDescription<>'' then
+      AddEntryString(270,IDF.ImageDescription);
+
+    // StripOffsets: StripOffsets, StripByteCounts
+    StripOffsets:=TTiffWriteStripOffsets.Create;
+    AddEntry(StripOffsets);
+    StripCounts:=TTiffWriteEntry.Create;
+    StripCounts.Tag:=279;
+    StripCounts.EntryType:=4;
+    StripOffsets.StripByteCounts:=StripCounts;
+    AddEntry(StripCounts);
+    if OrientedHeight>0 then begin
+      StripOffsets.SetCount((OrientedHeight+IDF.RowsPerStrip-1) div IDF.RowsPerStrip);
+      // compute StripOffsets
+      Row:=0;
+      StripIndex:=0;
+      dx:=0;
+      dy:=0;
+      for y:=0 to OrientedHeight-1 do begin
+        if Row=0 then begin
+          // allocate Strip for the next rows
+          StripBytes:=Min(IDF.RowsPerStrip,OrientedHeight-y)*BytesPerLine;
+          //writeln('TFPWriterTiff.AddImage StripIndex=',StripIndex,' StripBytes=',StripBytes);
+          GetMem(Strip,StripBytes);
+          FillByte(Strip^,StripBytes,0);
+          StripOffsets.Strips[StripIndex].Data:=Strip;
+          StripOffsets.Strips[StripIndex].Bytes:=StripBytes;
+          inc(StripIndex);
+          Run:=Strip;
+        end;
+        // write line
+        for x:=0 to OrientedWidth-1 do begin
+          // Orientation
+          case IDF.Orientation of
+          1: begin dx:=x; dy:=y; end;// 0,0 is left, top
+          2: begin dx:=OrientedWidth-x-1; dy:=y; end;// 0,0 is right, top
+          3: begin dx:=OrientedWidth-x-1; dy:=OrientedHeight-y-1; end;// 0,0 is right, bottom
+          4: begin dx:=x; dy:=OrientedHeight-y; end;// 0,0 is left, bottom
+          5: begin dx:=y; dy:=x; end;// 0,0 is top, left (rotated)
+          6: begin dx:=OrientedHeight-y-1; dy:=x; end;// 0,0 is top, right (rotated)
+          7: begin dx:=OrientedHeight-y-1; dy:=OrientedWidth-x-1; end;// 0,0 is bottom, right (rotated)
+          8: begin dx:=y; dy:=OrientedWidth-x-1; end;// 0,0 is bottom, left (rotated)
+          end;
+          Col:=Img.Colors[dx,dy];
+          case IDF.PhotoMetricInterpretation of
+          0,1:
+            begin
+              // grayscale
+              Value:=(DWord(Col.red)+Col.green+Col.blue) div 3;
+              if IDF.PhotoMetricInterpretation=0 then
+                Value:=$ffff-Value;// 0 is white
+              if GrayBits=8 then begin
+                Run^:=Value shr 8;
+                inc(Run);
+              end else if GrayBits=16 then begin
+                PWord(Run)^:=Value;
+                inc(Run,2);
+              end;
+              if AlphaBits=8 then begin
+                Run^:=Col.alpha shr 8;
+                inc(Run);
+              end else if AlphaBits=16 then begin
+                PWord(Run)^:=Col.alpha;
+                inc(Run,2);
+              end;
+            end;
+          2:
+            begin
+              // RGB
+              if RedBits=8 then begin
+                Run^:=Col.red shr 8;
+                inc(Run);
+              end else if RedBits=16 then begin
+                PWord(Run)^:=Col.red;
+                inc(Run,2);
+              end;
+              if GreenBits=8 then begin
+                Run^:=Col.green shr 8;
+                inc(Run);
+              end else if GreenBits=16 then begin
+                PWord(Run)^:=Col.green;
+                inc(Run,2);
+              end;
+              if BlueBits=8 then begin
+                Run^:=Col.blue shr 8;
+                inc(Run);
+              end else if BlueBits=16 then begin
+                PWord(Run)^:=Col.blue;
+                inc(Run,2);
+              end;
+              if AlphaBits=8 then begin
+                Run^:=Col.alpha shr 8;
+                inc(Run);
+              end else if AlphaBits=16 then begin
+                PWord(Run)^:=Col.alpha;
+                inc(Run,2);
+              end;
+            end;
+          end;
+        end;
+        // next row
+        inc(Row);
+        if (Row=IDF.RowsPerStrip) then
+          Row:=0;
+      end;
+    end;
+
+    CurEntries.Sort(@CompareTiffWriteEntries);
+  finally
+    IDF.Free;
+  end;
+end;
+
+procedure TFPWriterTiff.SaveToStream(Stream: TStream);
+begin
+  fStartPos:=Stream.Position;
+  // simulate write to compute offsets
+  fStream:=nil;
+  WriteTiff;
+  // write to stream
+  fStream:=Stream;
+  WriteTiff;
+  fStream:=nil;
+end;
+
+procedure TFPWriterTiff.InternalWrite(Stream: TStream; Img: TFPCustomImage);
+begin
+  AddImage(Img);
+  SaveToStream(Stream);
+end;
+
+procedure TFPWriterTiff.AddEntryString(Tag: word; const s: string);
+begin
+  if s<>'' then
+    AddEntry(Tag,2,length(s)+1,@s[1],length(s)+1)
+  else
+    AddEntry(Tag,2,0,nil,0);
+end;
+
+procedure TFPWriterTiff.AddEntryShort(Tag: word; Value: Word);
+begin
+  AddEntry(Tag,3,1,@Value,2);
+end;
+
+procedure TFPWriterTiff.AddEntryLong(Tag: word; Value: DWord);
+begin
+  AddEntry(Tag,4,1,@Value,4);
+end;
+
+procedure TFPWriterTiff.AddEntryRational(Tag: word; const Value: TTiffRational
+  );
+begin
+  AddEntry(Tag,5,1,@Value,8);
+end;
+
+procedure TFPWriterTiff.AddEntry(Tag: Word; EntryType: Word; EntryCount: DWord;
+  Data: Pointer; Bytes: DWord; CopyData: boolean);
+var
+  Entry: TTiffWriteEntry;
+begin
+  Entry:=TTiffWriteEntry.Create;
+  Entry.Tag:=Tag;
+  Entry.EntryType:=EntryType;
+  Entry.Count:=EntryCount;
+  if CopyData then begin
+    if Bytes>0 then begin
+      GetMem(Entry.Data,Bytes);
+      System.Move(Data^,Entry.Data^,Bytes);
+    end else begin
+      Entry.Data:=nil;
+    end;
+  end else
+    Entry.Data:=Data;
+  Entry.Bytes:=Bytes;
+  AddEntry(Entry);
+end;
+
+procedure TFPWriterTiff.AddEntry(Entry: TTiffWriteEntry);
+var
+  List: TFPList;
+begin
+  List:=TFPList(FEntries[FEntries.Count-1]);
+  List.Add(Entry);
+end;
+
+procedure TFPWriterTiff.TiffError(Msg: string);
+begin
+  raise Exception.Create('TFPWriterTiff.TiffError: '+Msg);
+end;
+
+constructor TFPWriterTiff.Create;
+begin
+  inherited Create;
+  FEntries:=TFPList.Create;
+end;
+
+destructor TFPWriterTiff.Destroy;
+begin
+  Clear;
+  FreeAndNil(FEntries);
+  inherited Destroy;
+end;
+
+procedure TFPWriterTiff.Clear;
+begin
+  ClearEntries;
+end;
+
+{ TTiffWriteEntry }
+
+destructor TTiffWriteEntry.Destroy;
+begin
+  ReAllocMem(Data,0);
+  inherited Destroy;
+end;
+
+{ TTiffWriteStripOffsets }
+
+constructor TTiffWriteStripOffsets.Create;
+begin
+  Tag:=273;
+  EntryType:=4;
+end;
+
+destructor TTiffWriteStripOffsets.Destroy;
+var
+  i: Integer;
+begin
+  if Strips<>nil then begin
+    for i:=0 to Count-1 do
+      ReAllocMem(Strips[i].Data,0);
+    ReAllocMem(Strips,0);
+  end;
+  inherited Destroy;
+end;
+
+procedure TTiffWriteStripOffsets.SetCount(NewCount: DWord);
+var
+  Size: DWord;
+begin
+  {$IFDEF VerboseTiffWriter}
+  writeln('TTiffWriteStripOffsets.SetCount OldCount=',Count,' NewCount=',NewCount);
+  {$ENDIF}
+  Count:=NewCount;
+  Size:=Count*SizeOf(TTiffWriteStrip);
+  ReAllocMem(Strips,Size);
+  if Size>0 then FillByte(Strips^,Size,0);
+  Size:=Count*SizeOf(DWord);
+  // StripOffsets
+  ReAllocMem(Data,Size);
+  if Size>0 then FillByte(Data^,Size,0);
+  Bytes:=Size;
+  // StripByteCounts
+  ReAllocMem(StripByteCounts.Data,Size);
+  if Size>0 then FillByte(StripByteCounts.Data^,Size,0);
+  StripByteCounts.Count:=Count;
+  StripByteCounts.Bytes:=Size;
+end;
+
+end.
+