ImagingTiffLib.pas 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668
  1. {
  2. Vampyre Imaging Library
  3. by Marek Mauder
  4. http://imaginglib.sourceforge.net
  5. The contents of this file are used with permission, subject to the Mozilla
  6. Public License Version 1.1 (the "License"); you may not use this file except
  7. in compliance with the License. You may obtain a copy of the License at
  8. http://www.mozilla.org/MPL/MPL-1.1.html
  9. Software distributed under the License is distributed on an "AS IS" basis,
  10. WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  11. the specific language governing rights and limitations under the License.
  12. Alternatively, the contents of this file may be used under the terms of the
  13. GNU Lesser General Public License (the "LGPL License"), in which case the
  14. provisions of the LGPL License are applicable instead of those above.
  15. If you wish to allow use of your version of this file only under the terms
  16. of the LGPL License and not to allow others to use your version of this file
  17. under the MPL, indicate your decision by deleting the provisions above and
  18. replace them with the notice and other provisions required by the LGPL
  19. License. If you do not delete the provisions above, a recipient may use
  20. your version of this file under either the MPL or the LGPL License.
  21. For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
  22. }
  23. { This unit contains image format loader/saver for TIFF images
  24. using LibTiff C library compiled to object files or LibTiff DLL/SO.
  25. Supported platforms/compilers are now:
  26. Win32 Delphi: obj, dll
  27. Win64 Delphi: dll
  28. Win32, Win64 FPC: obj, dll
  29. Linux/Unix/macOS 32/64 FPC: dll
  30. }
  31. unit ImagingTiffLib;
  32. {$I ImagingOptions.inc}
  33. {$IF Defined(LINUX) or Defined(BSD) or Defined(MACOS)}
  34. // Use LibTiff dynamic library in Linux/BSD instead of precompiled objects.
  35. // It's installed on most systems so let's use it and keep the binary smaller.
  36. // In macOS it's usually not installed but if it is let's use it.
  37. {$DEFINE USE_DYN_LIB}
  38. {$IFEND}
  39. {$IF Defined(DCC) and Defined(WIN64)}
  40. // For Delphi Win64 target try to use LibTiff dynamic library.
  41. {$DEFINE USE_DYN_LIB}
  42. {$IFEND}
  43. {$IF Defined(POSIX) and Defined(CPUX64)}
  44. // Workaround for problem on 64bit Linux where thandle_t in libtiff is
  45. // still 32bit so it cannot be used to pass pointers (for IO functions).
  46. {$DEFINE HANDLE_NOT_POINTER_SIZED}
  47. {$IFEND}
  48. {.$DEFINE USE_DYN_LIB}
  49. interface
  50. uses
  51. SysUtils, Imaging, ImagingTypes, ImagingUtility, ImagingIO,
  52. ImagingTiff,
  53. {$IFDEF USE_DYN_LIB}
  54. LibTiffDynLib;
  55. {$ELSE}
  56. LibTiffDelphi;
  57. {$ENDIF}
  58. type
  59. { TIFF (Tag Image File Format) loader/saver class. Uses LibTiff so
  60. it can handle most types of TIFF files.}
  61. TTiffLibFileFormat = class(TBaseTiffFileFormat)
  62. protected
  63. procedure Define; override;
  64. function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
  65. OnlyFirstLevel: Boolean): Boolean; override;
  66. function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
  67. Index: Integer): Boolean; override;
  68. procedure ConvertToSupported(var Image: TImageData;
  69. const Info: TImageFormatInfo); override;
  70. end;
  71. implementation
  72. const
  73. TiffSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8,
  74. ifGray16, ifA16Gray16, ifGray32, ifR8G8B8, ifA8R8G8B8, ifR16G16B16,
  75. ifA16R16G16B16, ifR32F, ifA32R32G32B32F, ifR16F, ifA16R16G16B16F, ifBinary];
  76. type
  77. TTiffIOWrapper = record
  78. IO: TIOFunctions;
  79. Handle: TImagingHandle;
  80. end;
  81. PTiffIOWrapper = ^TTiffIOWrapper;
  82. {$IFDEF HANDLE_NOT_POINTER_SIZED}
  83. var
  84. TiffIOWrapper: TTiffIOWrapper;
  85. {$ENDIF}
  86. function GetTiffIOWrapper(Fd: THandle): PTiffIOWrapper;
  87. begin
  88. {$IFDEF HANDLE_NOT_POINTER_SIZED}
  89. Result := @TiffIOWrapper;
  90. {$ELSE}
  91. Result := PTiffIOWrapper(Fd);
  92. {$ENDIF}
  93. end;
  94. function TIFFReadProc(Fd: THandle; Buffer: Pointer; Size: Integer): Integer; cdecl;
  95. var
  96. Wrapper: PTiffIOWrapper;
  97. begin
  98. Wrapper := GetTiffIOWrapper(Fd);
  99. Result := Wrapper.IO.Read(Wrapper.Handle, Buffer, Size);
  100. end;
  101. function TIFFWriteProc(Fd: THandle; Buffer: Pointer; Size: Integer): Integer; cdecl;
  102. var
  103. Wrapper: PTiffIOWrapper;
  104. begin
  105. Wrapper := GetTiffIOWrapper(Fd);
  106. Result := Wrapper.IO.Write(Wrapper.Handle, Buffer, Size);
  107. end;
  108. function TIFFSizeProc(Fd: THandle): toff_t; cdecl;
  109. var
  110. Wrapper: PTiffIOWrapper;
  111. begin
  112. Wrapper := GetTiffIOWrapper(Fd);
  113. Result := ImagingIO.GetInputSize(Wrapper.IO, Wrapper.Handle);
  114. end;
  115. function TIFFSeekProc(Fd: THandle; Offset: toff_t; Where: Integer): toff_t; cdecl;
  116. const
  117. SEEK_SET = 0;
  118. SEEK_CUR = 1;
  119. SEEK_END = 2;
  120. var
  121. Mode: TSeekMode;
  122. Wrapper: PTiffIOWrapper;
  123. begin
  124. Wrapper := GetTiffIOWrapper(Fd);
  125. if Offset = $FFFFFFFF then
  126. begin
  127. Result := $FFFFFFFF;
  128. Exit;
  129. end;
  130. case Where of
  131. SEEK_SET: Mode := smFromBeginning;
  132. SEEK_CUR: Mode := smFromCurrent;
  133. SEEK_END: Mode := smFromEnd;
  134. else
  135. Mode := smFromBeginning;
  136. end;
  137. Result := Wrapper.IO.Seek(Wrapper.Handle, Offset, Mode);
  138. end;
  139. function TIFFCloseProc(Fd: THandle): Integer; cdecl;
  140. begin
  141. Result := 0;
  142. end;
  143. function TIFFNoMapProc(Fd: THandle; Base: PPointer; Size: PCardinal): Integer; cdecl;
  144. begin
  145. Result := 0;
  146. end;
  147. procedure TIFFNoUnmapProc(Fd: THandle; Base: Pointer; Size: Cardinal); cdecl;
  148. begin
  149. end;
  150. var
  151. LastError: string = 'None';
  152. procedure TIFFErrorHandler(const Module, Message: AnsiString);
  153. begin
  154. LastError := string(Module + ': ' + Message);
  155. end;
  156. {
  157. TTiffFileFormat implementation
  158. }
  159. procedure TTiffLibFileFormat.Define;
  160. begin
  161. inherited;
  162. FFeatures := [ffLoad, ffSave, ffMultiImage];
  163. FSupportedFormats := TiffSupportedFormats;
  164. end;
  165. function TTiffLibFileFormat.LoadData(Handle: TImagingHandle;
  166. var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
  167. var
  168. Tiff: PTIFF;
  169. IOWrapper: TTiffIOWrapper;
  170. I, Idx, TiffResult, ScanLineSize, NumDirectories, X: Integer;
  171. RowsPerStrip: UInt32;
  172. Orientation, BitsPerSample, SamplesPerPixel, Photometric,
  173. PlanarConfig, SampleFormat: Word;
  174. DataFormat: TImageFormat;
  175. CanAccessScanlines: Boolean;
  176. Ptr: PByte;
  177. Red, Green, Blue: PWordRecArray;
  178. procedure LoadMetadata(Tiff: PTiff; TiffPage: Integer);
  179. var
  180. TiffResUnit, CompressionScheme: Word;
  181. XRes, YRes: Single;
  182. ResUnit: TResolutionUnit;
  183. CompressionName: string;
  184. begin
  185. TIFFGetFieldDefaulted(Tiff, TIFFTAG_RESOLUTIONUNIT, @TiffResUnit);
  186. TIFFGetFieldDefaulted(Tiff, TIFFTAG_XRESOLUTION, @XRes);
  187. TIFFGetFieldDefaulted(Tiff, TIFFTAG_YRESOLUTION, @YRes);
  188. TIFFGetFieldDefaulted(Tiff, TIFFTAG_COMPRESSION, @CompressionScheme);
  189. FMetadata.SetMetaItem(SMetaTiffResolutionUnit, TiffResUnit);
  190. if (TiffResUnit <> RESUNIT_NONE) and (XRes >= 0.1) and (YRes >= 0.1) then
  191. begin
  192. ResUnit := ruDpi;
  193. if TiffResUnit = RESUNIT_CENTIMETER then
  194. ResUnit := ruDpcm;
  195. FMetadata.SetPhysicalPixelSize(ResUnit, XRes, YRes, False, TiffPage);
  196. end;
  197. case CompressionScheme of
  198. COMPRESSION_NONE: CompressionName := 'None';
  199. COMPRESSION_LZW: CompressionName := 'LZW';
  200. COMPRESSION_JPEG: CompressionName := 'JPEG';
  201. COMPRESSION_PACKBITS: CompressionName := 'Packbits RLE';
  202. COMPRESSION_DEFLATE: CompressionName := 'Deflate';
  203. COMPRESSION_CCITTFAX4: CompressionName := 'CCITT Group 4 Fax';
  204. COMPRESSION_OJPEG: CompressionName := 'Old JPEG';
  205. COMPRESSION_CCITTRLE..COMPRESSION_CCITTFAX3: CompressionName := 'CCITT';
  206. else
  207. CompressionName := 'Unknown';
  208. end;
  209. FMetadata.SetMetaItem(SMetaTiffCompressionName, CompressionName);
  210. end;
  211. begin
  212. Result := False;
  213. SetUserMessageHandlers(TIFFErrorHandler, nil);
  214. // Set up IO wrapper and open TIFF
  215. IOWrapper.IO := GetIO;
  216. IOWrapper.Handle := Handle;
  217. {$IFDEF HANDLE_NOT_POINTER_SIZED}
  218. TiffIOWrapper := IOWrapper;
  219. {$ENDIF}
  220. Tiff := TIFFClientOpen('LibTIFF', 'r', THandle(@IOWrapper), @TIFFReadProc,
  221. @TIFFWriteProc, @TIFFSeekProc, @TIFFCloseProc,
  222. @TIFFSizeProc, @TIFFNoMapProc, @TIFFNoUnmapProc);
  223. if Tiff <> nil then
  224. TIFFSetFileNo(Tiff, THandle(@IOWrapper))
  225. else
  226. Exit;
  227. NumDirectories := TIFFNumberOfDirectories(Tiff);
  228. if OnlyFirstLevel then
  229. NumDirectories := Min(1, NumDirectories);
  230. SetLength(Images, NumDirectories);
  231. for Idx := 0 to NumDirectories - 1 do
  232. begin
  233. TIFFSetDirectory(Tiff, Idx);
  234. // Set defaults for TIFF fields
  235. DataFormat := ifUnknown;
  236. // Read some TIFF fields with basic image info
  237. TIFFGetField(Tiff, TIFFTAG_IMAGEWIDTH, @Images[Idx].Width);
  238. TIFFGetField(Tiff, TIFFTAG_IMAGELENGTH, @Images[Idx].Height);
  239. TIFFGetFieldDefaulted(Tiff, TIFFTAG_ORIENTATION, @Orientation);
  240. TIFFGetFieldDefaulted(Tiff, TIFFTAG_BITSPERSAMPLE, @BitsPerSample);
  241. TIFFGetFieldDefaulted(Tiff, TIFFTAG_SAMPLESPERPIXEL, @SamplesPerPixel);
  242. TIFFGetFieldDefaulted(Tiff, TIFFTAG_SAMPLEFORMAT, @SampleFormat);
  243. TIFFGetFieldDefaulted(Tiff, TIFFTAG_PHOTOMETRIC, @Photometric);
  244. TIFFGetFieldDefaulted(Tiff, TIFFTAG_PLANARCONFIG, @PlanarConfig);
  245. TIFFGetFieldDefaulted(Tiff, TIFFTAG_ROWSPERSTRIP, @RowsPerStrip);
  246. // Load supported metadata
  247. LoadMetadata(Tiff, Idx);
  248. // See if we can just copy scanlines from TIFF to Imaging image
  249. CanAccessScanlines := (PlanarConfig = PLANARCONFIG_CONTIG) or (SamplesPerPixel = 1);
  250. if CanAccessScanlines then
  251. begin
  252. // We can copy scanlines so we try to find data format that best matches
  253. // TIFFs internal data format
  254. if (Photometric = PHOTOMETRIC_MINISBLACK) or (Photometric = PHOTOMETRIC_MINISWHITE) then
  255. begin
  256. if SampleFormat = SAMPLEFORMAT_UINT then
  257. begin
  258. case BitsPerSample of
  259. 1:
  260. if SamplesPerPixel = 1 then
  261. DataFormat := ifBinary;
  262. 8:
  263. case SamplesPerPixel of
  264. 1: DataFormat := ifGray8;
  265. 2: DataFormat := ifA8Gray8;
  266. end;
  267. 16:
  268. case SamplesPerPixel of
  269. 1: DataFormat := ifGray16;
  270. 2: DataFormat := ifA16Gray16;
  271. end;
  272. 32:
  273. if SamplesPerPixel = 1 then
  274. DataFormat := ifGray32;
  275. end;
  276. end
  277. else if SampleFormat = SAMPLEFORMAT_IEEEFP then
  278. begin
  279. case BitsPerSample of
  280. 16:
  281. if SamplesPerPixel = 1 then
  282. DataFormat := ifR16F;
  283. 32:
  284. if SamplesPerPixel = 1 then
  285. DataFormat := ifR32F;
  286. end;
  287. end;
  288. end
  289. else if Photometric = PHOTOMETRIC_RGB then
  290. begin
  291. if SampleFormat = SAMPLEFORMAT_UINT then
  292. begin
  293. case BitsPerSample of
  294. 8:
  295. case SamplesPerPixel of
  296. 3: DataFormat := ifR8G8B8;
  297. 4: DataFormat := ifA8R8G8B8;
  298. end;
  299. 16:
  300. case SamplesPerPixel of
  301. 3: DataFormat := ifR16G16B16;
  302. 4: DataFormat := ifA16R16G16B16;
  303. end;
  304. end;
  305. end
  306. else if SampleFormat = SAMPLEFORMAT_IEEEFP then
  307. begin
  308. case BitsPerSample of
  309. 16:
  310. if SamplesPerPixel = 4 then
  311. DataFormat := ifA16R16G16B16F;
  312. 32:
  313. if SamplesPerPixel = 4 then
  314. DataFormat := ifA32R32G32B32F;
  315. end;
  316. end;
  317. end
  318. else if Photometric = PHOTOMETRIC_PALETTE then
  319. begin
  320. if (SamplesPerPixel = 1) and (SampleFormat = SAMPLEFORMAT_UINT) and (BitsPerSample = 8) then
  321. DataFormat := ifIndex8
  322. end;
  323. end;
  324. if DataFormat = ifUnknown then
  325. begin
  326. // Use RGBA interface to read A8R8G8B8 TIFFs and mainly TIFFs in various
  327. // formats with no Imaging equivalent, exotic color spaces etc.
  328. NewImage(Images[Idx].Width, Images[Idx].Height, ifA8R8G8B8, Images[Idx]);
  329. TiffResult := TIFFReadRGBAImageOriented(Tiff, Images[Idx].Width, Images[Idx].Height,
  330. Images[Idx].Bits, Orientation, 0);
  331. if TiffResult = 0 then
  332. RaiseImaging(LastError, []);
  333. // Swap Red and Blue, if YCbCr.
  334. if Photometric=PHOTOMETRIC_YCBCR then
  335. SwapChannels(Images[Idx], ChannelRed, ChannelBlue);
  336. end
  337. else
  338. begin
  339. // Create new image in given format and read scanlines from TIFF,
  340. // read palette too if needed
  341. NewImage(Images[Idx].Width, Images[Idx].Height, DataFormat, Images[Idx]);
  342. ScanLineSize := TIFFScanlineSize(Tiff);
  343. for I := 0 to Images[Idx].Height - 1 do
  344. TIFFReadScanline(Tiff, @PByteArray(Images[Idx].Bits)[I * ScanLineSize], I, 0);
  345. if DataFormat = ifIndex8 then
  346. begin
  347. TIFFGetField(Tiff, TIFFTAG_COLORMAP, @Red, @Green, @Blue);
  348. for I := 0 to 255 do
  349. with Images[Idx].Palette[I] do
  350. begin
  351. A := 255;
  352. R := Red[I].High;
  353. G := Green[I].High;
  354. B := Blue[I].High;
  355. end;
  356. end;
  357. // TIFF uses BGR order so we must swap it (but not images we got
  358. // from TiffLib RGBA interface)
  359. if Photometric = PHOTOMETRIC_RGB then
  360. SwapChannels(Images[Idx], ChannelRed, ChannelBlue);
  361. // We need to negate 'MinIsWhite' formats to get common grayscale
  362. // formats where min sample value is black
  363. if Photometric = PHOTOMETRIC_MINISWHITE then
  364. for I := 0 to Images[Idx].Height - 1 do
  365. begin
  366. Ptr := @PByteArray(Images[Idx].Bits)[I * ScanLineSize];
  367. for X := 0 to ScanLineSize - 1 do
  368. begin
  369. Ptr^ := not Ptr^;
  370. Inc(Ptr);
  371. end;
  372. end;
  373. end;
  374. end;
  375. TIFFClose(Tiff);
  376. Result := True;
  377. end;
  378. function TTiffLibFileFormat.SaveData(Handle: TImagingHandle;
  379. const Images: TDynImageDataArray; Index: Integer): Boolean;
  380. const
  381. Compressions: array[0..5] of Word = (COMPRESSION_NONE, COMPRESSION_LZW,
  382. COMPRESSION_PACKBITS, COMPRESSION_DEFLATE, COMPRESSION_JPEG, COMPRESSION_CCITTFAX4);
  383. var
  384. Tiff: PTIFF;
  385. IOWrapper: TTiffIOWrapper;
  386. I, J, ScanLineSize: Integer;
  387. ImageToSave: TImageData;
  388. MustBeFreed: Boolean;
  389. Info: TImageFormatInfo;
  390. Orientation, BitsPerSample, SamplesPerPixel, Photometric,
  391. PlanarConfig, SampleFormat, CompressionScheme: Word;
  392. RowsPerStrip: UInt32;
  393. Red, Green, Blue: array[Byte] of TWordRec;
  394. CompressionMismatch: Boolean;
  395. OpenMode: PAnsiChar;
  396. procedure SaveMetadata(Tiff: PTiff; TiffPage: Integer);
  397. var
  398. XRes, YRes: Single;
  399. ResUnit: TResolutionUnit;
  400. TiffResUnit, StoredTiffResUnit: Word;
  401. begin
  402. XRes := -1;
  403. YRes := -1;
  404. ResUnit := ruDpcm;
  405. TiffResUnit := RESUNIT_CENTIMETER;
  406. if FMetadata.HasMetaItemForSaving(SMetaTiffResolutionUnit) then
  407. begin
  408. // Check if DPI resolution unit is requested to be used (e.g. to
  409. // use the same unit when just resaving files - also some )
  410. StoredTiffResUnit := FMetadata.MetaItemsForSaving[SMetaTiffResolutionUnit];
  411. if StoredTiffResUnit = RESUNIT_INCH then
  412. begin
  413. ResUnit := ruDpi;
  414. TiffResUnit := RESUNIT_INCH;
  415. end;
  416. end;
  417. // First try to find phys. size for current TIFF page index. If not found then
  418. // try size for main image (index 0).
  419. if not FMetadata.GetPhysicalPixelSize(ResUnit, XRes, YRes, True, TiffPage) then
  420. FMetadata.GetPhysicalPixelSize(ResUnit, XRes, YRes, True, 0);
  421. if (XRes > 0) and (YRes > 0) then
  422. begin
  423. TIFFSetField(Tiff, TIFFTAG_RESOLUTIONUNIT, TiffResUnit);
  424. TIFFSetField(Tiff, TIFFTAG_XRESOLUTION, XRes);
  425. TIFFSetField(Tiff, TIFFTAG_YRESOLUTION, YRes);
  426. end;
  427. end;
  428. begin
  429. Result := False;
  430. SetUserMessageHandlers(TIFFErrorHandler, nil);
  431. if not (FCompression in [0..5]) then
  432. FCompression := COMPRESSION_LZW;
  433. // Set up IO wrapper and open TIFF
  434. IOWrapper.IO := GetIO;
  435. IOWrapper.Handle := Handle;
  436. {$IFDEF HANDLE_NOT_POINTER_SIZED}
  437. TiffIOWrapper := IOWrapper;
  438. {$ENDIF}
  439. OpenMode := 'w';
  440. Tiff := TIFFClientOpen('LibTIFF', OpenMode, THandle(@IOWrapper), @TIFFReadProc,
  441. @TIFFWriteProc, @TIFFSeekProc, @TIFFCloseProc,
  442. @TIFFSizeProc, @TIFFNoMapProc, @TIFFNoUnmapProc);
  443. if Tiff <> nil then
  444. TIFFSetFileNo(Tiff, THandle(@IOWrapper))
  445. else
  446. Exit;
  447. for I := FFirstIdx to FLastIdx do
  448. begin
  449. if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
  450. with GetIO, ImageToSave do
  451. try
  452. GetImageFormatInfo(Format, Info);
  453. // Set Tag values
  454. Orientation := ORIENTATION_TOPLEFT;
  455. BitsPerSample := Info.BytesPerPixel div Info.ChannelCount * 8;
  456. if Info.Format = ifBinary then
  457. BitsPerSample := 1;
  458. SamplesPerPixel := Info.ChannelCount;
  459. SampleFormat := Iff(not Info.IsFloatingPoint, SAMPLEFORMAT_UINT, SAMPLEFORMAT_IEEEFP);
  460. PlanarConfig := PLANARCONFIG_CONTIG;
  461. CompressionScheme := Compressions[FCompression];
  462. // Check if selected compression scheme can be used for current image
  463. CompressionMismatch := (CompressionScheme = COMPRESSION_JPEG) and ((BitsPerSample <> 8) or
  464. not (SamplesPerPixel in [1, 3]) or Info.IsIndexed or Info.IsFloatingPoint);
  465. CompressionMismatch := CompressionMismatch or ((CompressionScheme = COMPRESSION_CCITTFAX4) and (Info.Format <> ifBinary));
  466. if CompressionMismatch then
  467. CompressionScheme := COMPRESSION_LZW;
  468. // If we have some compression scheme selected and it's not Fax then select it automatically - better comp ratios!
  469. if (Info.Format = ifBinary) and (CompressionScheme <> COMPRESSION_NONE) and (CompressionScheme <> COMPRESSION_CCITTFAX4) then
  470. CompressionScheme := COMPRESSION_CCITTFAX4;
  471. RowsPerStrip := TIFFDefaultStripSize(Tiff, Height);
  472. if Info.IsIndexed then
  473. Photometric := PHOTOMETRIC_PALETTE
  474. else if (Info.HasGrayChannel) or (Info.ChannelCount = 1) then
  475. Photometric := PHOTOMETRIC_MINISBLACK
  476. else
  477. Photometric := PHOTOMETRIC_RGB;
  478. // Write tags
  479. TIFFSetField(Tiff, TIFFTAG_IMAGEWIDTH, Width);
  480. TIFFSetField(Tiff, TIFFTAG_IMAGELENGTH, Height);
  481. TIFFSetField(Tiff, TIFFTAG_PHOTOMETRIC, Photometric);
  482. TIFFSetField(Tiff, TIFFTAG_PLANARCONFIG, PlanarConfig);
  483. TIFFSetField(Tiff, TIFFTAG_ORIENTATION, Orientation);
  484. TIFFSetField(Tiff, TIFFTAG_BITSPERSAMPLE, BitsPerSample);
  485. TIFFSetField(Tiff, TIFFTAG_SAMPLESPERPIXEL, SamplesPerPixel);
  486. TIFFSetField(Tiff, TIFFTAG_SAMPLEFORMAT, SampleFormat);
  487. TIFFSetField(Tiff, TIFFTAG_COMPRESSION, CompressionScheme);
  488. if CompressionScheme = COMPRESSION_JPEG then
  489. TIFFSetField(Tiff, TIFFTAG_JPEGQUALITY, FJpegQuality);
  490. TIFFSetField(Tiff, TIFFTAG_ROWSPERSTRIP, RowsPerStrip);
  491. // Save supported metadata
  492. SaveMetadata(Tiff, I);
  493. if Format = ifIndex8 then
  494. begin
  495. // Set paletee for indexed images
  496. for J := 0 to 255 do
  497. with ImageToSave.Palette[J] do
  498. begin
  499. Red[J].High := R;
  500. Green[J].High := G;
  501. Blue[J].High := B;
  502. end;
  503. TIFFSetField(Tiff, TIFFTAG_COLORMAP, @Red[0], @Green[0], @Blue[0]);
  504. end;
  505. ScanLineSize := Info.GetPixelsSize(Info.Format, Width, 1);
  506. if Photometric = PHOTOMETRIC_RGB then
  507. SwapChannels(ImageToSave, ChannelRed, ChannelBlue);
  508. // Write image scanlines and then directory for current image
  509. for J := 0 to Height - 1 do
  510. TIFFWriteScanline(Tiff, @PByteArray(Bits)[J * ScanLineSize], J, 0);
  511. if Info.ChannelCount > 1 then
  512. SwapChannels(ImageToSave, ChannelRed, ChannelBlue);
  513. TIFFWriteDirectory(Tiff);
  514. finally
  515. if MustBeFreed then
  516. FreeImage(ImageToSave);
  517. end;
  518. end;
  519. TIFFClose(Tiff);
  520. Result := True;
  521. end;
  522. procedure TTiffLibFileFormat.ConvertToSupported(var Image: TImageData;
  523. const Info: TImageFormatInfo);
  524. var
  525. ConvFormat: TImageFormat;
  526. begin
  527. if Info.RBSwapFormat in GetSupportedFormats then
  528. ConvFormat := Info.RBSwapFormat
  529. else if Info.IsFloatingPoint then
  530. ConvFormat := IffFormat(Info.ChannelCount = 1, ifR32F, ifA32R32G32B32F)
  531. else if Info.HasGrayChannel then
  532. ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16Gray16, ifGray32)
  533. else
  534. ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8);
  535. ConvertImage(Image, ConvFormat);
  536. end;
  537. initialization
  538. {$IFDEF USE_DYN_LIB}
  539. // If using dynamic library only register the format if
  540. // the library loads successfully.
  541. if LibTiffDynLib.LoadTiffLibrary then
  542. {$ENDIF}
  543. RegisterImageFileFormat(TTiffLibFileFormat);
  544. {
  545. File Notes:
  546. -- TODOS ----------------------------------------------------
  547. - nothing now
  548. -- 0.77.3 ----------------------------------------------------
  549. - Lot more platforms than just 32bit Delphi supported now.
  550. - Workaround for problem on 64bit Linux where thandle_t in libtiff is
  551. still 32bit so it cannot be used to pass pointers (for IO functions).
  552. - Support for libtiff as DLL/SO instead of linking object files to exe.
  553. Useful for platforms like Linux where libtiff is already installed
  554. most of the time (and exe could be make smaller not linking the objects).
  555. - Removed problematic append mode.
  556. - Renamed and refactored to be based on common Tiff base class
  557. (for shared stuff between other Tiff implementations (WIC, Quartz)).
  558. -- 0.77.1 ----------------------------------------------------
  559. - Renamed unit to ImagingLibTiffDelphi since there will be more
  560. Tiff implementations in the future, cleaned up interface units
  561. and obj file a little bit.
  562. - Updated LibTiff to version 3.9.4 and added EXIF tag support.
  563. - Added TIFF Append mode: when saving existing files are not
  564. overwritten but images are appended to TIFF instead.
  565. - Images in ifBinary format are now supported for loading/saving
  566. (optional Group 4 fax encoding added).
  567. - PHOTOMETRIC_MINISWHITE is now properly read as Grayscale/Binary
  568. instead of using unefficient RGBA interface.
  569. -- 0.26.5 Changes/Bug Fixes ---------------------------------
  570. - Fix: All pages of multipage TIFF were loaded even when
  571. OnlyFirstLevel was True.
  572. - Loading and saving of physical resolution metadata.
  573. - Unicode compatibility fixes in LibTiffDelphi.
  574. - Added Jpeg compression quality setting.
  575. -- 0.24.3 Changes/Bug Fixes ---------------------------------
  576. - Fixed bug in loading and saving of 2 channel images - Imaging
  577. tried to swap R and B channels here.
  578. -- 0.23 Changes/Bug Fixes -----------------------------------
  579. - Added TIFF loading and saving.
  580. - Unit created and initial code added.
  581. }
  582. end.