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
663 lines
22 KiB
{
|
|
Vampyre Imaging Library
|
|
by Marek Mauder
|
|
http://imaginglib.sourceforge.net
|
|
|
|
The contents of this file are used with permission, subject to the Mozilla
|
|
Public License Version 1.1 (the "License"); you may not use this file except
|
|
in compliance with the License. You may obtain a copy of the License at
|
|
http://www.mozilla.org/MPL/MPL-1.1.html
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
|
|
the specific language governing rights and limitations under the License.
|
|
|
|
Alternatively, the contents of this file may be used under the terms of the
|
|
GNU Lesser General Public License (the "LGPL License"), in which case the
|
|
provisions of the LGPL License are applicable instead of those above.
|
|
If you wish to allow use of your version of this file only under the terms
|
|
of the LGPL License and not to allow others to use your version of this file
|
|
under the MPL, indicate your decision by deleting the provisions above and
|
|
replace them with the notice and other provisions required by the LGPL
|
|
License. If you do not delete the provisions above, a recipient may use
|
|
your version of this file under either the MPL or the LGPL License.
|
|
|
|
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
|
|
}
|
|
|
|
{ This unit contains image format loader/saver for TIFF images
|
|
using LibTiff C library compiled to object files or LibTiff DLL/SO.
|
|
|
|
Supported platforms/compilers are now:
|
|
Win32 Delphi: obj, dll
|
|
Win64 Delphi: dll
|
|
Win32, Win64 FPC: obj, dll
|
|
Linux/Unix/macOS 32/64 FPC: dll
|
|
}
|
|
unit ImagingTiffLib;
|
|
|
|
{$I ImagingOptions.inc}
|
|
|
|
{$IF Defined(LINUX) or Defined(BSD) or Defined(MACOS)}
|
|
// Use LibTiff dynamic library in Linux/BSD instead of precompiled objects.
|
|
// It's installed on most systems so let's use it and keep the binary smaller.
|
|
// In macOS it's usually not installed but if it is let's use it.
|
|
{$DEFINE USE_DYN_LIB}
|
|
{$IFEND}
|
|
|
|
{$IF Defined(POSIX) and Defined(CPUX64)}
|
|
// Workaround for problem on 64bit Linux where thandle_t in libtiff is
|
|
// still 32bit so it cannot be used to pass pointers (for IO functions).
|
|
{$DEFINE HANDLE_NOT_POINTER_SIZED}
|
|
{$IFEND}
|
|
|
|
{.$DEFINE USE_DYN_LIB}
|
|
|
|
interface
|
|
|
|
uses
|
|
SysUtils, Imaging, ImagingTypes, ImagingUtility, ImagingIO,
|
|
ImagingTiff,
|
|
{$IFDEF USE_DYN_LIB}
|
|
LibTiffDynLib;
|
|
{$ELSE}
|
|
LibTiffDelphi;
|
|
{$ENDIF}
|
|
|
|
type
|
|
{ TIFF (Tag Image File Format) loader/saver class. Uses LibTiff so
|
|
it can handle most types of TIFF files.}
|
|
TTiffLibFileFormat = class(TBaseTiffFileFormat)
|
|
protected
|
|
procedure Define; override;
|
|
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
|
|
OnlyFirstLevel: Boolean): Boolean; override;
|
|
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
|
|
Index: Integer): Boolean; override;
|
|
procedure ConvertToSupported(var Image: TImageData;
|
|
const Info: TImageFormatInfo); override;
|
|
end;
|
|
|
|
implementation
|
|
|
|
const
|
|
TiffSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8,
|
|
ifGray16, ifA16Gray16, ifGray32, ifR8G8B8, ifA8R8G8B8, ifR16G16B16,
|
|
ifA16R16G16B16, ifR32F, ifA32R32G32B32F, ifR16F, ifA16R16G16B16F, ifBinary];
|
|
|
|
type
|
|
TTiffIOWrapper = record
|
|
IO: TIOFunctions;
|
|
Handle: TImagingHandle;
|
|
end;
|
|
PTiffIOWrapper = ^TTiffIOWrapper;
|
|
|
|
{$IFDEF HANDLE_NOT_POINTER_SIZED}
|
|
var
|
|
TiffIOWrapper: TTiffIOWrapper;
|
|
{$ENDIF}
|
|
|
|
function GetTiffIOWrapper(Fd: THandle): PTiffIOWrapper;
|
|
begin
|
|
{$IFDEF HANDLE_NOT_POINTER_SIZED}
|
|
Result := @TiffIOWrapper;
|
|
{$ELSE}
|
|
Result := PTiffIOWrapper(Fd);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TIFFReadProc(Fd: THandle; Buffer: Pointer; Size: Integer): Integer; cdecl;
|
|
var
|
|
Wrapper: PTiffIOWrapper;
|
|
begin
|
|
Wrapper := GetTiffIOWrapper(Fd);
|
|
Result := Wrapper.IO.Read(Wrapper.Handle, Buffer, Size);
|
|
end;
|
|
|
|
function TIFFWriteProc(Fd: THandle; Buffer: Pointer; Size: Integer): Integer; cdecl;
|
|
var
|
|
Wrapper: PTiffIOWrapper;
|
|
begin
|
|
Wrapper := GetTiffIOWrapper(Fd);
|
|
Result := Wrapper.IO.Write(Wrapper.Handle, Buffer, Size);
|
|
end;
|
|
|
|
function TIFFSizeProc(Fd: THandle): toff_t; cdecl;
|
|
var
|
|
Wrapper: PTiffIOWrapper;
|
|
begin
|
|
Wrapper := GetTiffIOWrapper(Fd);
|
|
Result := ImagingIO.GetInputSize(Wrapper.IO, Wrapper.Handle);
|
|
end;
|
|
|
|
function TIFFSeekProc(Fd: THandle; Offset: toff_t; Where: Integer): toff_t; cdecl;
|
|
const
|
|
SEEK_SET = 0;
|
|
SEEK_CUR = 1;
|
|
SEEK_END = 2;
|
|
var
|
|
Mode: TSeekMode;
|
|
Wrapper: PTiffIOWrapper;
|
|
begin
|
|
Wrapper := GetTiffIOWrapper(Fd);
|
|
if Offset = $FFFFFFFF then
|
|
begin
|
|
Result := $FFFFFFFF;
|
|
Exit;
|
|
end;
|
|
case Where of
|
|
SEEK_SET: Mode := smFromBeginning;
|
|
SEEK_CUR: Mode := smFromCurrent;
|
|
SEEK_END: Mode := smFromEnd;
|
|
else
|
|
Mode := smFromBeginning;
|
|
end;
|
|
Result := Wrapper.IO.Seek(Wrapper.Handle, Offset, Mode);
|
|
end;
|
|
|
|
function TIFFCloseProc(Fd: THandle): Integer; cdecl;
|
|
begin
|
|
Result := 0;
|
|
end;
|
|
|
|
function TIFFNoMapProc(Fd: THandle; Base: PPointer; Size: PCardinal): Integer; cdecl;
|
|
begin
|
|
Result := 0;
|
|
end;
|
|
|
|
procedure TIFFNoUnmapProc(Fd: THandle; Base: Pointer; Size: Cardinal); cdecl;
|
|
begin
|
|
end;
|
|
|
|
var
|
|
LastError: string = 'None';
|
|
|
|
procedure TIFFErrorHandler(const Module, Message: AnsiString);
|
|
begin
|
|
LastError := string(Module + ': ' + Message);
|
|
end;
|
|
|
|
{
|
|
TTiffFileFormat implementation
|
|
}
|
|
|
|
procedure TTiffLibFileFormat.Define;
|
|
begin
|
|
inherited;
|
|
FFeatures := [ffLoad, ffSave, ffMultiImage];
|
|
FSupportedFormats := TiffSupportedFormats;
|
|
end;
|
|
|
|
function TTiffLibFileFormat.LoadData(Handle: TImagingHandle;
|
|
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
|
|
var
|
|
Tiff: PTIFF;
|
|
IOWrapper: TTiffIOWrapper;
|
|
I, Idx, TiffResult, ScanLineSize, NumDirectories, X: Integer;
|
|
RowsPerStrip: LongWord;
|
|
Orientation, BitsPerSample, SamplesPerPixel, Photometric,
|
|
PlanarConfig, SampleFormat: Word;
|
|
DataFormat: TImageFormat;
|
|
CanAccessScanlines: Boolean;
|
|
Ptr: PByte;
|
|
Red, Green, Blue: PWordRecArray;
|
|
|
|
procedure LoadMetadata(Tiff: PTiff; TiffPage: Integer);
|
|
var
|
|
TiffResUnit, CompressionScheme: Word;
|
|
XRes, YRes: Single;
|
|
ResUnit: TResolutionUnit;
|
|
CompressionName: string;
|
|
begin
|
|
TIFFGetFieldDefaulted(Tiff, TIFFTAG_RESOLUTIONUNIT, @TiffResUnit);
|
|
TIFFGetFieldDefaulted(Tiff, TIFFTAG_XRESOLUTION, @XRes);
|
|
TIFFGetFieldDefaulted(Tiff, TIFFTAG_YRESOLUTION, @YRes);
|
|
TIFFGetFieldDefaulted(Tiff, TIFFTAG_COMPRESSION, @CompressionScheme);
|
|
|
|
FMetadata.SetMetaItem(SMetaTiffResolutionUnit, TiffResUnit);
|
|
|
|
if (TiffResUnit <> RESUNIT_NONE) and (XRes >= 0.1) and (YRes >= 0.1) then
|
|
begin
|
|
ResUnit := ruDpi;
|
|
if TiffResUnit = RESUNIT_CENTIMETER then
|
|
ResUnit := ruDpcm;
|
|
FMetadata.SetPhysicalPixelSize(ResUnit, XRes, YRes, False, TiffPage);
|
|
end;
|
|
|
|
case CompressionScheme of
|
|
COMPRESSION_NONE: CompressionName := 'None';
|
|
COMPRESSION_LZW: CompressionName := 'LZW';
|
|
COMPRESSION_JPEG: CompressionName := 'JPEG';
|
|
COMPRESSION_PACKBITS: CompressionName := 'Packbits RLE';
|
|
COMPRESSION_DEFLATE: CompressionName := 'Deflate';
|
|
COMPRESSION_CCITTFAX4: CompressionName := 'CCITT Group 4 Fax';
|
|
COMPRESSION_OJPEG: CompressionName := 'Old JPEG';
|
|
COMPRESSION_CCITTRLE..COMPRESSION_CCITTFAX3: CompressionName := 'CCITT';
|
|
else
|
|
CompressionName := 'Unknown';
|
|
end;
|
|
|
|
FMetadata.SetMetaItem(SMetaTiffCompressionName, CompressionName);
|
|
end;
|
|
|
|
begin
|
|
Result := False;
|
|
SetUserMessageHandlers(TIFFErrorHandler, nil);
|
|
|
|
// Set up IO wrapper and open TIFF
|
|
IOWrapper.IO := GetIO;
|
|
IOWrapper.Handle := Handle;
|
|
{$IFDEF HANDLE_NOT_POINTER_SIZED}
|
|
TiffIOWrapper := IOWrapper;
|
|
{$ENDIF}
|
|
|
|
Tiff := TIFFClientOpen('LibTIFF', 'r', THandle(@IOWrapper), @TIFFReadProc,
|
|
@TIFFWriteProc, @TIFFSeekProc, @TIFFCloseProc,
|
|
@TIFFSizeProc, @TIFFNoMapProc, @TIFFNoUnmapProc);
|
|
|
|
if Tiff <> nil then
|
|
TIFFSetFileNo(Tiff, THandle(@IOWrapper))
|
|
else
|
|
Exit;
|
|
|
|
NumDirectories := TIFFNumberOfDirectories(Tiff);
|
|
if OnlyFirstLevel then
|
|
NumDirectories := Min(1, NumDirectories);
|
|
|
|
SetLength(Images, NumDirectories);
|
|
|
|
for Idx := 0 to NumDirectories - 1 do
|
|
begin
|
|
TIFFSetDirectory(Tiff, Idx);
|
|
|
|
// Set defaults for TIFF fields
|
|
DataFormat := ifUnknown;
|
|
|
|
// Read some TIFF fields with basic image info
|
|
TIFFGetField(Tiff, TIFFTAG_IMAGEWIDTH, @Images[Idx].Width);
|
|
TIFFGetField(Tiff, TIFFTAG_IMAGELENGTH, @Images[Idx].Height);
|
|
TIFFGetFieldDefaulted(Tiff, TIFFTAG_ORIENTATION, @Orientation);
|
|
TIFFGetFieldDefaulted(Tiff, TIFFTAG_BITSPERSAMPLE, @BitsPerSample);
|
|
TIFFGetFieldDefaulted(Tiff, TIFFTAG_SAMPLESPERPIXEL, @SamplesPerPixel);
|
|
TIFFGetFieldDefaulted(Tiff, TIFFTAG_SAMPLEFORMAT, @SampleFormat);
|
|
TIFFGetFieldDefaulted(Tiff, TIFFTAG_PHOTOMETRIC, @Photometric);
|
|
TIFFGetFieldDefaulted(Tiff, TIFFTAG_PLANARCONFIG, @PlanarConfig);
|
|
TIFFGetFieldDefaulted(Tiff, TIFFTAG_ROWSPERSTRIP, @RowsPerStrip);
|
|
|
|
// Load supported metadata
|
|
LoadMetadata(Tiff, Idx);
|
|
// See if we can just copy scanlines from TIFF to Imaging image
|
|
CanAccessScanlines := (PlanarConfig = PLANARCONFIG_CONTIG) or (SamplesPerPixel = 1);
|
|
|
|
if CanAccessScanlines then
|
|
begin
|
|
// We can copy scanlines so we try to find data format that best matches
|
|
// TIFFs internal data format
|
|
if (Photometric = PHOTOMETRIC_MINISBLACK) or (Photometric = PHOTOMETRIC_MINISWHITE) then
|
|
begin
|
|
if SampleFormat = SAMPLEFORMAT_UINT then
|
|
begin
|
|
case BitsPerSample of
|
|
1:
|
|
if SamplesPerPixel = 1 then
|
|
DataFormat := ifBinary;
|
|
8:
|
|
case SamplesPerPixel of
|
|
1: DataFormat := ifGray8;
|
|
2: DataFormat := ifA8Gray8;
|
|
end;
|
|
16:
|
|
case SamplesPerPixel of
|
|
1: DataFormat := ifGray16;
|
|
2: DataFormat := ifA16Gray16;
|
|
end;
|
|
32:
|
|
if SamplesPerPixel = 1 then
|
|
DataFormat := ifGray32;
|
|
end;
|
|
end
|
|
else if SampleFormat = SAMPLEFORMAT_IEEEFP then
|
|
begin
|
|
case BitsPerSample of
|
|
16:
|
|
if SamplesPerPixel = 1 then
|
|
DataFormat := ifR16F;
|
|
32:
|
|
if SamplesPerPixel = 1 then
|
|
DataFormat := ifR32F;
|
|
end;
|
|
end;
|
|
end
|
|
else if Photometric = PHOTOMETRIC_RGB then
|
|
begin
|
|
if SampleFormat = SAMPLEFORMAT_UINT then
|
|
begin
|
|
case BitsPerSample of
|
|
8:
|
|
case SamplesPerPixel of
|
|
3: DataFormat := ifR8G8B8;
|
|
4: DataFormat := ifA8R8G8B8;
|
|
end;
|
|
16:
|
|
case SamplesPerPixel of
|
|
3: DataFormat := ifR16G16B16;
|
|
4: DataFormat := ifA16R16G16B16;
|
|
end;
|
|
end;
|
|
end
|
|
else if SampleFormat = SAMPLEFORMAT_IEEEFP then
|
|
begin
|
|
case BitsPerSample of
|
|
16:
|
|
if SamplesPerPixel = 4 then
|
|
DataFormat := ifA16R16G16B16F;
|
|
32:
|
|
if SamplesPerPixel = 4 then
|
|
DataFormat := ifA32R32G32B32F;
|
|
end;
|
|
end;
|
|
end
|
|
else if Photometric = PHOTOMETRIC_PALETTE then
|
|
begin
|
|
if (SamplesPerPixel = 1) and (SampleFormat = SAMPLEFORMAT_UINT) and (BitsPerSample = 8) then
|
|
DataFormat := ifIndex8
|
|
end;
|
|
end;
|
|
|
|
if DataFormat = ifUnknown then
|
|
begin
|
|
// Use RGBA interface to read A8R8G8B8 TIFFs and mainly TIFFs in various
|
|
// formats with no Imaging equivalent, exotic color spaces etc.
|
|
NewImage(Images[Idx].Width, Images[Idx].Height, ifA8R8G8B8, Images[Idx]);
|
|
TiffResult := TIFFReadRGBAImageOriented(Tiff, Images[Idx].Width, Images[Idx].Height,
|
|
Images[Idx].Bits, Orientation, 0);
|
|
if TiffResult = 0 then
|
|
RaiseImaging(LastError, []);
|
|
// Swap Red and Blue, if YCbCr.
|
|
if Photometric=PHOTOMETRIC_YCBCR then
|
|
SwapChannels(Images[Idx], ChannelRed, ChannelBlue);
|
|
end
|
|
else
|
|
begin
|
|
// Create new image in given format and read scanlines from TIFF,
|
|
// read palette too if needed
|
|
NewImage(Images[Idx].Width, Images[Idx].Height, DataFormat, Images[Idx]);
|
|
ScanLineSize := TIFFScanlineSize(Tiff);
|
|
|
|
for I := 0 to Images[Idx].Height - 1 do
|
|
TIFFReadScanline(Tiff, @PByteArray(Images[Idx].Bits)[I * ScanLineSize], I, 0);
|
|
|
|
if DataFormat = ifIndex8 then
|
|
begin
|
|
TIFFGetField(Tiff, TIFFTAG_COLORMAP, @Red, @Green, @Blue);
|
|
for I := 0 to 255 do
|
|
with Images[Idx].Palette[I] do
|
|
begin
|
|
A := 255;
|
|
R := Red[I].High;
|
|
G := Green[I].High;
|
|
B := Blue[I].High;
|
|
end;
|
|
end;
|
|
|
|
// TIFF uses BGR order so we must swap it (but not images we got
|
|
// from TiffLib RGBA interface)
|
|
if Photometric = PHOTOMETRIC_RGB then
|
|
SwapChannels(Images[Idx], ChannelRed, ChannelBlue);
|
|
|
|
// We need to negate 'MinIsWhite' formats to get common grayscale
|
|
// formats where min sample value is black
|
|
if Photometric = PHOTOMETRIC_MINISWHITE then
|
|
for I := 0 to Images[Idx].Height - 1 do
|
|
begin
|
|
Ptr := @PByteArray(Images[Idx].Bits)[I * ScanLineSize];
|
|
for X := 0 to ScanLineSize - 1 do
|
|
begin
|
|
Ptr^ := not Ptr^;
|
|
Inc(Ptr);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
TIFFClose(Tiff);
|
|
Result := True;
|
|
end;
|
|
|
|
function TTiffLibFileFormat.SaveData(Handle: TImagingHandle;
|
|
const Images: TDynImageDataArray; Index: Integer): Boolean;
|
|
const
|
|
Compressions: array[0..5] of Word = (COMPRESSION_NONE, COMPRESSION_LZW,
|
|
COMPRESSION_PACKBITS, COMPRESSION_DEFLATE, COMPRESSION_JPEG, COMPRESSION_CCITTFAX4);
|
|
var
|
|
Tiff: PTIFF;
|
|
IOWrapper: TTiffIOWrapper;
|
|
I, J, ScanLineSize: Integer;
|
|
ImageToSave: TImageData;
|
|
MustBeFreed: Boolean;
|
|
Info: TImageFormatInfo;
|
|
Orientation, BitsPerSample, SamplesPerPixel, Photometric,
|
|
PlanarConfig, SampleFormat, CompressionScheme: Word;
|
|
RowsPerStrip: LongWord;
|
|
Red, Green, Blue: array[Byte] of TWordRec;
|
|
CompressionMismatch: Boolean;
|
|
OpenMode: PAnsiChar;
|
|
|
|
procedure SaveMetadata(Tiff: PTiff; TiffPage: Integer);
|
|
var
|
|
XRes, YRes: Single;
|
|
ResUnit: TResolutionUnit;
|
|
TiffResUnit, StoredTiffResUnit: Word;
|
|
begin
|
|
XRes := -1;
|
|
YRes := -1;
|
|
|
|
ResUnit := ruDpcm;
|
|
TiffResUnit := RESUNIT_CENTIMETER;
|
|
|
|
if FMetadata.HasMetaItemForSaving(SMetaTiffResolutionUnit) then
|
|
begin
|
|
// Check if DPI resolution unit is requested to be used (e.g. to
|
|
// use the same unit when just resaving files - also some )
|
|
StoredTiffResUnit := FMetadata.MetaItemsForSaving[SMetaTiffResolutionUnit];
|
|
if StoredTiffResUnit = RESUNIT_INCH then
|
|
begin
|
|
ResUnit := ruDpi;
|
|
TiffResUnit := RESUNIT_INCH;
|
|
end;
|
|
end;
|
|
|
|
// First try to find phys. size for current TIFF page index. If not found then
|
|
// try size for main image (index 0).
|
|
if not FMetadata.GetPhysicalPixelSize(ResUnit, XRes, YRes, True, TiffPage) then
|
|
FMetadata.GetPhysicalPixelSize(ResUnit, XRes, YRes, True, 0);
|
|
|
|
if (XRes > 0) and (YRes > 0) then
|
|
begin
|
|
TIFFSetField(Tiff, TIFFTAG_RESOLUTIONUNIT, TiffResUnit);
|
|
TIFFSetField(Tiff, TIFFTAG_XRESOLUTION, XRes);
|
|
TIFFSetField(Tiff, TIFFTAG_YRESOLUTION, YRes);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Result := False;
|
|
SetUserMessageHandlers(TIFFErrorHandler, nil);
|
|
|
|
if not (FCompression in [0..5]) then
|
|
FCompression := COMPRESSION_LZW;
|
|
|
|
// Set up IO wrapper and open TIFF
|
|
IOWrapper.IO := GetIO;
|
|
IOWrapper.Handle := Handle;
|
|
{$IFDEF HANDLE_NOT_POINTER_SIZED}
|
|
TiffIOWrapper := IOWrapper;
|
|
{$ENDIF}
|
|
|
|
OpenMode := 'w';
|
|
|
|
Tiff := TIFFClientOpen('LibTIFF', OpenMode, THandle(@IOWrapper), @TIFFReadProc,
|
|
@TIFFWriteProc, @TIFFSeekProc, @TIFFCloseProc,
|
|
@TIFFSizeProc, @TIFFNoMapProc, @TIFFNoUnmapProc);
|
|
|
|
if Tiff <> nil then
|
|
TIFFSetFileNo(Tiff, THandle(@IOWrapper))
|
|
else
|
|
Exit;
|
|
|
|
for I := FFirstIdx to FLastIdx do
|
|
begin
|
|
if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
|
|
with GetIO, ImageToSave do
|
|
try
|
|
GetImageFormatInfo(Format, Info);
|
|
|
|
// Set Tag values
|
|
Orientation := ORIENTATION_TOPLEFT;
|
|
BitsPerSample := Info.BytesPerPixel div Info.ChannelCount * 8;
|
|
if Info.Format = ifBinary then
|
|
BitsPerSample := 1;
|
|
SamplesPerPixel := Info.ChannelCount;
|
|
SampleFormat := Iff(not Info.IsFloatingPoint, SAMPLEFORMAT_UINT, SAMPLEFORMAT_IEEEFP);
|
|
PlanarConfig := PLANARCONFIG_CONTIG;
|
|
CompressionScheme := Compressions[FCompression];
|
|
|
|
// Check if selected compression scheme can be used for current image
|
|
CompressionMismatch := (CompressionScheme = COMPRESSION_JPEG) and ((BitsPerSample <> 8) or
|
|
not (SamplesPerPixel in [1, 3]) or Info.IsIndexed or Info.IsFloatingPoint);
|
|
CompressionMismatch := CompressionMismatch or ((CompressionScheme = COMPRESSION_CCITTFAX4) and (Info.Format <> ifBinary));
|
|
if CompressionMismatch then
|
|
CompressionScheme := COMPRESSION_LZW;
|
|
// If we have some compression scheme selected and it's not Fax then select it automatically - better comp ratios!
|
|
if (Info.Format = ifBinary) and (CompressionScheme <> COMPRESSION_NONE) and (CompressionScheme <> COMPRESSION_CCITTFAX4) then
|
|
CompressionScheme := COMPRESSION_CCITTFAX4;
|
|
|
|
RowsPerStrip := TIFFDefaultStripSize(Tiff, Height);
|
|
if Info.IsIndexed then
|
|
Photometric := PHOTOMETRIC_PALETTE
|
|
else if (Info.HasGrayChannel) or (Info.ChannelCount = 1) then
|
|
Photometric := PHOTOMETRIC_MINISBLACK
|
|
else
|
|
Photometric := PHOTOMETRIC_RGB;
|
|
|
|
// Write tags
|
|
TIFFSetField(Tiff, TIFFTAG_IMAGEWIDTH, Width);
|
|
TIFFSetField(Tiff, TIFFTAG_IMAGELENGTH, Height);
|
|
TIFFSetField(Tiff, TIFFTAG_PHOTOMETRIC, Photometric);
|
|
TIFFSetField(Tiff, TIFFTAG_PLANARCONFIG, PlanarConfig);
|
|
TIFFSetField(Tiff, TIFFTAG_ORIENTATION, Orientation);
|
|
TIFFSetField(Tiff, TIFFTAG_BITSPERSAMPLE, BitsPerSample);
|
|
TIFFSetField(Tiff, TIFFTAG_SAMPLESPERPIXEL, SamplesPerPixel);
|
|
TIFFSetField(Tiff, TIFFTAG_SAMPLEFORMAT, SampleFormat);
|
|
TIFFSetField(Tiff, TIFFTAG_COMPRESSION, CompressionScheme);
|
|
if CompressionScheme = COMPRESSION_JPEG then
|
|
TIFFSetField(Tiff, TIFFTAG_JPEGQUALITY, FJpegQuality);
|
|
TIFFSetField(Tiff, TIFFTAG_ROWSPERSTRIP, RowsPerStrip);
|
|
// Save supported metadata
|
|
SaveMetadata(Tiff, I);
|
|
|
|
if Format = ifIndex8 then
|
|
begin
|
|
// Set paletee for indexed images
|
|
for J := 0 to 255 do
|
|
with ImageToSave.Palette[J] do
|
|
begin
|
|
Red[J].High := R;
|
|
Green[J].High := G;
|
|
Blue[J].High := B;
|
|
end;
|
|
TIFFSetField(Tiff, TIFFTAG_COLORMAP, @Red[0], @Green[0], @Blue[0]);
|
|
end;
|
|
|
|
ScanLineSize := Info.GetPixelsSize(Info.Format, Width, 1);
|
|
|
|
if Photometric = PHOTOMETRIC_RGB then
|
|
SwapChannels(ImageToSave, ChannelRed, ChannelBlue);
|
|
// Write image scanlines and then directory for current image
|
|
for J := 0 to Height - 1 do
|
|
TIFFWriteScanline(Tiff, @PByteArray(Bits)[J * ScanLineSize], J, 0);
|
|
if Info.ChannelCount > 1 then
|
|
SwapChannels(ImageToSave, ChannelRed, ChannelBlue);
|
|
|
|
TIFFWriteDirectory(Tiff);
|
|
finally
|
|
if MustBeFreed then
|
|
FreeImage(ImageToSave);
|
|
end;
|
|
end;
|
|
|
|
TIFFClose(Tiff);
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TTiffLibFileFormat.ConvertToSupported(var Image: TImageData;
|
|
const Info: TImageFormatInfo);
|
|
var
|
|
ConvFormat: TImageFormat;
|
|
begin
|
|
if Info.RBSwapFormat in GetSupportedFormats then
|
|
ConvFormat := Info.RBSwapFormat
|
|
else if Info.IsFloatingPoint then
|
|
ConvFormat := IffFormat(Info.ChannelCount = 1, ifR32F, ifA32R32G32B32F)
|
|
else if Info.HasGrayChannel then
|
|
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16Gray16, ifGray32)
|
|
else
|
|
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8);
|
|
|
|
ConvertImage(Image, ConvFormat);
|
|
end;
|
|
|
|
initialization
|
|
{$IFDEF USE_DYN_LIB}
|
|
// If using dynamic library only register the format if
|
|
// the library loads successfully.
|
|
if LibTiffDynLib.LoadTiffLibrary then
|
|
{$ENDIF}
|
|
RegisterImageFileFormat(TTiffLibFileFormat);
|
|
|
|
{
|
|
File Notes:
|
|
|
|
-- TODOS ----------------------------------------------------
|
|
- nothing now
|
|
|
|
-- 0.77.3 ----------------------------------------------------
|
|
- Lot more platforms than just 32bit Delphi supported now.
|
|
- Workaround for problem on 64bit Linux where thandle_t in libtiff is
|
|
still 32bit so it cannot be used to pass pointers (for IO functions).
|
|
- Support for libtiff as DLL/SO instead of linking object files to exe.
|
|
Useful for platforms like Linux where libtiff is already installed
|
|
most of the time (and exe could be make smaller not linking the objects).
|
|
- Removed problematic append mode.
|
|
- Renamed and refactored to be based on common Tiff base class
|
|
(for shared stuff between other Tiff implementations (WIC, Quartz)).
|
|
|
|
-- 0.77.1 ----------------------------------------------------
|
|
- Renamed unit to ImagingLibTiffDelphi since there will be more
|
|
Tiff implementations in the future, cleaned up interface units
|
|
and obj file a little bit.
|
|
- Updated LibTiff to version 3.9.4 and added EXIF tag support.
|
|
- Added TIFF Append mode: when saving existing files are not
|
|
overwritten but images are appended to TIFF instead.
|
|
- Images in ifBinary format are now supported for loading/saving
|
|
(optional Group 4 fax encoding added).
|
|
- PHOTOMETRIC_MINISWHITE is now properly read as Grayscale/Binary
|
|
instead of using unefficient RGBA interface.
|
|
|
|
-- 0.26.5 Changes/Bug Fixes ---------------------------------
|
|
- Fix: All pages of multipage TIFF were loaded even when
|
|
OnlyFirstLevel was True.
|
|
- Loading and saving of physical resolution metadata.
|
|
- Unicode compatibility fixes in LibTiffDelphi.
|
|
- Added Jpeg compression quality setting.
|
|
|
|
-- 0.24.3 Changes/Bug Fixes ---------------------------------
|
|
- Fixed bug in loading and saving of 2 channel images - Imaging
|
|
tried to swap R and B channels here.
|
|
|
|
-- 0.23 Changes/Bug Fixes -----------------------------------
|
|
- Added TIFF loading and saving.
|
|
- Unit created and initial code added.
|
|
}
|
|
|
|
end.
|