ImagingTiffLib.pas 22 KB

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