* Graphics: Added TTiffImage

git-svn-id: trunk@25134 -

.gitattributes

@@ -4448,6 +4448,7 @@ lcl/include/statuspanel.inc svneol=native#text/pascal
 lcl/include/statuspanels.inc svneol=native#text/pascal
 lcl/include/tabcontrol.inc svneol=native#text/pascal
 lcl/include/tabsheet.inc svneol=native#text/pascal
+lcl/include/tiffimage.inc svneol=native#text/pascal
 lcl/include/timer.inc svneol=native#text/pascal
 lcl/include/togglebox.inc svneol=native#text/pascal
 lcl/include/toolbar.inc svneol=native#text/pascal

lcl/graphics.pp

@@ -32,13 +32,14 @@ interface
 {$endif}
 
 uses
-  SysUtils, Math, Types, Classes, FPCAdds,
+  SysUtils, Math, Types, Classes, FPCAdds, LCLversion,
   FileUtil,
   FPImage, FPCanvas,
   FPWriteBMP,              // bmp support
   FPWritePNG, PNGComn,     // png support
   FPReadPNM, FPWritePNM,   // PNM (Portable aNyMap) support
   FPReadJpeg, FPWriteJpeg, // jpg support
+  FPReadTiff, FPTiffCmn,   // tiff support
   IntfGraphics,
   AvgLvlTree,
   LCLStrConsts, LCLType, LCLProc, LMessages, LCLIntf, LResources, LCLResCache,
@@ -1767,6 +1768,64 @@ type
     property Performance: TJPEGPerformance read FPerformance write FPerformance;
   end;
 
+  { TSharedTiffImage }
+
+  TSharedTiffImage = class(TSharedCustomBitmap)
+  end;
+
+  { TTiffImage }
+
+  TTiffUnit = (
+    tuUnknown,
+    tuNone,       // No absolute unit of measurement. Used for images that may have a non-square
+                  // aspect ratio, but no meaningful absolute dimensions.
+    tuInch,
+    tuCentimeter
+  );
+
+  TTiffImage = class(TFPImageBitmap)
+  private
+    FArtist: string;
+    FCopyright: string;
+    FDateTime: TDateTime;
+    FDocumentName: string;
+    FHostComputer: string;
+    FImageDescription: string;
+    FMake: string; {ScannerManufacturer}
+    FModel: string; {Scanner}
+    FResolutionUnit: TTiffUnit;
+    FSoftware: string;
+    FXResolution: TTiffRational;
+    FYResolution: TTiffRational;
+  protected
+    procedure InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader); override;
+    procedure InitializeWriter(AImage: TLazIntfImage; AWriter: TFPCustomImageWriter); override;
+    procedure FinalizeReader(AReader: TFPCustomImageReader); override;
+    class function GetReaderClass: TFPCustomImageReaderClass; override;
+    class function GetWriterClass: TFPCustomImageWriterClass; override;
+    class function GetSharedImageClass: TSharedRasterImageClass; override;
+  public
+    constructor Create; override;
+    class function GetFileExtensions: string; override;
+  public
+    property Artist: string read FArtist write FArtist;
+    property Copyright: string read FCopyright write FCopyright;
+    property DateTime: TDateTime read FDateTime write FDateTime;
+    property DocumentName: string read FDocumentName write FDocumentName;
+    property HostComputer: string read FHostComputer write FHostComputer;
+    property ImageDescription: string read FImageDescription write FImageDescription;
+//    property ImageIsMask: Boolean;
+//    property ImageIsPage: Boolean;
+//    property ImageIsThumbNail: Boolean;
+    property Make: string read FMake write FMake;
+    property Model: string read FModel write FModel;
+    property ResolutionUnit: TTiffUnit read FResolutionUnit write FResolutionUnit;
+    property Software: string read FSoftware write FSoftware;
+    property XResolution: TTiffRational read FXResolution write FXResolution;
+    property YResolution: TTiffRational read FYResolution write FYResolution;
+  end;
+
+
 function GraphicFilter(GraphicClass: TGraphicClass): string;
 function GraphicExtension(GraphicClass: TGraphicClass): string;
 function GraphicFileMask(GraphicClass: TGraphicClass): string;
@@ -2494,6 +2553,7 @@ end;
 {$I icnsicon.inc}
 {$I fpimagebitmap.inc}
 {$I bitmap.inc}
+{$I tiffimage.inc}
 
 function LocalGetSystemFont: HFont;
 begin

lcl/include/picture.inc

@@ -56,6 +56,7 @@ begin
   Add(TIcnsIcon.GetFileExtensions, rsIcns, TIcnsIcon);
   Add(TCursorImage.GetFileExtensions, rsCursor, TCursorImage);
   Add(TJpegImage.GetFileExtensions, rsJpeg, TJpegImage);
+  Add(TTiffImage.GetFileExtensions, rsTiff, TTiffImage);
 end;
 
 procedure TPicFileFormatsList.Clear;

lcl/include/tiffimage.inc

@@ -0,0 +1,153 @@
+{%MainUnit ../graphics.pp}
+
+{******************************************************************************
+                                TTiffImage
+ ******************************************************************************
+
+ *****************************************************************************
+ *                                                                           *
+ *  This file is part of the Lazarus Component Library (LCL)                 *
+ *                                                                           *
+ *  See the file COPYING.modifiedLGPL.txt, 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.                     *
+ *                                                                           *
+ *****************************************************************************
+}
+
+{ TTiffImage }
+
+constructor TTiffImage.Create;
+begin
+  inherited Create;
+  FSoftware := 'TTiffImage - Lazarus LCL: ' + lcl_version + ' - FPC: ' + {$I %FPCVERSION%};
+end;
+
+procedure TTiffImage.FinalizeReader(AReader: TFPCustomImageReader);
+var
+  D, T: TDateTime;
+  S: String;
+  YY, MM, DD, HH, NN, SS: Integer;
+begin
+  FArtist := TFPReaderTiff(AReader).FirstImg.Artist;
+  FCopyright := TFPReaderTiff(AReader).FirstImg.Copyright;
+
+  S := TFPReaderTiff(AReader).FirstImg.DateAndTime;
+  // YYYY:MM:DD HH:MM:SS
+  // 0000000001111111111
+  // 1234567890123456789
+  if  TryStrToInt(Copy(S, 1, 4), YY)
+  and TryStrToInt(Copy(S, 6, 2), MM)
+  and TryStrToInt(Copy(S, 9, 2), DD)
+  and TryStrToInt(Copy(S, 12, 2), HH)
+  and TryStrToInt(Copy(S, 15, 2), NN)
+  and TryStrToInt(Copy(S, 18, 2), SS)
+  and TryEncodeDate(YY, MM, DD, D)
+  and TryEncodeTime(HH, NN, SS, 0, T)
+  then FDateTime := D + T
+  else FDateTime := 0;
+
+  FDocumentName := TFPReaderTiff(AReader).FirstImg.DocumentName;
+  FHostComputer := TFPReaderTiff(AReader).FirstImg.HostComputer;
+  FImageDescription := TFPReaderTiff(AReader).FirstImg.ImageDescription;
+  FMake := TFPReaderTiff(AReader).FirstImg.Make_ScannerManufacturer;
+  FModel := TFPReaderTiff(AReader).FirstImg.Model_Scanner;
+  case TFPReaderTiff(AReader).FirstImg.ResolutionUnit of
+    1: FResolutionUnit := tuNone;
+    2: FResolutionUnit := tuInch;
+    3: FResolutionUnit := tuCentimeter;
+  else
+    FResolutionUnit := tuUnknown;
+  end;
+  FSoftware := TFPReaderTiff(AReader).FirstImg.Software;
+  FXResolution := TFPReaderTiff(AReader).FirstImg.XResolution;
+  FYResolution := TFPReaderTiff(AReader).FirstImg.YResolution;
+  inherited;
+end;
+
+class function TTiffImage.GetFileExtensions: string;
+begin
+  Result := 'tif;tiff';
+end;
+
+class function TTiffImage.GetReaderClass: TFPCustomImageReaderClass;
+begin
+  Result := TLazReaderTiff;
+end;
+
+class function TTiffImage.GetSharedImageClass: TSharedRasterImageClass;
+begin
+  Result := TSharedTiffImage;
+end;
+
+class function TTiffImage.GetWriterClass: TFPCustomImageWriterClass;
+begin
+  Result := TLazWriterTiff;
+end;
+
+procedure TTiffImage.InitializeReader(AImage: TLazIntfImage; AReader: TFPCustomImageReader);
+begin
+  inherited;
+end;
+
+procedure TTiffImage.InitializeWriter(AImage: TLazIntfImage; AWriter: TFPCustomImageWriter);
+begin
+  inherited;
+
+  if FArtist = ''
+  then AImage.RemoveExtra(TiffArtist)
+  else AImage.Extra[TiffArtist] := FArtist;
+
+  if FCopyright = ''
+  then AImage.RemoveExtra(TiffCopyright)
+  else AImage.Extra[TiffCopyright] := FCopyright;
+
+  if FDateTime = 0
+  then AImage.RemoveExtra(TiffDateTime)
+  else AImage.Extra[TiffDateTime] := FormatDateTime('YYYY:MM:DD HH:NN:SS', FDateTime);
+
+  if FDocumentName = ''
+  then AImage.RemoveExtra(TiffDocumentName)
+  else AImage.Extra[TiffDocumentName] := FDocumentName;
+
+  if FImageDescription = ''
+  then AImage.RemoveExtra(TiffImageDescription)
+  else AImage.Extra[TiffImageDescription] := FImageDescription;
+
+  case FResolutionUnit of
+    tuNone: AImage.Extra[TiffResolutionUnit] := '1';
+    tuInch: AImage.Extra[TiffResolutionUnit] := '2';
+    tuCentimeter: AImage.Extra[TiffResolutionUnit] := '3';
+  else
+    AImage.RemoveExtra(TiffResolutionUnit);
+  end;
+
+  if (FXResolution.Denominator = 0) and (FXResolution.Numerator = 0)
+  then AImage.RemoveExtra(TiffXResolution)
+  else AImage.Extra[TiffXResolution] := TiffRationalToStr(FXResolution);
+
+  if (FYResolution.Denominator = 0) and (FYResolution.Numerator = 0)
+  then AImage.RemoveExtra(TiffYResolution)
+  else AImage.Extra[TiffYResolution] := TiffRationalToStr(FYResolution);
+
+  if FHostComputer = ''
+  then AImage.RemoveExtra(LazTiffHostComputer)
+  else AImage.Extra[LazTiffHostComputer] := FHostComputer;
+
+  if FMake = ''
+  then AImage.RemoveExtra(LazTiffMake)
+  else AImage.Extra[LazTiffMake] := FMake;
+
+  if FModel = ''
+  then AImage.RemoveExtra(LazTiffModel)
+  else AImage.Extra[LazTiffModel] := FModel;
+
+  if FSoftware = ''
+  then AImage.RemoveExtra(LazTiffSoftware)
+  else AImage.Extra[LazTiffSoftware] := FSoftware;
+
+end;
+

lcl/intfgraphics.pas

@@ -32,8 +32,9 @@ interface
 
 uses
   Classes, SysUtils, fpImage, FPReadBMP, FPWriteBMP, BMPComn, FPCAdds,
-  AvgLvlTree, LCLType,
-  LCLProc, GraphType, LCLIntf, FPReadPNG, FPWritePNG, IcnsTypes;
+  AvgLvlTree, LCLType, LCLversion,
+  LCLProc, GraphType, LCLIntf, FPReadPNG, FPWritePNG, FPReadTiff, FPWriteTiff,
+  IcnsTypes;
 
 type
   { TLazIntfImage }
@@ -579,6 +580,51 @@ type
     procedure Finalize;
   end;
 
+  { TLazReaderTiff }
+
+const
+  LazTiffExtraPrefix = 'LazTiff';
+  LazTiffHostComputer = LazTiffExtraPrefix + 'HostComputer';
+  LazTiffMake = LazTiffExtraPrefix + 'Make';
+  LazTiffModel = LazTiffExtraPrefix + 'Model';
+  LazTiffSoftware = LazTiffExtraPrefix + 'Software';
+
+type
+  TLazReaderTiff = class(TFPReaderTiff, ILazImageReader)
+  private
+    FUpdateDescription: Boolean;
+    // the OnCreateImage event is "abused" to update the description after the
+    // format and before the image is read
+    FOrgEvent: TTiffCreateCompatibleImgEvent;
+    function  GetUpdateDescription: Boolean;
+    procedure SetUpdateDescription(AValue: Boolean);
+    procedure CreateImageHook(Sender: TFPReaderTiff; var NewImage: TFPCustomImage);
+  protected
+    function QueryInterface(const iid: TGuid; out obj): LongInt; stdcall;
+    function _AddRef: LongInt; stdcall;
+    function _Release: LongInt; stdcall;
+  protected
+    procedure InternalRead(Str:TStream; Img:TFPCustomImage); override;
+  public
+    property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription;
+  end;
+
+  { TLazWriterTiff }
+
+  TLazWriterTiff = class(TFPWriterTiff, ILazImageWriter)
+  private
+  protected
+    function QueryInterface(const iid: TGuid; out obj): LongInt; stdcall;
+    function _AddRef: LongInt; stdcall;
+    function _Release: LongInt; stdcall;
+  protected
+    procedure InternalWrite(Stream: TStream; Img: TFPCustomImage); override;
+  public
+    procedure Initialize(AImage: TLazIntfImage);
+    procedure Finalize;
+  end;
+
+
   { TLazReaderIcnsPart }
 
   TLazReaderIcnsPart = class(TFPCustomImageReader, ILazImageReader)
@@ -5676,6 +5722,161 @@ begin
   Result := -1;
 end;
 
+{ TLazReaderTiff }
+
+procedure TLazReaderTiff.CreateImageHook(Sender: TFPReaderTiff; var NewImage: TFPCustomImage);
+var
+  Desc: TRawImageDescription;
+  IsAlpha, IsGray: Boolean;
+begin
+  if Assigned(FOrgEvent) then FOrgEvent(Sender, NewImage);
+
+  if not FUpdateDescription then Exit;
+  if not (theImage is TLazIntfImage) then Exit;
+
+  // init some default
+
+  IsGray := FirstImg.PhotoMetricInterpretation in [0, 1];
+  IsAlpha := FirstImg.AlphaBits <> 0;
+
+  if IsAlpha
+  then Desc.Init_BPP32_B8G8R8A8_BIO_TTB(FirstImg.ImageWidth, FirstImg.ImageHeight)
+  else Desc.Init_BPP24_B8G8R8_BIO_TTB(FirstImg.ImageWidth, FirstImg.ImageHeight);
+
+  if IsGray
+  then Desc.Format := ricfGray;
+
+  // check mask
+  if FirstImg.PhotoMetricInterpretation = 4
+  then begin
+    // todo: mask
+  end
+  else
+  // check palette
+  if FirstImg.PhotoMetricInterpretation = 3
+  then begin
+    // todo: palette
+  end
+  else begin
+    // no palette, adjust description
+    if IsGray
+    then begin
+      if IsAlpha
+      then begin
+        Desc.Depth := FirstImg.GrayBits + FirstImg.AlphaBits;
+      end
+      else begin
+        Desc.Depth := FirstImg.GrayBits;
+        Desc.BitsPerPixel := FirstImg.GrayBits;
+      end;
+      Desc.RedPrec := FirstImg.GrayBits;
+      Desc.RedShift := 0;
+    end
+    else begin
+      Desc.Depth := FirstImg.RedBits + FirstImg.GreenBits + FirstImg.BlueBits + FirstImg.AlphaBits;
+      if Desc.Depth > 32
+      then begin
+        // switch to 64bit description
+        Desc.BitsPerPixel := Desc.BitsPerPixel * 2;
+        Desc.RedPrec := 16;
+        Desc.RedShift := Desc.RedShift * 2;
+        Desc.GreenPrec := 16;
+        Desc.GreenShift := Desc.GreenShift * 2;
+        Desc.BluePrec := 16;
+        Desc.BlueShift := Desc.BlueShift * 2;
+        Desc.AlphaPrec := Desc.AlphaPrec * 2; // might be zero
+        Desc.AlphaShift := Desc.AlphaShift * 2;
+      end;
+    end;
+  end;
+
+  TLazIntfImage(theImage).DataDescription := Desc;
+end;
+
+function TLazReaderTiff.GetUpdateDescription: Boolean;
+begin
+  Result := FUpdateDescription;
+end;
+
+procedure TLazReaderTiff.InternalRead(Str: TStream; Img: TFPCustomImage);
+begin
+  FOrgEvent := OnCreateImage;
+  OnCreateImage := @CreateImageHook;
+  inherited InternalRead(Str, Img);
+  OnCreateImage := FOrgEvent;
+  FOrgEvent := nil;
+end;
+
+function TLazReaderTiff.QueryInterface(const iid: TGuid; out obj): LongInt; stdcall;
+begin
+  if GetInterface(iid, obj)
+  then Result := S_OK
+  else Result := E_NOINTERFACE;
+end;
+
+procedure TLazReaderTiff.SetUpdateDescription(AValue: Boolean);
+begin
+  FUpdateDescription := AValue;
+end;
+
+function TLazReaderTiff._AddRef: LongInt; stdcall;
+begin
+  Result := -1;
+end;
+
+function TLazReaderTiff._Release: LongInt; stdcall;
+begin
+  Result := -1;
+end;
+
+{ TLazWriterTiff }
+
+procedure TLazWriterTiff.Finalize;
+begin
+end;
+
+procedure TLazWriterTiff.Initialize(AImage: TLazIntfImage);
+begin
+  AImage.Extra[LazTiffSoftware] := 'TLazWriterTiff - Lazarus LCL: ' + lcl_version + ' - FPC: ' + {$I %FPCVERSION%};
+end;
+
+procedure TLazWriterTiff.InternalWrite(Stream: TStream; Img: TFPCustomImage);
+var
+  S: String;
+begin
+  AddImage(Img);
+
+  //add additional elements
+
+  S := Img.Extra[LazTiffHostComputer];
+  if S <> '' then AddEntryString(316, S);
+  S := Img.Extra[LazTiffMake];
+  if S <> '' then AddEntryString(271, S);
+  S := Img.Extra[LazTiffModel];
+  if S <> '' then AddEntryString(272, S);
+  S := Img.Extra[LazTiffSoftware];
+  if S <> '' then AddEntryString(305, S);
+
+  SaveToStream(Stream);
+end;
+
+function TLazWriterTiff.QueryInterface(const iid: TGuid; out obj): LongInt; stdcall;
+begin
+  if GetInterface(iid, obj)
+  then Result := S_OK
+  else Result := E_NOINTERFACE;
+end;
+
+function TLazWriterTiff._AddRef: LongInt; stdcall;
+begin
+  Result := -1;
+end;
+
+function TLazWriterTiff._Release: LongInt; stdcall;
+begin
+  Result := -1;
+end;
+
 { TLazReaderIcnsPart }
 
 function TLazReaderIcnsPart.InternalCheck(Str: TStream): boolean;

lcl/lclstrconsts.pas

@@ -205,6 +205,7 @@ resourceString
   rsIcns = 'OSX Icon Resource';
   rsCursor = 'Cursor';
   rsJpeg = 'Joint Picture Expert Group';
+  rsTiff = 'Tagged Image File Format';
   rsUnsupportedClipboardFormat = 'Unsupported clipboard format: %s';
   rsGroupIndexCannotBeLessThanPrevious = 'GroupIndex cannot be less than a '
     +'previous menu item''s GroupIndex';