Repo for the search and displace ingest module that takes odf, docx and pdf and transforms it into .md to be used with search and displace operations
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

663 lines
22 KiB

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