kjkim
/
BSOne.SFC
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
BSOne.SFC/EM.Lib/ImageEn_SRC/Source/tiffilt.pas

6590 lines
217 KiB
Plaintext
Raw Blame History

(* ImageEn Build 7.0.0.06.2637 @ 7-4-17 14:58:42.679 *)
(*
Copyright (c) 1998-2017 by Carlotta Calandra. All rights reserved.
Copyright (c) 2011-2017 by Xequte Software.
This software comes without express or implied warranty.
In no case shall the author be liable for any damage or unwanted behavior of any
computer hardware and/or software.
Author grants you the right to include the component
in your application, whether COMMERCIAL, SHAREWARE, or FREEWARE.
ImageEn, IEvolution and ImageEn ActiveX may not be included in any
commercial, shareware or freeware libraries or components.
www.ImageEn.com
*)
(*
File version 1032
Doc revision N/A
*)
unit tiffilt;
{$R-}
{$Q-}
{$I ie.inc}
interface
uses
Windows, Graphics, classes, sysutils, ImageEnProc, ImageEnIO, hyiedefs, iexBitmaps;
// TIFF image load/save
procedure TIFFReadStream(Bitmap: TIEBitmap; Stream: TStream; var numi: integer; IOParams: TIOParams; var Progress: TProgressRec; Preview: boolean; var AlphaChannel: TIEMask; TranslateBase: boolean; IgnoreAlpha: boolean; IsExifThumb: boolean; IsEXIFData: boolean; ProvidedHeader: PTIFFHeader = nil);
function TIFFWriteStream(OStream: TStream; Ins: boolean; Bitmap: TIEBitmap; var IOParams: TIOParams; var Progress: TProgressRec): integer;
function TIFFEnumImages(Stream: TStream): integer;
function TIFFDeleteImStream(Stream: TStream; idx: integer): integer;
function TIFFDeleteImStreamGroup(Stream: TStream; idxlist: pintegerarray; idxcount: integer): integer;
procedure TIFFExtractImStream(Stream: TStream; idx: integer; OutStream: TStream);
procedure TIFFInsertImStream(Stream: TStream; ToInsert: TStream; idx: integer; OutStream: TStream); overload;
function TIFFInsertImStream(Stream: TStream; ToInsert: TStream; idx: integer; OutStream: TStream; internal: boolean): integer; overload;
function IsTIFFStream(fs: TStream): boolean;
function IsDNGStream(fs: TStream): boolean;
function IsHDPStream(fs: TStream): boolean;
{$ifdef IEINCLUDETIFFHANDLER}
function IEInjectTIFFEXIF(InputStream, OutputStream: TStream; const InputFileName, OutputFileName: WideString; pageIndex: integer; IOParams: TIOParams): boolean;
{$endif}
function TIFFReadHeader(Stream: TStream; ProvidedHeader: PTIFFHeader; out LittleEndian: boolean; out BigTIFF: boolean; out DataPosSize: integer; out IFDPosition: int64): boolean;
function TIFFLoadTags(Stream: TStream; var numi: integer; ImageIndex: integer; IFD: TIETIFFIFDReader): boolean;
implementation
uses
math,
{$ifdef IEUSEVCLZLIB}zlib, {$endif} iezlib,
giffilter, tifccitt, imageenview, ieview, jpegfilt, neurquant, iesettings, hyieutils;
{$R-}
//////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////
//**********************************************************************************//
//* READ TIFF *//
//**********************************************************************************//
////////////////////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////////////////
const
IEMAXEXTRASAMPLES = 10;
type
TTIFFReaderContext = class
ImageWidth, ImageHeight: integer;
SamplesPerPixel: integer;
BitsPerSample: integer;
RowsPerStrip: integer;
TileWidth, TileLength: integer;
PhotometricInterpretation: word;
PlanarConfiguration: word;
Orientation: word;
Compression: word;
SampleFormat: word;
StripOffsets: pint64array;
StripOffsets_Num: integer; // number of items in StripOffsets
StripByteCounts: pint64array;
StripByteCounts_Num: integer; // number of items in StripByteCounts
TileOffsets: pint64Array;
TileOffsets_Num: integer; // number of items in TileOffsets
TileByteCounts: pint64Array;
TileByteCounts_Num: integer; // number of items in TileByteCounts
ColorMap: array of TRGB; // Colormap (dim=2^BitsPerSample)
ColorMap_Num: integer; // number of entries in Colormap (2^BitsPerSample)
TransferFunction: array of TTIFFColor;
Transferfunction_Num: integer; // number of items in TransferFunction
Predictor: integer;
JPEGTables: pointer; // compression tables (JPEG 7)
JPEGTablesSize: integer; // size in bytes of JPEGTables
T4Options: integer;
T6Options: integer;
FillOrder: integer;
Software: AnsiString;
YCbCrSubSampling: array [0..1] of integer;
// OLD Jpeg fields
JPEGProc: integer;
JPEGInterchangeFormat: integer;
JPEGInterchangeFormatLength: integer;
JPEGRestartInterval: integer;
JPEGLosslessPredictors: array[0..6] of integer;
JPEGPointTransforms: array[0..6] of integer;
JPEGQTables: array[0..6] of integer;
JPEGDCTables: array[0..6] of integer;
JPEGACTables: array[0..6] of integer;
// no tiff fields
LZWDecompFunc: TTIFFLZWDecompFunc;
LittleEndian: boolean;
RefParams: TIOParams;
// Alpha
AlphaChannel: TIEMask;
IgnoreAlpha: boolean;
ExtraSamples: integer;
ExtraSamplesCount: integer;
ExtraSamplesVal: array[0..IEMAXEXTRASAMPLES-1] of integer;
// IFDs
MainIFD: TIETIFFIFDReader;
ExifIFD: TIETIFFIFDReader;
GpsIFD: TIETIFFIFDReader;
InteropIFD: TIETIFFIFDReader;
constructor Create();
destructor Destroy(); override;
procedure ReadStream(Bitmap: TIEBitmap; Stream: TStream; var numi: integer; IOParams: TIOParams; var Progress: TProgressRec; Preview: boolean; var AlphaChannel: TIEMask; TranslateBase: boolean; IgnoreAlpha: boolean; IsExifThumb: boolean; IsEXIFData: boolean; ProvidedHeader: PTIFFHeader = nil);
end;
procedure Decompress1(context: TTIFFReaderContext; outbuf: TIEBitmap; baserow: integer; basecol: integer; inBuffer: pbyte; inBufferLen: integer; Width, Height: integer; var Progress: TProgressRec); forward;
procedure Decompress2(context: TTIFFReaderContext; outbuf: TIEBitmap; baserow: integer; xbufn: array of pbyte; szn: array of integer; Width, Height: integer; var Progress: TProgressRec); forward;
procedure Strips2Bitmap(IFD: TIETIFFIFDReader; context: TTIFFReaderContext; var Bitmap: TIEBitmap; var Progress: TProgressRec); forward;
procedure Tiles2Bitmap(IFD: TIETIFFIFDReader; context: TTIFFReaderContext; var Bitmap: TIEBitmap; var Progress: TProgressRec); forward;
// returns: true = ok, false = fail
function TIFFReadHeader(Stream: TStream; ProvidedHeader: PTIFFHeader; out LittleEndian: boolean; out BigTIFF: boolean; out DataPosSize: integer; out IFDPosition: int64): boolean;
var
HeaderByteOrder: word;
HeaderVersion: word;
begin
if ProvidedHeader <> nil then
begin
HeaderByteOrder := ProvidedHeader^.Id;
LittleEndian := HeaderByteOrder = $4949;
//HeaderVersion := IECSwapWord(ProvidedHeader^.Ver, not LittleEndian);
IFDPosition := IECSwapDWord(ProvidedHeader^.PosIFD, not LittleEndian);
BigTIFF := false;
DataPosSize := 4;
end
else
begin
Stream.Read(HeaderByteOrder, sizeof(word));
LittleEndian := HeaderByteOrder = $4949;
HeaderVersion := IEStreamReadWord(Stream, not LittleEndian);
if HeaderVersion = 43 then
begin
// BigTIFF
BigTIFF := true;
DataPosSize := 8;
if IEStreamReadWord(Stream, not LittleEndian) <> 8 then // Bytesize of offsets (always 8)
begin
result := false;
exit;
end;
if IEStreamReadWord(Stream, not LittleEndian) <> 0 then // always 0
begin
result := false;
exit;
end;
IFDPosition := IEStreamReadInt64(Stream, not LittleEndian); // Offset to first IFD
end
else
begin
// classic TIFF
BigTIFF := false;
DataPosSize := 4;
IFDPosition := IEStreamReadDWord(Stream, not LittleEndian); // Offset to first IFD
end;
end;
// simple header check
result := ((HeaderByteOrder = $4949) or (HeaderByteOrder = $4D4D)) and ((IFDPosition > 0) or (ProvidedHeader <> nil)) and (IFDPosition < Stream.Size);
end;
/////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////
// TTIFFReaderContext
constructor TTIFFReaderContext.Create();
begin
inherited;
MainIFD := TIETIFFIFDReader.Create();
ExifIFD := TIETIFFIFDReader.Create();
GpsIFD := TIETIFFIFDReader.Create();
InteropIFD := TIETIFFIFDReader.Create();
// note: other object fields are always initialized to 0
end;
destructor TTIFFReaderContext.Destroy();
begin
if StripOffsets_Num > 0 then
freemem(Stripoffsets);
if StripByteCounts_Num > 0 then
freemem(StripByteCounts);
if TileOffsets_Num > 0 then
freemem(TileOffsets);
if TileByteCounts_Num > 0 then
freemem(TileByteCounts);
if JPEGTables <> nil then
freemem(JPEGTables);
MainIFD.Free();
ExifIFD.Free();
GpsIFD.Free();
InteropIFD.Free();
inherited;
end;
// TTIFFReaderContext
/////////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////////
procedure ReadEXIFMakerNote(IFD: TIETIFFIFDReader; NTag: integer; tagsHandler: TIETagsHandler);
var
t: integer;
dpos, dnum: int64;
begin
tagsHandler.Clear();
if IEGlobalSettings().EXIFMakerNotesHandling = iemhDiscard then
exit;
t := IFD.FindTAG(NTag);
if t >= 0 then
begin
dpos := IFD.GetDataPos(t);
dnum := IFD.GetDataNum(t);
if (IFD.StreamBase + dpos + dnum <= IFD.Stream.Size) and (dnum > 0) then
begin
IFD.Stream.Seek(IFD.StreamBase + dpos, soBeginning);
tagsHandler.ReadFromStream(IFD.Stream, dnum, IFD.LittleEndian, IFD.Stream.Position, (IEGlobalSettings().EXIFMakerNotesHandling = iemhDecodeOrDiscardRaw));
end;
end;
end;
{$ifdef IEINCLUDEIMAGINGANNOT}
procedure LoadWang(IFD: TIETIFFIFDReader; Params: TIOParams);
var
t: integer;
buf: array of byte;
dpos, dnum: int64;
begin
t := IFD.FindTAG(IETIFFTAG_WANGIMAGING);
if t >= 0 then
begin
dpos := IFD.GetDataPos(t);
dnum := IFD.GetDataNum(t);
IFD.Stream.Seek(IFD.StreamBase + dpos, soBeginning);
SetLength(buf, dnum);
IFD.Stream.Read(buf[0], dnum);
Params.ImagingAnnot.LoadFromStandardBuffer(@buf[0], dnum);
end;
end;
{$endif}
procedure LoadImageEnAnnot(IFD: TIETIFFIFDReader; Params: TIOParams);
var
t : integer;
buf: array of byte;
dpos, dnum: int64;
begin
t := IFD.FindTAG(IEGlobalSettings().ObjectsTIFFTag);
if t >= 0 then
begin
dpos := IFD.GetDataPos(t);
dnum := IFD.GetDataNum(t);
IFD.Stream.Seek(IFD.StreamBase + dpos, soBeginning);
SetLength(buf, dnum);
IFD.Stream.Read(buf[0], dnum);
Params.ImageEnAnnot.LoadFromBuffer(@buf[0], dnum);
end;
end;
procedure LoadICC(IFD: TIETIFFIFDReader; Params: TIOParams);
var
t: integer;
buf: array of byte;
dpos, dnum: int64;
begin
if assigned(Params) then
begin
t := IFD.FindTAG(IETIFFTAG_ICC);
if t >= 0 then
begin
dpos := IFD.GetDataPos(t);
dnum := IFD.GetDataNum(t);
IFD.Stream.Seek(IFD.StreamBase + dpos, soBeginning);
SetLength(buf, dnum);
IFD.Stream.Read(buf[0], dnum);
Params.InputICCProfile.LoadFromBuffer(@buf[0], dnum);
end;
end;
end;
function convVersionIDtoStr(id: AnsiString): AnsiString;
var
i: integer;
begin
if id = '' then
id := #2#2#0#0;
result := '';
for i := 1 to length(id) do
result := result + IEIntToStr(ord(id[i])) + '.';
result := IECopy(result, 1, length(result) - 1);
end;
function convVersionStrtoID(const str: AnsiString): AnsiString;
var
i, p: integer;
begin
result := '';
p := 1;
for i := 1 to length(str) do
begin
if (str[i] = '.') then
begin
result := result + AnsiChar(IEStrToIntDef(IECopy(str, p, i - p), 0));
p := i + 1;
end;
end;
result := result + AnsiChar(IEStrToIntDef(IECopy(str, p, length(str) - p + 1), 0));
while length(result) < 4 do
result := result + #0;
SetLength(result, 4);
end;
// read colormap
procedure ReadColorMap(IFD: TIETIFFIFDReader; context: TTIFFReaderContext);
var
t, q: integer;
max: integer;
begin
context.ColorMap_Num := 0;
t := IFD.FindTAG(IETIFFTAG_COLORMAP);
if t >= 0 then
with context do
begin
ColorMap_Num := 1 shl BitsPerSample;
max := 0;
for q := 0 to ColorMap_Num * 3 - 1 do
max := imax( IFD.GetItem(t, q), max );
SetLength(ColorMap, ColorMap_Num);
for q := 0 to ColorMap_Num - 1 do
begin
if max>255 then
begin
ColorMap[q].R := IFD.GetItem(t, q) shr 8;
ColorMap[q].G := IFD.GetItem(t, ColorMap_Num + q) shr 8;
ColorMap[q].B := IFD.GetItem(t, (ColorMap_Num * 2) + q) shr 8;
end
else
begin
ColorMap[q].R := IFD.GetItem(t, q) ;
ColorMap[q].G := IFD.GetItem(t, ColorMap_Num + q) ;
ColorMap[q].B := IFD.GetItem(t, (ColorMap_Num * 2) + q) ;
end;
end;
end;
end;
procedure TIFFReadExtraSamples(IFD: TIETIFFIFDReader; context: TTIFFReaderContext);
var
t, i: integer;
dnum: int64;
begin
context.ExtraSamplesCount := 0;
t := IFD.FindTAG(338);
if t >= 0 then
begin
dnum := IFD.GetDataNum(t);
with context do
begin
ExtraSamplesCount := imin( dnum, IEMAXEXTRASAMPLES );
for i := 0 to ExtraSamplesCount - 1 do
ExtraSamplesVal[i] := IFD.GetItem(t, i);
end;
end;
end;
// read TransferFunction
procedure ReadTransferFunction(IFD: TIETIFFIFDReader; context: TTIFFReaderContext);
var
t, q: integer;
begin
context.TransferFunction_Num := 0;
t := IFD.FindTAG(IETIFFTAG_TRANSFERFUNC);
if t >= 0 then
with context do
begin
TransferFunction_Num := 1 shl BitsPerSample;
SetLength(TransferFunction, TransferFunction_Num);
for q := 0 to TransferFunction_Num - 1 do
begin
TransferFunction[q].R := IFD.GetItem(t, q * 3);
TransferFunction[q].G := IFD.GetItem(t, q * 3 + 1);
TransferFunction[q].B := IFD.GetItem(t, q * 3 + 2);
end;
end;
end;
function ReadBitsPerSample(IFD: TIETIFFIFDReader; context: TTIFFReaderContext): boolean;
var
t: integer;
w: word;
q: integer;
dnum: int64;
begin
result := true;
context.BitsPerSample := 1; // default
t := IFD.FindTAG(258);
if t >= 0 then
begin
dnum := IFD.GetDataNum(t);
if dnum = 1 then
begin
// one value
context.BitsPerSample := IFD.GetItem(t, 0);
end
else
begin
context.BitsPerSample := -1;
for q := 0 to dnum - 1 do
begin
w := IFD.GetItem(t, q);
if (context.BitsPerSample <> -1) and (context.BitsPerSample <> w) then
result := false;
context.BitsPerSample := w;
end;
end;
end;
end;
// read tiles
procedure Tiles2Bitmap(IFD: TIETIFFIFDReader; context: TTIFFReaderContext; var Bitmap: TIEBitmap; var Progress: TProgressRec);
var
q, sz: integer;
buf: pbyte;
row, col: integer;
begin
with context do
begin
row := 0;
col := 0;
Progress.per1 := 100 / ImageHeight;
Progress.per2 := 100 / TileOffsets_Num;
Progress.val := 0;
if PlanarConfiguration = 1 then
begin
Bitmap.Width := Bitmap.Width + TileWidth;
Bitmap.Height := Bitmap.Height + TileLength;
if RefParams.TIFF_GetTile = -1 then
q := 0
else
q := RefParams.TIFF_GetTile;
while q < TileOffsets_Num do
begin
IFD.Stream.Seek(IFD.StreamBase + TileOffsets^[q], soBeginning);
if TileByteCounts_Num > q then
sz := TileByteCounts^[q]
else
sz := 0;
if sz = 0 then
sz := IFD.Stream.Size - TileOffsets^[q];
getmem(buf, imax(sz, TileWidth * TileLength * 4));
try
IFD.Stream.Read(buf^, sz);
Decompress1(context, Bitmap, row, col, buf, sz, TileWidth, TileLength, Progress); // compress strip (buffer)
finally
freemem(buf);
end;
inc(col, TileWidth);
if col >= ImageWidth then
begin
col := 0;
inc(row, TileLength);
end;
if Progress.Aborting^ then
break;
if RefParams.TIFF_GetTile > -1 then
break;
inc(q);
end;
Bitmap.Width := ImageWidth;
Bitmap.Height := Imageheight;
end
else
if PlanarConfiguration = 2 then
begin
// not supported
Progress.Aborting^ := true;
exit;
end;
end;
end;
// read strips
procedure Strips2Bitmap(IFD: TIETIFFIFDReader; context: TTIFFReaderContext; var Bitmap: TIEBitmap; var Progress: TProgressRec);
var
q, w, e, c, sz, szt, i: integer;
szn: array [0..IEMAXEXTRASAMPLES-1] of integer;
buf: array of byte;
bufn, bufv: array [0..IEMAXEXTRASAMPLES-1] of pbyte;
row: integer;
begin
with context do
begin
row := 0;
Progress.per1 := 100 / ImageHeight;
Progress.per2 := 100 / StripOffsets_Num;
Progress.val := 0;
if PlanarConfiguration = 1 then
begin
// consecutive channels
for q := 0 to StripOffsets_Num - 1 do
begin
IFD.Stream.Seek(IFD.StreamBase + StripOffsets^[q], soBeginning);
if StripByteCounts_Num > q then
sz := StripByteCounts^[q]
else
sz := 0;
szt := RowsPerStrip * IEBitmapRowLen(ImageWidth, SamplesPerPixel * BitsPerSample, 8); // 3.1.2 (case 26 MAR 2010, 05:51)
if (Compression = 1) and (szt > sz) then
sz := szt;
if sz = 0 then
sz := IFD.Stream.size - StripOffsets^[q];
if sz > 0 then
begin
if (Compression = 1) and (RowsPerStrip = ImageHeight) and (BitsPerSample = 8) then
begin
// to avoid allocating the full strip (useful when one strip contains the whole image)
sz := SamplesPerPixel * ImageWidth * (BitsPerSample div 8);
SetLength(buf, sz);
for i := 0 to RowsPerStrip-1 do
begin
IFD.Stream.Read(buf[0], sz);
Decompress1(context, bitmap, row+i, 0, @buf[0], sz, ImageWidth, 1, Progress); // decompress row
end;
end
else
begin
SetLength(buf, sz);
szt := sz;
if szt > IFD.Stream.Size then
szt := IFD.Stream.size - StripOffsets^[q];
szt := IFD.Stream.Read(buf[0], szt);
Decompress1(context, bitmap, row, 0, @buf[0], szt, ImageWidth, imin(RowsPerStrip, ImageHeight - row), Progress); // decompress strip (buffer)
end;
end;
inc(row, RowsPerStrip);
if Progress.Aborting^ then
break;
end;
end
else
if PlanarConfiguration = 2 then
begin
// channels are on separate strips
q := 0;
e := StripOffsets_Num div context.SamplesPerPixel;
while q < e do
begin
for c := 0 to context.SamplesPerPixel - 1 do
bufn[c] := nil;
try
for c := 0 to context.SamplesPerPixel - 1 do
begin
// channel "c"
szn[c] := StripByteCounts^[q + c*e];
getmem(bufn[c], szn[c]);
bufv[c] := bufn[c]; // bufv is actually sent to Decompress2, hence it can change pointers inside the array
IFD.Stream.Seek(IFD.StreamBase + StripOffsets^[q + c*e], soBeginning);
szn[c] := IFD.Stream.Read(bufn[c]^, szn[c]);
if context.FillOrder = 2 then
for i := 0 to szn[c]-1 do
ReverseBitsB( pbytearray(bufn[c])[i] );
end;
inc(q);
w := imin(RowsPerStrip, ImageHeight - row);
Decompress2(context, bitmap, row, bufv, szn, ImageWidth, w, Progress); // decompress strip (buffer)
finally
for c := 0 to context.SamplesPerPixel - 1 do
freemem(bufn[c]);
end;
inc(row, RowsPerStrip);
if Progress.Aborting^ then
break;
end;
end;
end;
end;
procedure PerformPredictor(context: TTIFFReaderContext; buf: pbyte; Width: integer; OneChannel: boolean = false);
var
ra1, ra2, ra3, ra4, rp1, rp2, rp3, rp4: pbyte;
dra1, dra2, dra3, drp1, drp2, drp3: pword;
ra, rp: array of pbyte;
z, v, i: integer;
begin
if (context.Predictor = 2) and ((context.Compression = 5) or (context.Compression = 8) or (context.Compression = 32946)) then
begin
// Predictor
if (context.BitsPerSample = 8) and ((context.SamplesPerPixel = 1) or OneChannel) then
begin
// 8 bits per sample - 1 sample per pixel
ra1 := @(pbytearray(buf)^[1]);
rp1 := buf;
for z := 1 to Width - 1 do
begin
inc(ra1^, rp1^);
inc(ra1);
inc(rp1);
end;
end
else
if (context.BitsPerSample = 16) and ((context.SamplesPerPixel = 1) or OneChannel) then
begin
// 16 bits per sample - 1 sample per pixel
dra1 := @(pwordarray(buf)^[1]);
drp1 := pword(buf);
for z := 1 to Width - 1 do
begin
inc(dra1^, drp1^);
inc(dra1);
inc(drp1);
end;
end
else
if (context.BitsPerSample = 8) and (context.SamplesPerPixel = 3) then
begin
// 8 bits per sample - 3 samples per pixel
ra1 := @(pbytearray(buf)^[3]);
ra2 := @(pbytearray(buf)^[4]);
ra3 := @(pbytearray(buf)^[5]);
rp1 := buf;
rp2 := @(pbytearray(buf)^[1]);
rp3 := @(pbytearray(buf)^[2]);
for z := 1 to width - 1 do
begin
inc(ra1^, rp1^);
inc(ra1, 3);
inc(rp1, 3);
inc(ra2^, rp2^);
inc(ra2, 3);
inc(rp2, 3);
inc(ra3^, rp3^);
inc(ra3, 3);
inc(rp3, 3);
end;
end
else
if (context.BitsPerSample = 8) and (context.SamplesPerPixel = 2) then
begin
// 8 bits per sample - 2 samples per pixel
ra1 := @(pbytearray(buf)^[2]);
ra2 := @(pbytearray(buf)^[3]);
rp1 := buf;
rp2 := @(pbytearray(buf)^[1]);
for z := 1 to width - 1 do
begin
inc(ra1^, rp1^);
inc(ra1, 2);
inc(rp1, 2);
inc(ra2^, rp2^);
inc(ra2, 2);
inc(rp2, 2);
end;
end
else
if (context.BitsPerSample = 16) and (context.SamplesPerPixel = 3) then
begin
// 16 bits per sample - 3 samples per pixel
dra1 := @(pwordarray(buf)^[3]);
dra2 := @(pwordarray(buf)^[4]);
dra3 := @(pwordarray(buf)^[5]);
drp1 := pword(buf);
drp2 := @(pwordarray(buf)^[1]);
drp3 := @(pwordarray(buf)^[2]);
for z := 1 to width - 1 do
begin
inc(dra1^, drp1^);
inc(dra1, 3);
inc(drp1, 3);
inc(dra2^, drp2^);
inc(dra2, 3);
inc(drp2, 3);
inc(dra3^, drp3^);
inc(dra3, 3);
inc(drp3, 3);
end;
end
else
if (context.BitsPerSample = 8) and (context.SamplesPerPixel = 4) then
begin
// 8 bits per sample - 4 samples per pixel
ra1 := @(pbytearray(buf)^[4]);
ra2 := @(pbytearray(buf)^[5]);
ra3 := @(pbytearray(buf)^[6]);
ra4 := @(pbytearray(buf)^[7]);
rp1 := buf;
rp2 := @(pbytearray(buf)^[1]);
rp3 := @(pbytearray(buf)^[2]);
rp4 := @(pbytearray(buf)^[3]);
for z := 1 to width - 1 do
begin
inc(ra1^, rp1^);
inc(ra1, 4);
inc(rp1, 4);
inc(ra2^, rp2^);
inc(ra2, 4);
inc(rp2, 4);
inc(ra3^, rp3^);
inc(ra3, 4);
inc(rp3, 4);
inc(ra4^, rp4^);
inc(ra4, 4);
inc(rp4, 4);
end;
end
else
if (context.BitsPerSample = 8) and (context.SamplesPerPixel > 4) then
begin
// 8 bits per sample - >4 samples per pixel
v := context.SamplesPerPixel;
SetLength(ra, v);
SetLength(rp, v);
for i := 0 to v-1 do
begin
ra[i] := @(pbytearray(buf)^[ v + i ]);
rp[i] := @(pbytearray(buf)^[ i ]);
end;
for z := 1 to width - 1 do
for i := 0 to v - 1 do
begin
inc(ra[i]^, rp[i]^);
inc(ra[i], v);
inc(rp[i], v);
end;
end;
end;
end;
// Decompress a row
// outBuffer = output buffer (if BitsPerSample>=8 and there isn't compression then it link to the input buffer)
// inBuffer = input buffer (current position)
// inBufferLen = length of xbuf
// Width= row size
// brow = row size in bytes (decompressed, packed)
// LZW = LZW decompressor Id
// predbuf = buffer of previous line for CCITT 2D decompression and ZIP compression
// CCITTposb = position of next bit to read for CCITT decompression (intput/output)
// return false if aborting
function GetNextLine(curline: integer; var outBuffer: pbyte; var inBuffer: pbyte; inBufferLen: integer; context: TTIFFReaderContext; Width, brow: integer; var LzwId: pointer; predbuf: pbyte; var CCITTposb: integer; var zipbuf: pbyte; var rlepos: integer): boolean;
var
z, v, v2, z2, cw: integer;
buf2: pbyte;
ra1: pbyte;
{$ifdef IEINCLUDEZLIB}
i: integer;
{$endif}
begin
result := true;
case context.Compression of
1: // NO COMPRESSION
begin
if context.BitsperSample >= 8 then
outBuffer := inBuffer
else
CopyMemory(outBuffer, inBuffer, brow);
if (context.FillOrder=2) and (context.BitsPerSample<=8) then // 3.0.3
begin
buf2 := outBuffer;
for z := 0 to brow - 1 do
begin
ReverseBitsB(buf2^);
inc(buf2);
end;
end;
inc(inBuffer, brow);
end;
2: // HUFFMAN (TIFF: CCITT 1D)
inc(inBuffer, CCITTHuffmanGetLine(outBuffer, inBuffer, inBufferLen, Width, context.FillOrder));
3:
if (context.T4Options and 1) = 0 then
// CCITT 3 - 1D (TIFF: Group 3 Fax, or T.4)
CCITTposb := _CCITTHuffmanGetLine(outBuffer, inBuffer, inBufferLen, Width, CCITTposb, context.FillOrder)
else
// CCITT 3 - 2D (TIFF: Group 3 Fax, or T.4 - 2D)
CCITTposb := CCITT3_2D_GetLine(outBuffer, inBuffer, inBufferLen, Width, predbuf, CCITTposb, context.FillOrder, true);
4:
// CCITT 4 (TIFF: Group 4 Fax, or T.6)
CCITTposb := CCITT3_2D_GetLine(outBuffer, inBuffer, inBufferLen, Width, predbuf, CCITTposb, context.FillOrder, (context.T4Options and $4) <> 0);
5: // LZW
begin
buf2 := context.LZWDecompFunc(inBuffer, brow, LzwId, context.FillOrder);
if buf2 <> nil then
CopyMemory(outBuffer, buf2, brow)
else
// aborting
result := false;
end;
8, 32946: // Deflate or ZIP
begin
{$ifdef IEINCLUDEZLIB}
if zipbuf = nil then
IEZDecompress(inBuffer, inBufferLen, pointer(zipbuf), i, 0);
buf2 := pbyte(zipbuf); inc(buf2, curline*brow);
CopyMemory(outBuffer, buf2, brow);
{$endif}
end;
32773: // RLE PACKBITS
begin
{$WARNINGS OFF}
buf2 := outBuffer;
z := 0; // reading position
v := brow;
cw := 0;
while (z < v) and (rlepos < inBufferLen) do
begin
if context.FillOrder = 2 then
ReverseBitsB(inBuffer^);
if (shortint(inBuffer^) >= 0) and (shortint(inBuffer^) <= 127) then
begin
// read next shortint(xbuf^)+1 bytes
v2 := shortint(inBuffer^);
inc(inBuffer);
inc(rlepos);
for z2 := 0 to v2 do
begin // it isn't v2-1, because I have first removed v2+1
if context.FillOrder = 2 then
ReverseBitsB(inBuffer^);
if cw < brow then
buf2^ := inBuffer^;
inc(buf2);
inc(inBuffer);
inc(rlepos);
inc(z);
inc(cw);
end;
end
else
if (shortint(inBuffer^) >= -127) and (shortint(inBuffer^) <= -1) then
begin
// repeat next byte for abs(shortint(xbuf^))+1 times
v2 := -1 * (shortint(inBuffer^)); // see up because there isn't the "+1"
inc(inBuffer);
inc(rlepos);
if context.FillOrder=2 then
ReverseBitsB(inBuffer^);
for z2 := 0 to v2 do
begin
if cw < brow then
buf2^ := inBuffer^;
inc(buf2);
inc(z);
inc(cw);
end;
inc(inBuffer);
inc(rlepos);
end
else
begin
inc(inBuffer);
inc(rlepos);
end;
end;
{$WARNINGS ON}
end;
end;
if context.BitsPerSample = 4 then
begin
// unpack nibble to byte
v := brow * 2 - 1;
v2 := brow - 1;
while v >= 0 do
begin
pbytearray(outBuffer)^[v] := pbytearray(outBuffer)^[v2] and $0F;
dec(v);
pbytearray(outBuffer)^[v] := (pbytearray(outBuffer)^[v2] and $F0) shr 4;
dec(v);
dec(v2);
end;
end
else
if (context.BitsPerSample > 1) and (context.BitsPerSample < 8) and ((context.Compression < 2) or (context.Compression > 4)) then
begin
// unpack groups of BitsPerSample bits in a byte
buf2 := allocmem(width);
ra1 := buf2;
v := 0;
for z := 0 to width * context.BitsPerSample - 1 do
begin
if _GetPixelbw(outBuffer, z) <> 0 then
ra1^ := ra1^ or (1 shl (context.BitsPerSample - 1 - v));
inc(v);
if v = context.BitsPerSample then
begin
v := 0;
inc(ra1);
end;
end;
copymemory(outBuffer, buf2, width);
freemem(buf2);
end;
if (context.BitsPerSample = 4) and (context.PhotometricInterpretation <= 1) then
begin
// image (4 bit, 16 levels) gray scale , convert to 8 bit
buf2 := outBuffer;
z := 0;
v := brow * 2;
while z < v do
begin
buf2^ := buf2^ * 17;
inc(buf2);
inc(z);
end;
end;
if (context.BitsPerSample = 2) and (context.PhotometricInterpretation <= 1) then
begin
// image (2 bit, 4 levels) gray scale , convert to 8 bit
buf2 := outBuffer;
z := 0;
v := brow * 4;
while z < v do
begin
buf2^ := buf2^ * 85;
inc(buf2);
inc(z);
end;
end;
if (context.BitsPerSample = 7) and (context.PhotometricInterpretation <= 1) then
begin
// image (7 bit, 128 levels) gray scale , convert to 8 bit
buf2 := outBuffer;
z := 0;
v := brow;
while z < v do
begin
buf2^ := buf2^ * 2;
inc(buf2);
inc(z);
end;
end;
end;
// decompress buffer (PlanarConfiguration=1)
// baserow = first row to fill in outbuf (y coordinate of the subimage)
// basecol = first col fill in outbuf (x coordinate of the subimage)
// inBuffer = compressed data
// inBufferLen = length of compressed data
// Width = width of the sub image (in pixel)
// Height = height of the sub image (in pixel)
procedure Decompress1(context: TTIFFReaderContext; outbuf: TIEBitmap; baserow: integer; basecol: integer; inBuffer: pbyte; inBufferLen: integer; Width, Height: integer; var Progress: TProgressRec);
var
q, w, i, e, j: integer;
px: PRGB;
pw, pw2: pword;
lxbuf, zbuf, predbuf, pxx, pb, buf1, palpha: pbyte;
decompBuf: pbyte;
wbuf: pword;
brow: integer; // dimensione in byte di una riga (decompressa, non scompattata)
CCITTposb: integer;
inv: boolean;
LzwId: pointer;
hasalpha: boolean;
ms, tbs: TMemoryStream;
tmpBMP: TIEBitmap;
NullProgress: TProgressRec;
raw: boolean;
ldpix, ldpiy, lwidth, lheight, lowidth, loheight, limcount: integer;
px_cmyk: PCMYK;
px_rgb48: PRGB48;
ycbcr, px_ycbcr: PYCBCR;
pba: pbytearray;
zipbuf: pbyte;
rlepos: integer;
lper: integer;
alpha: double;
begin
predbuf := nil;
zipbuf := nil;
rlepos := 0;
lper := -1;
// calc brow
if context.PlanarConfiguration = 1 then
brow := trunc(Width * context.SamplesPerPixel * (context.BitsPerSample / 8))
else
brow := trunc(Width * (context.BitsPerSample / 8));
if (brow / (context.BitsPerSample / 8) < Width) then
inc(brow);
LzwId := nil; // initialize Id of LZW compressor
// jpeg compression (DRAFT TIFF Technical Note #2), without jpeg tables
if (context.Compression = 7) and (context.JPEGTables = nil) then
begin
tmpBMP := nil;
ms := TMemoryStream.Create();
try
ms.Write(inBuffer^, inBufferLen);
ms.Position := 0;
tmpBMP := TIEBitmap.Create();
tmpBMP.Allocate(Width, Height, outbuf.PixelFormat);
if (context.StripOffsets_Num = 1) or (context.TileOffsets_Num = 1) then
NullProgress := Progress
else
begin
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per2 * val)<>lper) then
begin
lper := trunc(per2 * val);
fOnProgress(Sender, lper);
end;
end;
NullProgress := NullProgressRec( Progress.Aborting, False );
end;
//raw := context.PhotometricInterpretation=2; // saved as native RGB
raw := false;
// save dpi and size because ReadJpegStream overwrite them
ldpix := context.RefParams.DpiX;
ldpiy := context.RefParams.DpiY;
lwidth := context.RefParams.Width;
lheight := context.RefParams.Height;
lowidth := context.RefParams.OriginalWidth;
loheight := context.RefParams.OriginalHeight;
limcount := context.RefParams.ImageCount;
ReadJpegStream(ms, nil, tmpBMP, context.RefParams, NullProgress, false, raw, false, true, false, true, -1, context.RefParams.IsNativePixelFormat);
context.RefParams.ImageCount := limcount;
context.RefParams.DpiX := ldpix;
context.RefParams.DpiY := ldpiy;
context.RefParams.Width := lwidth;
context.RefParams.Height := lheight;
context.RefParams.OriginalWidth := lowidth;
context.RefParams.OriginalHeight := loheight;
if not NullProgress.Aborting^ then
begin
if raw then
for q := 0 to tmpBMP.Height - 1 do
begin
px := tmpBMP.Scanline[q];
_BGR2RGB(px, tmpBMP.Width);
end;
tmpBMP.CopyRectTo(outbuf, 0, 0, basecol, baserow, Width, Height, false);
end;
finally
FreeAndNil(tmpBMP);
FreeAndNil(ms);
end;
end
// jpeg compression (DRAFT TIFF Technical Note #2), with jpeg tables
else
if (context.Compression = 7) and (context.JPEGTables <> nil) then
begin
ms := TMemoryStream.Create;
try
tbs := nil;
tmpBMP := nil;
ms.Write(inBuffer^, inBufferLen);
ms.Position := 0;
tbs := TMemoryStream.Create;
tbs.Write(pbyte(context.JPEGTables)^, context.JPEGTablesSize);
tbs.Position := 0;
tmpBMP := TIEBitmap.Create;
tmpBMP.Allocate(Width, Height, outbuf.PixelFormat);
if (context.StripOffsets_Num = 1) or (context.TileOffsets_Num = 1) then
NullProgress := Progress
else
begin
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per2 * val)<>lper) then
begin
lper := trunc(per2 * val);
fOnProgress(Sender, lper);
end;
end;
NullProgress := NullProgressRec( Progress.Aborting, False );
end;
raw := context.PhotometricInterpretation = 2; // saved as native RGB
try
// save dpi and size because ReadJpegStream overwrite them
ldpix := context.RefParams.DpiX;
ldpiy := context.RefParams.DpiY;
lwidth := context.RefParams.Width;
lheight := context.RefParams.Height;
lowidth := context.RefParams.OriginalWidth;
loheight := context.RefParams.OriginalHeight;
limcount := context.RefParams.ImageCount;
ReadJpegStream(ms, tbs, tmpBMP, context.RefParams, NullProgress, false, raw, false, true, false, true, -1, context.RefParams.IsNativePixelFormat);
context.RefParams.ImageCount := limcount;
context.RefParams.DpiX := ldpix;
context.RefParams.DpiY := ldpiy;
context.RefParams.Width := lwidth;
context.RefParams.Height := lheight;
context.RefParams.OriginalWidth := lowidth;
context.RefParams.OriginalHeight := loheight;
except
end;
if not NullProgress.Aborting^ then
begin
if raw then
for q := 0 to tmpBMP.Height - 1 do
begin
px := tmpBMP.Scanline[q];
_BGR2RGB(px, tmpBMP.Width);
end;
tmpBMP.CopyRectTo(outbuf, 0, 0, basecol, baserow, Width, Height, false);
end;
finally
FreeAndNil(tmpBMP);
FreeAndNil(ms);
FreeAndNil(tbs);
end;
end
// without ColorMap, RGB and 24/32 bit (8 per pixel)
else
if (context.PhotometricInterpretation = 2) and
((context.SamplesPerPixel = 3) or (context.SamplesPerPixel = 4)) and
(context.BitsPerSample = 8) then
begin
hasalpha := ( ((context.SamplesPerPixel = 4) and (context.ExtraSamples = 2)) or
((context.SamplesPerPixel = 4) and (context.PhotometricInterpretation = 2))
) and (not context.IgnoreAlpha);
if hasalpha then
begin
context.AlphaChannel.Resize(outbuf.Width, outbuf.Height);
context.AlphaChannel.Full := false;
end;
if (context.Compression <> 1) then
getmem(decompBuf, Width * context.SamplesPerPixel);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
zbuf := decompBuf;
px := outbuf.Scanline[baserow + q];
inc(px, basecol);
if hasalpha then
begin
// Has Alpha Channel (3.0.3)
pb := context.AlphaChannel.ScanLine[baserow + q];
inc(pb, basecol);
for w := 0 to Width - 1 do
begin
px^ := PRGB(zbuf)^;
bswap(px^.r, px^.b);
inc(zbuf, 3);
pb^ := zbuf^; // alpha channel
inc(pb);
inc(zbuf);
inc(px);
end;
end
else
begin
// No Alpha Channel
IEGlobalSettings().ConvertColorFunction(zbuf, iecmsRGB, px, iecmsBGR, Width, context.RefParams);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// Error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) then
freemem(decompBuf);
end
// without ColorMap, RGB 24 + extra samples (only alpha is handled)
else
if (context.PhotometricInterpretation = 2) and
(context.SamplesPerPixel > 3) and (context.ExtraSamplesCount>0) and
(context.BitsPerSample = 8) then
begin
hasalpha := false;
if not context.IgnoreAlpha then
for q := 0 to context.ExtraSamplesCount-1 do
if (context.ExtraSamplesVal[q] = 1) or (context.ExtraSamplesVal[q] = 2) then
hasalpha := true;
if hasalpha then
begin
context.AlphaChannel.Resize(outbuf.Width, outbuf.Height);
context.AlphaChannel.Full := false;
end;
if (context.Compression <> 1) then
getmem(decompBuf, Width * context.SamplesPerPixel);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
zbuf := decompBuf;
px := outbuf.Scanline[baserow + q];
inc(px, basecol);
if hasalpha then
begin
// Has Alpha Channel
for w := 0 to Width - 1 do
begin
px^ := PRGB(zbuf)^;
bswap(px^.r, px^.b);
inc(zbuf, 3);
for j := 0 to context.ExtraSamplesCount-1 do
begin
if context.ExtraSamplesVal[j] = 1 then
begin
// premultiplied alpha
context.AlphaChannel.SetPixel(w, q + BaseRow, zbuf^);
alpha := dmax( zbuf^ / 255, 1/255 );
px^.r := trunc(px^.r / alpha);
px^.g := trunc(px^.g / alpha);
px^.b := trunc(px^.b / alpha);
end
else
if context.ExtraSamplesVal[j] = 2 then
begin
// unassociated alpha
context.AlphaChannel.SetPixel(w, q + BaseRow, zbuf^);
end;
inc(zbuf);
end;
inc(px);
end;
end
else
begin
// No Alpha Channel
//IEConvertColorFunction(zbuf, iecmsRGB, px, iecmsBGR, Width, context.RefParams);
for w := 0 to Width - 1 do
begin
px^ := PRGB(zbuf)^;
bswap(px^.r, px^.b);
inc(zbuf, 3);
for j := 0 to context.ExtraSamplesCount-1 do
inc(zbuf);
inc(px);
end;
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// Error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) then
freemem(decompBuf);
end
// without ColorMap, RGB and 48 bit (16 per sample)
else
if (context.PhotometricInterpretation = 2) and (context.SamplesPerPixel = 3) and (context.BitsPerSample = 16) then
begin
if (context.Compression <> 1) then
getmem(decompBuf, Width * context.SamplesPerPixel * 2);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
pw := pword(decompBuf);
if outbuf.PixelFormat=ie48RGB then
begin
// native pixel format
px_rgb48 := outbuf.Scanline[baserow+q];
inc(px_rgb48, basecol);
if context.LittleEndian then
// LittleEndian
for w := 0 to Width-1 do
begin
px_rgb48^.r := pw^; inc(pw);
px_rgb48^.g := pw^; inc(pw);
px_rgb48^.b := pw^; inc(pw);
inc(px_rgb48);
end
else
// BigEndian
for w := 0 to Width-1 do
begin
px_rgb48^.r := IESwapWord(pw^); inc(pw);
px_rgb48^.g := IESwapWord(pw^); inc(pw);
px_rgb48^.b := IESwapWord(pw^); inc(pw);
inc(px_rgb48);
end;
end
else
begin
// convert to 24 bit
px := outbuf.Scanline[baserow + q];
inc(px, basecol);
if not context.LittleEndian then
// BigEndian Format
IEGlobalSettings().ConvertColorFunction(pw, iecmsRGB48_SE, px, iecmsBGR, Width, context.RefParams)
else
// LittleEndian format
IEGlobalSettings().ConvertColorFunction(pw, iecmsRGB48, px, iecmsBGR, Width, context.RefParams);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// Error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) then
freemem(decompBuf);
end
// without ColorMap, RGB and 48 bit (16 per sample) + 1 extra channel
else
if (context.PhotometricInterpretation = 2) and (context.SamplesPerPixel = 4) and (context.BitsPerSample = 16) then
begin
if (context.Compression <> 1) then
getmem(decompBuf, Width * context.SamplesPerPixel * 2);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
pw := pword(decompBuf);
if outbuf.PixelFormat=ie48RGB then
begin
// native pixel format
px_rgb48 := outbuf.Scanline[baserow+q];
inc(px_rgb48, basecol);
if context.LittleEndian then
// LittleEndian
for w := 0 to Width-1 do
begin
px_rgb48^.r := pw^; inc(pw);
px_rgb48^.g := pw^; inc(pw);
px_rgb48^.b := pw^; inc(pw);
inc(pw); // discard extra channel
inc(px_rgb48);
end
else
// BigEndian
for w := 0 to Width-1 do
begin
px_rgb48^.r := IESwapWord(pw^); inc(pw);
px_rgb48^.g := IESwapWord(pw^); inc(pw);
px_rgb48^.b := IESwapWord(pw^); inc(pw);
inc(pw); // discard extra channel
inc(px_rgb48);
end;
end
else
begin
// convert to 24 bit
px := outbuf.Scanline[baserow + q];
inc(px, basecol);
// discard extra channel
px_rgb48 := PRGB48(pw);
pw2 := pw;
for w := 0 to Width-1 do
begin
px_rgb48^.r := pw2^; inc(pw2);
px_rgb48^.g := pw2^; inc(pw2);
px_rgb48^.b := pw2^; inc(pw2);
inc(pw2); // the extra channel
inc(px_rgb48);
end;
if not context.LittleEndian then
// BigEndian Format
IEGlobalSettings().ConvertColorFunction(pw, iecmsRGB48_SE, px, iecmsBGR, Width, context.RefParams)
else
// LittleEndian format
IEGlobalSettings().ConvertColorFunction(pw, iecmsRGB48, px, iecmsBGR, Width, context.RefParams);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// Error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) then
freemem(decompBuf);
end
// without ColorMap, RGB and 16 bit
else
if (context.PhotometricInterpretation = 2) and (context.SamplesPerPixel = 1) and (context.BitsPerSample = 16) then
begin
if (context.Compression <> 1) then
getmem(decompBuf, Width * context.SamplesPerPixel);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
zbuf := decompBuf;
px := outbuf.Scanline[baserow + q];
inc(px, basecol);
for w := 0 to Width - 1 do
begin
px^.r := (pword(zbuf)^ shr 10) shl 3;
px^.g := ((pword(zbuf)^ shr 5) and $1F) shl 3;
px^.b := (pword(zbuf)^ and $1F) shl 3;
inc(zbuf, 2);
inc(px);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// Error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) then
freemem(decompBuf);
end
// with RGB ColorMap (1 bit per pixel)
else
if (context.PhotometricInterpretation = 3) and (context.BitsPerSample = 1) and (context.SamplesPerPixel=1) then
begin
getmem(decompBuf, Width*2);
getmem(predbuf, brow); // previous line for CCITT 2D
try
with context do
begin
fillmemory(predbuf, brow, 255); // initialize
CCITTposb := 0;
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
// RGB colormap
pb := outbuf.scanline[baserow + q];
inc(pb, basecol);
if outbuf.PixelFormat = ie8p then
begin
for i := 0 to Width - 1 do
begin
if _GetPixelbw(decompBuf, i)<>0 then
pb^ := 1
else
pb^ := 0;
inc(pb);
end;
end
else
begin
px := outbuf.scanline[baserow + q];
inc(px, basecol);
for i := 0 to Width - 1 do
begin
if _GetPixelbw(decompBuf, i)<>0 then
px^ := ColorMap[1]
else
px^ := ColorMap[0];
inc(px);
end;
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
end;
finally
freemem(predbuf);
freemem(decompBuf);
end;
end
// with RGB ColorMap
else
if (context.PhotometricInterpretation = 3) and (context.BitsPerSample <= 8) then
begin
if (context.SamplesPerPixel = 2) and (context.BitsPerSample = 8) then
begin
// with alpha channel
if ((context.Compression <> 1)) then
getmem(decompBuf, Width * 2);
with context do
for q := 0 to Height - 1 do
begin
px := outbuf.scanline[baserow + q];
inc(px, basecol);
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
zbuf := decompBuf;
// RGB colormap
for i := 0 to Width - 1 do
begin
px^ := ColorMap[zbuf^];
inc(zbuf);
context.AlphaChannel.SetPixel(i + basecol, q + baserow, 255 - zbuf^);
inc(zbuf);
inc(px);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
if ((context.Compression <> 1)) then
freemem(decompBuf);
end
else
begin
// without alpha channel
if ((context.Compression <> 1)) or (context.BitsperSample < 8) then
getmem(decompBuf, Width * 2);
with context do
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
zbuf := decompBuf;
// RGB colormap
if outbuf.PixelFormat = ie8p then
begin
pb := outbuf.scanline[baserow + q];
inc(pb, basecol);
for i := 0 to Width - 1 do
begin
pb^ := zbuf^;
inc(zbuf);
inc(pb);
end;
end
else
begin
px := outbuf.scanline[baserow + q];
inc(px, basecol);
for i := 0 to Width - 1 do
begin
px^ := ColorMap[zbuf^];
inc(zbuf);
inc(px);
end;
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
if ((context.Compression <> 1)) or (context.BitsperSample < 8) then
freemem(decompBuf);
end;
end
// gray levels (8 bit)
else
if (context.PhotometricInterpretation <= 1) and (context.SamplesPerPixel = 1) and
((context.BitsPerSample = 8) or (context.BitsPerSample = 4) or (context.BitsPerSample=2) or (context.BitsPerSample=7)) then
begin
if (context.Compression <> 1) or (context.BitsPerSample = 4) or (context.BitsPerSample=2) or (context.BitsPerSample=7) then
getmem(decompBuf, Width + 4);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
zbuf := decompBuf;
if outbuf.PixelFormat = ie8g then
begin
pb := outbuf.scanline[baserow + q];
inc(pb, basecol);
for w := 0 to Width - 1 do
begin
pb^ := zbuf^;
inc(zbuf);
inc(pb);
end;
end
else
begin
px := outbuf.scanline[baserow + q];
inc(px, basecol);
if context.PhotometricInterpretation = 0 then
begin
for w := 0 to Width - 1 do
begin
i := 255 - zbuf^;
px^.r := i;
px^.g := i;
px^.b := i;
inc(zbuf);
inc(px);
end
end
else
begin
for w := 0 to Width - 1 do
begin
px^.r := zbuf^;
px^.g := zbuf^;
px^.b := zbuf^;
inc(zbuf);
inc(px);
end;
end;
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) or (context.BitsPerSample = 4) or (context.BitsPerSample=2) or (context.BitsPerSample=7) then
freemem(decompBuf);
end
// gray levels (8 bit) with SamplesPerPixel>=2 bytes
else
if (context.PhotometricInterpretation <= 1) and (context.SamplesPerPixel > 1) and ((context.BitsPerSample = 8)) then
begin
hasalpha := (not context.IgnoreAlpha);
if hasalpha then
begin
context.AlphaChannel.Resize(outbuf.Width, outbuf.Height);
context.AlphaChannel.Full := false;
end;
if ((context.Compression <> 1)) then
getmem(decompBuf, Width * context.SamplesPerPixel);
getmem(pxx, Width * context.SamplesPerPixel);
try
for q := 0 to Height - 1 do
begin
px := outbuf.Scanline[baserow + q];
inc(px, basecol);
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
zbuf := decompBuf;
if context.PhotometricInterpretation = 0 then
begin
for w := 0 to Width - 1 do
begin
i := 255 - zbuf^;
px^.r := i;
px^.g := i;
px^.b := i;
inc(zbuf);
if hasalpha then
context.AlphaChannel.SetPixel(w + basecol, q + baserow, zbuf^);
inc(zbuf, context.SamplesPerPixel - 1);
inc(px);
end
end
else
begin
pb := pxx;
for w := 0 to Width - 1 do
begin
pb^ := zbuf^;
inc(zbuf);
if hasalpha then
context.AlphaChannel.SetPixel(w + basecol, q + baserow, zbuf^);
inc(zbuf, context.SamplesPerPixel - 1);
inc(pb);
end;
IEGlobalSettings().ConvertColorFunction(pxx, iecmsGray8, px, iecmsBGR, Width, context.RefParams);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
finally
freemem(pxx);
if (context.Compression <> 1)then
freemem(decompBuf);
end;
end
// gray levels (16 bit)
else
if (context.PhotometricInterpretation <= 1) and (context.BitsPerSample = 16) then
begin
if ((context.Compression <> 1)) then
getmem(decompBuf, context.SamplesPerPixel * Width * 2);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
wbuf := pword(decompBuf);
// special case
if IECopy(context.Software, 1, 15) = 'Look@Molli v1.1' then
e := 4
else
e := 8;
//
if outbuf.PixelFormat = ie16g then
begin
// native pixel format
pw := outbuf.scanline[baserow + q];
inc(pw, basecol);
if context.PhotometricInterpretation = 0 then
for w := 0 to Width - 1 do
begin
if not context.LittleEndian then
wbuf^ := ((wbuf^ shr 8) and $00FF) or ((wbuf^ shl 8) and $FF00); // swapWord
pw^ := 65535 - wbuf^;
for i := 1 to context.SamplesPerPixel do
inc(wbuf);
inc(pw);
end
else
begin
for w := 0 to Width - 1 do
begin
if not context.LittleEndian then
wbuf^ := ((wbuf^ shr 8) and $00FF) or ((wbuf^ shl 8) and $FF00); // swapWord
pw^ := wbuf^;
if context.SampleFormat = 2 then // two's complement signed integer data?
begin
// convert from -32768..32767 range to 0..65535
pw^ := 32768 + PSmallInt(pw)^;
end;
for i := 1 to context.SamplesPerPixel do
inc(wbuf);
inc(pw);
end;
end
end
else
begin
// convert to BGR
px := outbuf.scanline[baserow + q];
inc(px, basecol);
if context.PhotometricInterpretation = 0 then
for w := 0 to Width - 1 do
begin
if not context.LittleEndian then
wbuf^ := ((wbuf^ shr 8) and $00FF) or ((wbuf^ shl 8) and $FF00); // swapWord
i := (65535 - wbuf^) shr e;
px^.r := i;
px^.g := i;
px^.b := i;
for i := 1 to context.SamplesPerPixel do
inc(wbuf);
inc(px);
end
else
for w := 0 to Width - 1 do
begin
if not context.LittleEndian then
wbuf^ := ((wbuf^ shr 8) and $00FF) or ((wbuf^ shl 8) and $FF00); // swapWord
if context.SampleFormat = 2 then // two's complement signed integer data?
begin
// convert from -32768..32767 range to 0..65535
wbuf^ := 32768 + PSmallInt(wbuf)^;
end;
i := wbuf^ shr e;
px^.r := i;
px^.g := i;
px^.b := i;
for i := 1 to context.SamplesPerPixel do
inc(wbuf);
inc(px);
end;
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
if context.Compression <> 1 then
freemem(decompBuf);
end
// gray levels (12 bit, packed) -> converted to 16 bit
else
if (context.PhotometricInterpretation <= 1) and (context.SamplesPerPixel = 1) and (context.BitsPerSample = 12) then
begin
if ((context.Compression <> 1)) then
getmem(decompBuf, Width * 2);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
w := 0;
if outbuf.PixelFormat = ie16g then
begin
pw := outbuf.scanline[baserow + q];
inc(pw, basecol);
if context.PhotometricInterpretation = 0 then
begin
// todo
end
else
begin
pb := decompBuf;
while w < Width do
begin
// 8 + 4
i := pb^ shl 4; // get 8 bit
inc(pb);
i := i or ((pb^ and $F0) shr 4); // get 4 bit
i := i shl 4; // 12 bit to 16 bit
pw^ := i;
inc(w);
inc(pw);
if w = Width then
break;
// 4 + 8
i := (pb^ and $0F) shl 8; // get 4 bit
inc(pb);
i := i or pb^; // get 8 bit
inc(pb);
i := i shl 4; // 12 bit to 16 bit
pw^ := i;
inc(w);
inc(pw);
end;
end;
end
else
begin
px := outbuf.scanline[baserow + q];
inc(px, basecol);
if context.PhotometricInterpretation = 0 then
begin
// todo
end
else
begin
pb := decompBuf;
while w < Width do
begin
// 8 + 4
i := pb^ shl 4; // get 8 bit
inc(pb);
i := i or ((pb^ and $F0) shr 4); // get 4 bit
i := i shr 4; // convert 12 bit to 8 bit
px^.b := i;
px^.g := i;
px^.r := i;
inc(w);
inc(px);
if w = Width then
break;
// 4 + 8
i := (pb^ and $0F) shl 8; // get 4 bit
inc(pb);
i := i or pb^; // get 8 bit
inc(pb);
i := i shr 4; // convert 12 bit to 8 bit
px^.b := i;
px^.g := i;
px^.r := i;
inc(w);
inc(px);
end;
end;
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
if context.Compression <> 1 then
freemem(decompBuf);
end
// Black/White
else
if (context.PhotometricInterpretation <= 1) and (context.SamplesPerPixel = 1) and (context.BitsPerSample = 1) then
begin
lxbuf := inBuffer;
getmem(decompBuf, Width);
getmem(predbuf, brow); // previous line for CCITT 2D
try
FillMemory(predbuf, brow, 255); // initialize
CCITTposb := 0;
if ((context.PhotometricInterpretation = 0) and ((context.Compression = 1) or (context.Compression >= 5))) or
((context.PhotometricInterpretation = 1) and ((context.Compression = 3) or (context.Compression = 4))) then
inv := true
else
inv := false;
for q := 0 to Height - 1 do
begin
pb := outbuf.ScanLine[baserow + q];
inc(pb, basecol shr 3);
if (uint64(inBuffer) - uint64(lxbuf)) >= inBufferLen then
break; // exceeded to read input data
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
zbuf := decompBuf;
pxx := pb;
case inv of
true:
for w := 0 to brow - 1 do
begin
pxx^ := not zbuf^;
inc(zbuf);
inc(pxx);
end;
false:
CopyMemory(pxx, zbuf, brow);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
finally
freemem(predbuf);
freemem(decompBuf);
end;
end
// CMYK
else
if (context.PhotometricInterpretation = 5) and (context.SamplesPerPixel = 4) and (context.BitsPerSample = 8) then
begin
if (context.Compression <> 1) then
getmem(decompBuf, Width * 4);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
if outbuf.PixelFormat=ieCMYK then
begin
// native CMYK format
px_cmyk := outbuf.scanline[baserow+q];
inc(px_cmyk, basecol);
pb := decompBuf;
for w := 0 to Width-1 do
begin
px_cmyk^.c := 255-pb^; inc(pb);
px_cmyk^.m := 255-pb^; inc(pb);
px_cmyk^.y := 255-pb^; inc(pb);
px_cmyk^.k := 255-pb^; inc(pb);
inc(px_cmyk);
end;
end
else
begin
// convert to 24bit
px := outbuf.Scanline[baserow + q];
inc(px, basecol);
// invert CMYK values, because IEConvertColorFunction wants normal values
pb := decompBuf;
for w := 0 to Width- 1 do
begin
pb^ := 255 - pb^; inc(pb);
pb^ := 255 - pb^; inc(pb);
pb^ := 255 - pb^; inc(pb);
pb^ := 255 - pb^; inc(pb);
end;
IEGlobalSettings().ConvertColorFunction(decompBuf, iecmsCMYK, px, iecmsBGR, Width, context.RefParams);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) then
freemem(decompBuf);
end
// CMYK
else
if (context.PhotometricInterpretation = 5) and (context.SamplesPerPixel >= 5) and (context.BitsPerSample = 8) then
begin
hasalpha := (context.SamplesPerPixel > 4) and (context.ExtraSamples > 0) and not context.IgnoreAlpha;
if hasalpha then
begin
context.AlphaChannel.Resize(outbuf.Width, outbuf.Height);
context.AlphaChannel.Full := false;
end;
if (context.Compression <> 1) then
getmem(decompBuf, Width * context.SamplesPerPixel);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
if outbuf.PixelFormat=ieCMYK then
begin
// native CMYK format
px_cmyk := outbuf.scanline[baserow+q];
inc(px_cmyk, basecol);
if hasalpha then
begin
palpha := context.AlphaChannel.ScanLine[baserow + q];
inc(palpha, basecol);
end
else
palpha := nil;
pb := decompBuf;
for w := 0 to Width-1 do
begin
px_cmyk^.c := 255-pb^; inc(pb);
px_cmyk^.m := 255-pb^; inc(pb);
px_cmyk^.y := 255-pb^; inc(pb);
px_cmyk^.k := 255-pb^; inc(pb);
if hasalpha then
begin
palpha^ := pb^; inc(palpha); inc(pb);
for e := 2 to context.SamplesPerPixel-4 do
inc(pb);
end
else
for e := 1 to context.SamplesPerPixel-4 do
inc(pb);
inc(px_cmyk);
end;
end
else
begin
// convert to 24bit
px := outbuf.scanline[baserow + q];
inc(px, basecol);
if hasalpha then
begin
palpha := context.AlphaChannel.ScanLine[baserow + q];
inc(palpha, basecol);
end
else
palpha := nil;
// invert CMYK values, because IEConvertColorFunction wants normal values
pb := decompBuf;
px_cmyk := PCMYK(decompBuf);
for w := 0 to Width- 1 do
begin
px_cmyk^.c := 255-pb^; inc(pb);
px_cmyk^.m := 255-pb^; inc(pb);
px_cmyk^.y := 255-pb^; inc(pb);
px_cmyk^.k := 255-pb^; inc(pb);
if hasalpha then
begin
palpha^ := pb^; inc(palpha); inc(pb);
for e := 2 to context.SamplesPerPixel-4 do
inc(pb);
end
else
for e := 1 to context.SamplesPerPixel-4 do
inc(pb);
inc(px_cmyk);
end;
IEGlobalSettings().ConvertColorFunction(decompBuf, iecmsCMYK, px, iecmsBGR, Width, context.RefParams);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) then
freemem(decompBuf);
end
// CMYK
else
if (context.PhotometricInterpretation = 5) and (context.SamplesPerPixel = 4) and (context.BitsPerSample = 16) then
begin
if (context.Compression <> 1) then
getmem(decompBuf, Width * 8);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
if not context.LittleEndian then
IEChangeEndiannessWordArray(pword(decompBuf), Width * 4);
PerformPredictor(context, decompBuf, Width);
if outbuf.PixelFormat=ieCMYK then
begin
// native CMYK format
px_cmyk := outbuf.scanline[baserow+q];
inc(px_cmyk, basecol);
pw := pword(decompBuf);
for w := 0 to Width-1 do
begin
px_cmyk^.c := 255-pw^ shr 8; inc(pw);
px_cmyk^.m := 255-pw^ shr 8; inc(pw);
px_cmyk^.y := 255-pw^ shr 8; inc(pw);
px_cmyk^.k := 255-pw^ shr 8; inc(pw);
inc(px_cmyk);
end;
end
else
begin
// convert to 24bit
px := outbuf.scanline[baserow + q];
inc(px, basecol);
// invert and shift right CMYK values, because IEConvertColorFunction wants normal values
pw := pword(decompBuf);
getmem(buf1, Width*4);
pb := pbyte(buf1);
for w := 0 to Width- 1 do
begin
pb^ := 255 - pw^ shr 8; inc(pb); inc(pw);
pb^ := 255 - pw^ shr 8; inc(pb); inc(pw);
pb^ := 255 - pw^ shr 8; inc(pb); inc(pw);
pb^ := 255 - pw^ shr 8; inc(pb); inc(pw);
end;
IEGlobalSettings().ConvertColorFunction(buf1, iecmsCMYK, px, iecmsBGR, Width, context.RefParams);
freemem(buf1);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) then
freemem(decompBuf);
end
// CIE L*a*b*
else
if (context.PhotometricInterpretation = 8) and (context.SamplesPerPixel = 3) and (context.BitsPerSample = 8) then
begin
if (context.Compression <> 1) then
getmem(decompBuf, Width * 3);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
//lab := PIELAB(buf);
px := outbuf.scanline[baserow + q];
inc(px, basecol);
IEGlobalSettings().ConvertColorFunction(decompBuf, iecmsCIELab, px, iecmsBGR, Width, context.RefParams);
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) then
freemem(decompBuf);
end
// YCbCr - YCbCrSubSampling = 2, 1
else
if (context.PhotometricInterpretation = 6) and (context.SamplesPerPixel = 3) and
(context.BitsPerSample = 8) and (context.YCbCrSubSampling[0]=2) and (context.YCbCrSubSampling[1]=1) then
begin
brow := Width*2;
if (context.Compression <> 1) then
getmem(decompBuf, Width * 3);
getmem(ycbcr, Width*3);
for q := 0 to Height - 1 do
begin
if GetNextLine(q, decompBuf, inBuffer, inBufferLen, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf, rlepos) then
begin
PerformPredictor(context, decompBuf, Width);
// convert YCbCr: 2: 1 to 1: 1
pba := pbytearray(decompBuf);
px_ycbcr := ycbcr;
w := 0;
while w<width do
begin
px_ycbcr^.y := pba[0];
px_ycbcr^.Cb := pba[2];
px_ycbcr^.Cr := pba[3];
inc(px_ycbcr);
px_ycbcr^.y := pba[1];
px_ycbcr^.Cb := pba[2];
px_ycbcr^.Cr := pba[3];
inc(px_ycbcr);
inc(pbyte(pba), 4);
inc(w, 2);
end;
px := outbuf.scanline[baserow + q];
inc(px, basecol);
IEGlobalSettings().ConvertColorFunction(ycbcr, iecmsYCbCr, px, iecmsBGR, Width, context.RefParams);
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) and (trunc(per1 * val)<>lper) then
begin
lper := trunc(per1 * val);
fOnProgress(Sender, lper);
end;
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) then
freemem(decompBuf);
freemem(ycbcr);
end
// YCbCr - YCbCrSubSampling = 2, 2
else
if (context.PhotometricInterpretation = 6) and (context.SamplesPerPixel = 3) and
(context.BitsPerSample = 8) and (context.YCbCrSubSampling[0]=2) and (context.YCbCrSubSampling[1]=2) then
begin
(* not still working
brow := Width*3;
if (context.Compression <> 1) then
getmem(buf, Width * 3);
getmem(ycbcr, Width*3);
for q := 0 to Height- 1 do
begin
if GetNextLine(q, buf, xbuf, sz, context, Width, brow, LzwId, predbuf, CCITTposb, zipbuf) then
begin
PerformPredictor(context, buf, Width);
// convert YCbCr: 2: 2 to 1: 1
pba := pbytearray(buf);
px_ycbcr := ycbcr;
w := 0;
while w<width do
begin
px_ycbcr^.y := pba[2];
px_ycbcr^.Cb := 128;
px_ycbcr^.Cr := 128;
inc(px_ycbcr);
px_ycbcr^.y := pba[3];
px_ycbcr^.Cb := 128;
px_ycbcr^.Cr := 128;
inc(px_ycbcr);
inc(pbyte(pba), 6);
inc(w, 2);
end;
px := outbuf.scanline[baserow + q];
inc(px, basecol);
IEConvertColorFunction(ycbcr, iecmsYCbCr, px, iecmsBGR, Width, context.RefParams);
pba := pbytearray(buf);
px_ycbcr := ycbcr;
w := 0;
while w<width do
begin
px_ycbcr^.y := pba[2];
px_ycbcr^.Cb := 128;
px_ycbcr^.Cr := 128;
inc(px_ycbcr);
px_ycbcr^.y := pba[3];
px_ycbcr^.Cb := 128;
px_ycbcr^.Cr := 128;
inc(px_ycbcr);
inc(pbyte(pba), 6);
inc(w, 2);
end;
px := outbuf.scanline[baserow + q*2+1];
inc(px, basecol);
IEConvertColorFunction(ycbcr, iecmsYCbCr, px, iecmsBGR, Width, context.RefParams);
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * val));
end;
if Progress.Aborting^ then
break;
end
else
begin
// error detected
Progress.Aborting^ := True;
break;
end;
end;
if (context.Compression <> 1) then
freemem(buf);
freemem(ycbcr);
*)
end;
if (context.Compression = 5) and (LzwId<>nil) then
// free LZW compressor
context.LZWDecompFunc(nil, 0, LzwId, context.FillOrder);
if zipbuf<>nil then
freemem(zipbuf); // zip buffer
end;
// decompress buffer (PlanarConfiguration=2)
procedure Decompress2(context: TTIFFReaderContext; outbuf: TIEBitmap; baserow: integer; xbufn: array of pbyte; szn: array of integer; Width, Height: integer; var Progress: TProgressRec);
var
q, w, c: integer;
px: PRGB;
bufv, bufn, zbufn: array [0..IEMAXEXTRASAMPLES-1] of pbyte;
//pw_srcn: array [0..IEMAXEXTRASAMPLES-1] of pword;
predbuf: pbyte;
LZWn: array [0..IEMAXEXTRASAMPLES-1] of pointer;
brow: integer; // size in byte of one row (decompressed, not compacted)
CCITTposb: integer;
zipbufn: array [0..IEMAXEXTRASAMPLES-1] of pbyte;
rleposn: array [0..IEMAXEXTRASAMPLES-1] of integer;
cmyk_buf: ^TCMYKROW;
px_cmyk: PCMYK;
//px_srcRGB48, px_dstRGB48: PRGB48;
RGB48_src: array of TRGB48;
px_byte: pbyte;
px_srcword, px_dstword: pword;
byte_src: array of byte;
begin
predbuf := nil;
cmyk_buf := nil;
for c := 0 to IEMAXEXTRASAMPLES-1 do
begin
zipbufn[c] := nil;
rleposn[c] := 0;
LZWn[c] := nil;
bufn[c] := nil;
bufv[c] := nil;
end;
// calc brow
brow := trunc(Width * (context.BitsPerSample / 8));
if (context.BitsPerSample = 4) and (Width and 1 <> 0) then
inc(brow);
try
if (context.PhotometricInterpretation = 3) and (context.SamplesPerPixel = 1) and (context.BitsPerSample = 8) then
begin
// with ColorMap, RGB 24 bit (8bits per pixel)
if context.Compression <> 1 then
begin
getmem(bufv[0], Width);
bufn[0] := bufv[0];
end;
for q := 0 to Height - 1 do
begin
if not GetNextLine(q, bufn[0], xbufn[0], szn[0], context, Width, brow, LZWn[0], predbuf, CCITTposb, zipbufn[0], rleposn[0]) then
begin
Progress.Aborting^ := True;
exit; // memory released in "finally"
end;
zbufn[0] := bufn[0];
if outbuf.PixelFormat = ie8p then
begin
px_byte := outbuf.Scanline[baserow + q];
for w := 0 to Width - 1 do
begin
px_byte^ := zbufn[0]^;
inc(zbufn[0]);
inc(px_byte);
end;
PerformPredictor(context, outbuf.scanline[baserow + q], Width);
end
else
begin
px := outbuf.Scanline[baserow + q];
for w := 0 to Width - 1 do
begin
px^.r := context.ColorMap[zbufn[0]^].r;
px^.g := context.ColorMap[zbufn[0]^].g;
px^.b := context.ColorMap[zbufn[0]^].b;
inc(zbufn[0]);
inc(px);
end;
PerformPredictor(context, outbuf.scanline[baserow + q], Width);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * val));
end;
if Progress.Aborting^ then
break;
end;
end
else
if (context.PhotometricInterpretation = 2) and (context.SamplesPerPixel = 3) and (context.BitsPerSample = 8) then
begin
// without ColorMap, RGB 24 bit (8bits per pixel)
if context.Compression <> 1 then
for c := 0 to context.SamplesPerPixel - 1 do
begin
getmem(bufv[c], Width);
bufn[c] := bufv[c];
end;
for q := 0 to Height - 1 do
begin
for c := 0 to context.SamplesPerPixel - 1 do
begin
if not GetNextLine(q, bufn[c], xbufn[c], szn[c], context, Width, brow, LZWn[c], predbuf, CCITTposb, zipbufn[c], rleposn[c]) then
begin
Progress.Aborting^ := True;
exit; // memory released in "finally"
end;
zbufn[c] := bufn[c];
end;
px := outbuf.Scanline[baserow + q];
for w := 0 to Width - 1 do
begin
px^.r := zbufn[0]^;
inc(zbufn[0]);
px^.g := zbufn[1]^;
inc(zbufn[1]);
px^.b := zbufn[2]^;
inc(zbufn[2]);
inc(px);
end;
PerformPredictor(context, outbuf.scanline[baserow+q], Width);
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * val));
end;
if Progress.Aborting^ then
break;
end;
end
else
if (context.PhotometricInterpretation = 2) and (context.SamplesPerPixel = 3) and (context.BitsPerSample = 16) then
begin
// without ColorMap, RGB - 48 bit (16bits per pixel)
if context.Compression <> 1 then
SetLength(byte_src, Width * 2);
SetLength(RGB48_src, Width);
for q := 0 to Height - 1 do
begin
for c := 0 to context.SamplesPerPixel - 1 do
begin
px_byte := @byte_src[0];
if not GetNextLine(q, px_byte, xbufn[c], szn[c], context, Width, brow, LZWn[c], predbuf, CCITTposb, zipbufn[c], rleposn[c]) then
begin
Progress.Aborting^ := True;
exit;
end;
PerformPredictor(context, px_byte, Width);
px_srcword := pword(px_byte);
px_dstword := @RGB48_src[0];
inc(px_dstword, c);
for w := 0 to Width - 1 do
begin
px_dstword^ := px_srcword^;
inc(px_srcword);
inc(px_dstword, 3);
end;
end;
if outbuf.PixelFormat = ie48RGB then
begin
CopyMemory(outbuf.Scanline[baserow + q], @RGB48_src[0], Width * sizeof(TRGB48));
end
else
if outbuf.PixelFormat = ie24RGB then
begin
IEGlobalSettings().ConvertColorFunction(@RGB48_src[0], iecmsRGB48, outbuf.Scanline[baserow + q], iecmsBGR, Width, context.RefParams);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * val));
end;
if Progress.Aborting^ then
break;
end;
end
else
if (context.PhotometricInterpretation = 5) and (context.SamplesPerPixel >= 4) and (context.BitsPerSample = 8) then
begin
// CMYK
if (context.Compression <> 1) then
for c := 0 to context.SamplesPerPixel-1 do
begin
getmem(bufv[c], Width * context.SamplesPerPixel);
bufn[c] := bufv[c];
end;
getmem(cmyk_buf, sizeof(TCMYK)*Width);
for q := 0 to Height - 1 do
begin
for c := 0 to context.SamplesPerPixel-1 do
begin
if not GetNextLine(q, bufn[c], xbufn[c], szn[c], context, Width, brow, LZWn[c], predbuf, CCITTposb, zipbufn[c], rleposn[c]) then
begin
Progress.Aborting^ := True;
exit; // memory released in "finally"
end;
zbufn[c] := bufn[c];
PerformPredictor(context, bufn[c], Width, true);
end;
if outbuf.PixelFormat=ieCMYK then
begin
// native CMYK format
px_cmyk := outbuf.Scanline[baserow + q];
for w := 0 to Width-1 do
begin
px_cmyk^.c := 255 - zbufn[0]^; inc(zbufn[0]);
px_cmyk^.m := 255 - zbufn[1]^; inc(zbufn[1]);
px_cmyk^.y := 255 - zbufn[2]^; inc(zbufn[2]);
px_cmyk^.k := 255 - zbufn[3]^; inc(zbufn[3]);
inc(px_cmyk);
end;
end
else
begin
// convert to 24bit
px := outbuf.scanline[baserow + q];
// invert CMYK values, because IEConvertColorFunction wants normal values
for w := 0 to Width- 1 do
begin
cmyk_buf[w].c := 255 - zbufn[0]^; inc(zbufn[0]);
cmyk_buf[w].m := 255 - zbufn[1]^; inc(zbufn[1]);
cmyk_buf[w].y := 255 - zbufn[2]^; inc(zbufn[2]);
cmyk_buf[w].k := 255 - zbufn[3]^; inc(zbufn[3]);
end;
IEGlobalSettings().ConvertColorFunction(cmyk_buf, iecmsCMYK, px, iecmsBGR, Width, context.RefParams);
end;
// OnProgress
with Progress do
begin
inc(val);
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * val));
end;
if Progress.Aborting^ then
break;
end;
end
finally
for c := 0 to IEMAXEXTRASAMPLES-1 do
begin
if bufv[c]<>nil then
freemem(bufv[c]);
if (context.Compression=5) and (LZWn[c]<>nil) then
context.LZWDecompFunc(nil, 0, LZWn[c], context.FillOrder);
if zipbufn[c]<>nil then
freemem(zipbufn[c]);
end;
if cmyk_buf<>nil then
freemem(cmyk_buf);
end;
end;
procedure LoadSimpleJpegV6(IFD: TIETIFFIFDReader; context: TTIFFReaderContext; var Bitmap: TIEBitmap; var Progress: TProgressRec);
var
ms: TMemoryStream;
ioparams: TIOParams;
l: integer;
tlr: integer;
i: integer;
tmpBMP: TIEBitmap;
NullProgress: TProgressRec;
w: word;
begin
ioparams := TIOParams.Create( nil );
ms := TMemoryStream.Create;
try
if (context.StripByteCounts <> nil) then
begin
Bitmap.Allocate(context.ImageWidth, context.ImageHeight, ie24RGB);
tmpBMP := TIEBitmap.Create;
try
for i := 0 to context.StripOffsets_Num - 1 do
begin
ms.Clear;
IFD.Stream.Seek(IFD.StreamBase + context.JPEGInterchangeFormat, soBeginning);
if context.JPEGInterchangeFormatLength > 0 then
IECopyFrom(ms, IFD.Stream, context.JPEGInterchangeFormatLength);
if i>0 then
begin
IFD.Stream.Seek(IFD.StreamBase + context.StripOffsets^[0], soBeginning);
IFD.Stream.Seek(2, soCurrent);
IFD.Stream.Read(w, 2); w := IESwapWord(w);
IFD.Stream.Seek(-4, soCurrent);
if w + 2 > 0 then
IECopyFrom(ms, IFD.Stream, w + 2);
end;
IFD.Stream.Seek(IFD.StreamBase + context.StripOffsets^[i], soBeginning);
l := i64min( context.StripByteCounts[i] , IFD.Stream.Size - IFD.Stream.Position );
if l > 0 then
IECopyFrom(ms, IFD.Stream, l);
ms.position := 0;
if context.StripOffsets_Num>1 then
NullProgress := NullProgressRec( Progress.Aborting, False )
else
NullProgress := Progress;
tlr := ReadJpegStream(ms, nil, tmpBMP, ioparams, NullProgress, false, false, false, false, true, false, context.RowsPerStrip, ioparams.IsNativePixelFormat);
if (tlr > (context.RowsPerStrip div 2)) and Progress.Aborting^ then
Progress.Aborting^ := false; // >50% read, acceptable (2.3.1 - ref: tif\8907_1_0_Problem_greyscaleJPEG_image.tif)
tmpBMP.CopyRectTo(Bitmap, 0, 0, 0, i * context.RowsPerStrip, context.ImageWidth, context.RowsPerStrip, false);
with Progress do
if assigned(fOnProgress) then
fOnProgress(Sender, trunc( i / context.StripOffsets_Num * 100 ));
end;
finally
tmpBMP.free;
end;
end
else
begin
if (context.JPEGInterchangeFormat = 0) and (context.StripOffsets <> nil) then
// sometimes jpeg 6 is included in a strip instead of JPEGInterchangeFormat tag
IFD.Stream.Seek(IFD.StreamBase + context.StripOffsets^[0], soBeginning)
else
IFD.Stream.Seek(IFD.StreamBase + context.JPEGInterchangeFormat, soBeginning);
l := IEGetJpegLength(IFD.Stream); // sometimes JPEGInterchangeFormatLength is invalid and not cover the entire jpeg, then IEGetJpegLength is needed
if (l >= 0) and (IFD.Stream.Position+ l <= IFD.Stream.Size) then
begin
if l > 0 then
IECopyFrom(ms, IFD.Stream, l);
ms.position := 0;
ReadJpegStream(ms, nil, Bitmap, ioparams, Progress, false, false, false, false, true, true, -1, ioparams.IsNativePixelFormat);
end;
end;
finally
FreeAndNil(ms);
FreeAndNil(ioparams);
end;
end;
procedure LoadIPTC(IFD: TIETIFFIFDReader; context: TTIFFReaderContext; Params: TIOParams);
var
data: array of byte;
t: integer;
begin
Params.IPTC_Info.Clear();
t := IFD.FindTAG(IETIFFTAG_IPTC);
if t >= 0 then
begin
SetLength(data, IFD.GetDataLengthInBytes(t));
IFD.Stream.Seek(IFD.StreamBase + IFD.GetDataPos(t), soBeginning);
IFD.Stream.Read(data[0], length(data));
Params.IPTC_Info.LoadFromStandardBuffer(@data[0], length(data));
end;
end;
procedure LoadXMP(IFD: TIETIFFIFDReader; context: TTIFFReaderContext; Params: TIOParams);
var
t: integer;
info: AnsiString;
dpos, dnum: int64;
dtyp: word;
begin
Params.XMP_Info := '';
t := IFD.FindTAG(IETIFFTAG_XMP);
if (t >= 0) then
begin
dnum := IFD.GetDataNum(t);
dpos := IFD.GetDataPos(t);
dtyp := IFD.GetDataType(t);
if ((dtyp = IETIFFTYPE_BYTE) or (dtyp = IETIFFTYPE_UNDEFINED)) then
begin
IFD.Stream.Seek(IFD.StreamBase + dpos, soBeginning);
SetLength(info, dnum);
IFD.Stream.Read(info[1], dnum);
Params.XMP_Info := info;
end;
end;
end;
procedure ReadEXIFUserComment(IFD: TIETIFFIFDReader; Params: TIOParams);
var
tempAnsiString: AnsiString;
tempWideString: WideString;
wlen: integer;
begin
tempAnsiString := IFD.ReadString($9286, false);
wlen := length(tempAnsiString) - 8;
if wlen > 0 then
begin
Params.EXIF_UserCommentCode := IECopy(tempAnsiString, 1, 8);
if Params.EXIF_UserCommentCode = IEEXIFUSERCOMMENTCODE_UNICODE then
begin
// IEEXIFUSERCOMMENTCODE_UNICODE
SetLength(tempWideString, Ceil(wlen / 2));
CopyMemory(@tempWideString[1], @tempAnsiString[9], wlen);
Params.EXIF_UserComment := tempWideString;
end
else
if Params.EXIF_UserCommentCode = IEEXIFUSERCOMMENTCODE_ASCII then
begin
// IEEXIFUSERCOMMENTCODE_ASCII
Params.EXIF_UserComment := WideString(IECopy(tempAnsiString, 9, wlen));
end
else
begin
// IEEXIFUSERCOMMENTCODE_JIS, IEEXIFUSERCOMMENTCODE_UNDEFINED
Params.EXIF_UserComment := WideString(IECopy(tempAnsiString, 9, wlen));
end;
end
else
begin
Params.EXIF_UserCommentCode := #$55#$4E#$49#$43#$4F#$44#$45#$00; // default UNICODE
Params.EXIF_UserComment := ''; // default empty
end;
end;
procedure TIFFReadStream(Bitmap: TIEBitmap; Stream: TStream; var numi: integer; IOParams: TIOParams; var Progress: TProgressRec; Preview: boolean; var AlphaChannel: TIEMask; TranslateBase: boolean; IgnoreAlpha: boolean; IsExifThumb: boolean; IsEXIFData: boolean; ProvidedHeader: PTIFFHeader = nil);
var
context: TTIFFReaderContext;
begin
context := TTIFFReaderContext.Create();
try
context.ReadStream(Bitmap, Stream, numi, IOParams, Progress, Preview, AlphaChannel, TranslateBase, IgnoreAlpha, IsExifThumb, IsEXIFData, ProvidedHeader);
finally
context.Free();
end;
end;
// read a TIFF stream
// Bitmap: bitmap to write
// numi: images count (output)
procedure TTIFFReaderContext.ReadStream(Bitmap: TIEBitmap; Stream: TStream; var numi: integer; IOParams: TIOParams; var Progress: TProgressRec; Preview: boolean; var AlphaChannel: TIEMask; TranslateBase: boolean; IgnoreAlpha: boolean; IsExifThumb: boolean; IsEXIFData: boolean; ProvidedHeader: PTIFFHeader = nil);
var
PosIFD: int64;
q, w: integer;
xRes, yRes: double;
dd: double;
laccess: TIEDataAccess;
imageAllocationOk: boolean;
begin
numi := 0;
try
RefParams := IOParams;
// setup input stream
MainIFD.Stream := Stream;
if TranslateBase then
MainIFD.StreamBase := Stream.Position
else
MainIFD.StreamBase := 0;
// read header
if not TIFFReadHeader(Stream, ProvidedHeader, MainIFD.LittleEndian, MainIFD.IsBigTIFF, MainIFD.DataPosSize, PosIFD) then
begin
Progress.Aborting^ := True;
exit;
end;
LittleEndian := MainIFD.LittleEndian;
// read main IFD (of the selected image)
q := IOParams.TIFF_ImageIndex;
if not MainIFD.ReadIFD(q, PosIFD, numi) then
exit;
// Sub-IFD (loaded only on request, when TIFF_SubIndex > -1), replaces the main-IFD
if IOParams.TIFF_SubIndex > -1 then
begin
PosIFD := MainIFD.ReadInteger(IETIFFTAG_SUBIFD, IOParams.TIFF_SubIndex, 0);
if PosIFD > 0 then
begin
// replaces MainIFD
MainIFD.ReadIFD(0, PosIFD, q);
end;
end;
// EXIF-IFD
PosIFD := MainIFD.ReadInteger(IETIFFTAG_EXIFIFD, 0, 0);
if PosIFD > 0 then
begin
ExifIFD.LittleEndian := MainIFD.LittleEndian;
ExifIFD.Stream := MainIFD.Stream;
ExifIFD.StreamBase := IEIFI(isEXIFData, MainIFD.StreamBase, 0);
ExifIFD.IsBigTIFF := false;
ExifIFD.DataPosSize := 4;
ExifIFD.ReadIFD(0, PosIFD, q);
IOParams.EXIF_HasEXIFData := true;
end
else
if isEXIFData then
ExifIFD.Assign(MainIFD);
// Get GPS-EXIF data
PosIFD := MainIFD.ReadInteger(IETIFFTAG_EXIFGPSIFD, 0, 0);
if PosIFD > 0 then
begin
GpsIFD.LittleEndian := MainIFD.LittleEndian;
GpsIFD.Stream := MainIFD.Stream;
GpsIFD.StreamBase := 0;
GpsIFD.IsBigTIFF := false;
GpsIFD.DataPosSize := 4;
GpsIFD.ReadIFD(0, PosIFD, q);
end;
// Get Interoperability IFD
PosIFD := ExifIFD.ReadInteger(IETIFFTAG_INTEROPIFD, 0, 0);
if PosIFD > 0 then
begin
InteropIFD.LittleEndian := ExifIFD.LittleEndian;
InteropIFD.Stream := ExifIFD.Stream;
InteropIFD.StreamBase := 0;
InteropIFD.IsBigTIFF := false;
InteropIFD.DataPosSize := 4;
InteropIFD.ReadIFD(0, PosIFD, q);
end;
// Decode TAGS
TileWidth := MainIFD.ReadInteger(322, 0, -1);
TileLength := MainIFD.ReadInteger(323, 0, -1);
if (IOParams.TIFF_GetTile = -1) or (TileWidth = -1) or (TileLength = -1) then
begin
ImageWidth := MainIFD.ReadInteger(256, 0, 0);
ImageHeight := MainIFD.ReadInteger(257, 0, 0);
end
else
begin
ImageWidth := TileWidth;
ImageHeight := TileLength;
end;
SamplesPerPixel := MainIFD.ReadInteger(277, 0, 1);
if not ReadBitsPerSample(MainIFD, self) then
begin
Progress.Aborting^ := True;
exit;
end;
RowsPerStrip := imin( MainIFD.ReadInteger(278, 0, ImageHeight), ImageHeight);
if (RowsPerStrip = -1) or (RowsPerStrip = 0) then
RowsPerStrip := ImageHeight;
SampleFormat := MainIFD.ReadInteger(339, 0, 1);
PhotometricInterpretation := MainIFD.ReadInteger(262, 0, 2);
PlanarConfiguration := MainIFD.ReadInteger(284, 0, 1);
Orientation := MainIFD.ReadInteger(274, 0, 1);
Compression := MainIFD.ReadInteger(259, 0, 1);
Predictor := MainIFD.ReadInteger(317, 0, 1);
T4Options := MainIFD.ReadInteger(292, 0, 0);
T6Options := MainIFD.ReadInteger(293, 0, 0);
FillOrder := MainIFD.ReadInteger(266, 0, 1);
if (FillOrder <> 1) and (FillOrder <> 2) then
FillOrder := 1; // some tiffs have FillOrder<>[1, 2]
Software := MainIFD.ReadString(305);
JPEGProc := MainIFD.ReadInteger(512, 0, 0);
JPEGInterchangeFormat := MainIFD.ReadInteger(513, 0, 0);
JPEGInterchangeFormatLength := MainIFD.ReadInteger(514, 0, 0);
JPEGRestartInterval := MainIFD.ReadInteger(515, 0, 0);
w := imin(SamplesPerPixel, 7);
for q := 0 to w - 1 do
begin
JPEGLosslessPredictors[q] := MainIFD.ReadInteger(517, q, 0);
JPEGPointTransforms[q] := MainIFD.ReadInteger(518, q, 0);
JPEGQTables[q] := MainIFD.ReadInteger(519, q, 0);
JPEGDCTables[q] := MainIFD.ReadInteger(520, q, 0);
JPEGACTables[q] := MainIFD.ReadInteger(521, q, 0);
end;
ExtraSamples := MainIFD.ReadInteger(338, 0, 0);
TIFFReadExtraSamples(MainIFD, self);
YCbCrSubSampling[0] := MainIFD.ReadInteger(530, 0, 0);
if YCbCrSubSampling[0] = 0 then
YCbCrSubSampling[0] := 2;
YCbCrSubSampling[1] := MainIFD.ReadInteger(530, 1, 0);
if YCbCrSubSampling[1] = 0 then
YCbCrSubSampling[1] := 2;
StripOffsets_Num := MainIFD.ReadArrayIntegers(StripOffsets, 273);
StripByteCounts_Num := MainIFD.ReadArrayIntegers(StripByteCounts, 279);
TileOffsets_Num := MainIFD.ReadArrayIntegers(TileOffsets, 324);
TileByteCounts_Num := MainIFD.ReadArrayIntegers(TileByteCounts, 325);
// fix wrong files of ACDSee 3.1
if (SamplesPerPixel = 1) and (BitsPerSample = 1) and (Compression > 0) and (Compression < 5) and (PhotometricInterpretation = 2) then
PhotometricInterpretation := 0;
JPEGTables := MainIFD.ReadRawData(347, JPEGTablesSize); // for Compression=7
ReadColorMap(MainIFD, self);
ReadTransferFunction(MainIFD, self);
// IPTC
LoadIPTC(MainIFD, self, IOParams);
// XMP
LoadXMP(MainIFD, self, IOParams);
// Photoshop image resources information
IOParams.TIFF_PhotoshopImageResources := MainIFD.ReadRawDataAsArrayOfByte(IETIFFTAG_PHOTOSHOP);
// Photoshop "ImageSourceData"
IOParams.TIFF_PhotoshopImageSourceData := MainIFD.ReadRawDataAsArrayOfByte(37724);
{$ifdef IEINCLUDEIMAGINGANNOT}
// Wang annotations
LoadWang(MainIFD, IOParams);
{$endif}
// ImageEn annotations
LoadImageEnAnnot(MainIFD, IOParams);
// ICC profile
LoadICC(MainIFD, IOParams);
// set TIOParams parameters
with IOParams do
begin
BitsPerSample := self.BitsPerSample;
SamplesPerPixel := self.SamplesPerPixel;
Width := self.ImageWidth;
Height := self.ImageHeight;
OriginalWidth := self.ImageWidth;
OriginalHeight := self.ImageHeight;
TIFF_BigTIFF := MainIFD.IsBigTIFF;
if self.LittleEndian then
TIFF_ByteOrder := ioLittleEndian
else
TIFF_ByteOrder := ioBigEndian;
TIFF_ImageCount := numi;
TIFF_Orientation := self.Orientation;
case self.Compression of
1: TIFF_Compression := ioTIFF_UNCOMPRESSED;
2: TIFF_Compression := ioTIFF_CCITT1D;
3: if self.T4Options and 1 = 0 then
TIFF_Compression := ioTIFF_G3FAX1D
else
TIFF_Compression := ioTIFF_G3FAX2D;
4: TIFF_Compression := ioTIFF_G4FAX;
5: TIFF_Compression := ioTIFF_LZW;
6: TIFF_Compression := ioTIFF_OLDJPEG;
7: TIFF_Compression := ioTIFF_JPEG;
32773: TIFF_Compression := ioTIFF_PACKBITS;
32946: TIFF_Compression := ioTIFF_ZIP;
8: TIFF_Compression := ioTIFF_DEFLATE;
else
TIFF_Compression := ioTIFF_UNKNOWN;
end;
case self.PhotometricInterpretation of
0: TIFF_PhotometInterpret := ioTIFF_WHITEISZERO;
1: TIFF_PhotometInterpret := ioTIFF_BLACKISZERO;
2: TIFF_PhotometInterpret := ioTIFF_RGB;
3: TIFF_PhotometInterpret := ioTIFF_RGBPALETTE;
4: TIFF_PhotometInterpret := ioTIFF_TRANSPMASK;
5: TIFF_PhotometInterpret := ioTIFF_CMYK;
6: TIFF_PhotometInterpret := ioTIFF_YCBCR;
8: TIFF_PhotometInterpret := ioTIFF_CIELAB;
end;
TIFF_PlanarConf := self.PlanarConfiguration;
TIFF_DocumentName := MainIFD.ReadString(269);
TIFF_ImageDescription := MainIFD.ReadString(270);
TIFF_PageName := MainIFD.ReadString(285);
TIFF_PageNumber := MainIFD.ReadInteger(297, 0, 0);
TIFF_PageCount := MainIFD.ReadInteger(297, 1, 0);
TIFF_FillOrder := self.FillOrder;
TIFF_NewSubfileType := MainIFD.ReadInteger(254, 0, 0);
// EXIF (not in sub IFD)
EXIF_ImageDescription := TIFF_ImageDescription;
EXIF_Make := MainIFD.ReadString(271);
EXIF_Model := MainIFD.ReadString(272);
EXIF_DateTime := MainIFD.ReadString(306);
EXIF_Orientation := self.Orientation;
EXIF_XResolution := MainIFD.ReadRational(282, 0, IEGlobalSettings().DefaultDPIX);
EXIF_YResolution := MainIFD.ReadRational(283, 0, IEGlobalSettings().DefaultDPIY);
EXIF_ResolutionUnit := MainIFD.ReadInteger(296, 0, 2);
EXIF_Software := self.Software;
EXIF_XPRating := MainIFD.ReadInteger($4746, 0, -1);
EXIF_XPTitle := MainIFD.ReadWideString($9C9B);
EXIF_XPComment := MainIFD.ReadWideString($9C9C);
EXIF_XPAuthor := MainIFD.ReadWideString($9C9D);
EXIF_XPKeywords := MainIFD.ReadWideString($9C9E);
EXIF_XPSubject := MainIFD.ReadWideString($9C9F);
EXIF_Artist := MainIFD.ReadString(315);
EXIF_WhitePoint[0] := MainIFD.ReadRational(318, 0, -1);
EXIF_WhitePoint[1] := MainIFD.ReadRational(318, 1, -1);
EXIF_YCbCrPositioning := MainIFD.ReadInteger(531, 0, -1);
for q := 0 to 5 do
EXIF_PrimaryChromaticities[q] := MainIFD.ReadRational(319, q, -1);
for q := 0 to 2 do
EXIF_YCbCrCoefficients[q] := MainIFD.ReadRational(529, q, -1);
for q := 0 to 5 do
EXIF_ReferenceBlackWhite[q] := MainIFD.ReadRational(532, q, -1);
EXIF_Copyright := MainIFD.ReadString(IETIFFTAG_COPYRIGHT);
// EXIF (in sub IFD)
EXIF_ExposureTime := ExifIFD.ReadRational($829A, 0, -1);
EXIF_FNumber := ExifIFD.ReadRational($829D, 0, -1);
EXIF_ExposureProgram := ExifIFD.ReadInteger($8822, 0, -1);
EXIF_ISOSpeedRatings[0] := ExifIFD.ReadInteger($8827, 0, 0);
EXIF_ISOSpeedRatings[1] := ExifIFD.ReadInteger($8827, 1, 0);
EXIF_ExifVersion := ExifIFD.ReadString($9000);
EXIF_DateTimeOriginal := ExifIFD.ReadString($9003);
EXIF_DateTimeDigitized := ExifIFD.ReadString($9004);
EXIF_CompressedBitsPerPixel := ExifIFD.ReadRational($9102, 0, 0);
EXIF_ShutterSpeedValue := ExifIFD.ReadRational($9201, 0, -1);
EXIF_ApertureValue := ExifIFD.ReadRational($9202, 0, -1);
EXIF_BrightnessValue := ExifIFD.ReadRational($9203, 0, -1000);
EXIF_ExposureBiasValue := ExifIFD.ReadRational($9204, 0, -1000);
EXIF_MaxApertureValue := ExifIFD.ReadRational($9205, 0, -1000);
EXIF_SubjectDistance := ExifIFD.ReadRational($9206, 0, -1);
EXIF_MeteringMode := ExifIFD.ReadInteger($9207, 0, -1);
EXIF_LightSource := ExifIFD.ReadInteger($9208, 0, -1);
EXIF_Flash := ExifIFD.ReadInteger($9209, 0, -1);
EXIF_FocalLength := ExifIFD.ReadRational($920A, 0, -1);
EXIF_SubsecTime := ExifIFD.ReadString($9290);
EXIF_SubsecTimeOriginal := ExifIFD.ReadString($9291);
EXIF_SubsecTimeDigitized := ExifIFD.ReadString($9292);
EXIF_FlashPixVersion := ExifIFD.ReadString($A000);
EXIF_ColorSpace := ExifIFD.ReadInteger($A001, 0, -1);
EXIF_ExifImageWidth := ExifIFD.ReadInteger($A002, 0, 0);
EXIF_ExifImageHeight := ExifIFD.ReadInteger($A003, 0, 0);
EXIF_RelatedSoundFile := ExifIFD.ReadString($A004);
EXIF_FocalPlaneXResolution := ExifIFD.ReadRational($A20E, 0, -1);
EXIF_FocalPlaneYResolution := ExifIFD.ReadRational($A20F, 0, -1);
EXIF_FocalPlaneResolutionUnit := ExifIFD.ReadInteger($A210, 0, -1);
EXIF_ExposureIndex := ExifIFD.ReadRational($A215, 0, -1);
EXIF_SensingMethod := ExifIFD.ReadInteger($A217, 0, -1);
EXIF_FileSource := ExifIFD.ReadInteger($A300, 0, -1);
EXIF_SceneType := ExifIFD.ReadInteger($A301, 0, -1);
EXIF_ExposureMode := ExifIFD.ReadInteger($A402, 0, -1);
EXIF_WhiteBalance := ExifIFD.ReadInteger($A403, 0, -1);
EXIF_DigitalZoomRatio := ExifIFD.ReadRational($A404, 0, -1);
EXIF_FocalLengthIn35mmFilm := ExifIFD.ReadInteger($A405, 0, -1);
EXIF_SceneCaptureType := ExifIFD.ReadInteger($A406, 0, -1);
EXIF_GainControl := ExifIFD.ReadInteger($A407, 0, -1);
EXIF_Contrast := ExifIFD.ReadInteger($A408, 0, -1);
EXIF_Saturation := ExifIFD.ReadInteger($A409, 0, -1);
EXIF_Sharpness := ExifIFD.ReadInteger($A40A, 0, -1);
EXIF_SubjectDistanceRange := ExifIFD.ReadInteger($A40C, 0, -1);
EXIF_ImageUniqueID := ExifIFD.ReadString($A420);
EXIF_CameraOwnerName := ExifIFD.ReadString($A430);
EXIF_BodySerialNumber := ExifIFD.ReadString($A431);
EXIF_LensMake := ExifIFD.ReadString($A433);
EXIF_LensModel := ExifIFD.ReadString($A434);
EXIF_LensSerialNumber := ExifIFD.ReadString($A435);
EXIF_Gamma := ExifIFD.ReadRational($A500, 0, -1);
for q := 0 to 3 do
EXIF_SubjectArea[q] := MainIFD.ReadInteger($9214, q, -1);
EXIF_SubjectLocationX := ExifIFD.ReadInteger($A214, 0, -1);
EXIF_SubjectLocationY := ExifIFD.ReadInteger($A214, 1, -1);
ReadEXIFUserComment(ExifIFD, IOParams); // tag $9286
ReadEXIFMakerNote(ExifIFD, IETIFFTAG_EXIFMAKERNOTE, EXIF_MakerNote);
// GPS-EXIF
if GpsIFD.NumTags > 0 then
begin
EXIF_GPSVersionID := convVersionIDtoStr(GpsIFD.ReadString($0));
EXIF_GPSLatitudeRef := GpsIFD.ReadString($1);
EXIF_GPSLatitudeDegrees := GpsIFD.ReadRational($2, 0, 0);
EXIF_GPSLatitudeMinutes := GpsIFD.ReadRational($2, 1, 0);
EXIF_GPSLatitudeSeconds := GpsIFD.ReadRational($2, 2, 0);
EXIF_GPSLongitudeRef := GpsIFD.ReadString($3);
EXIF_GPSLongitudeDegrees := GpsIFD.ReadRational($4, 0, 0);
EXIF_GPSLongitudeMinutes := GpsIFD.ReadRational($4, 1, 0);
EXIF_GPSLongitudeSeconds := GpsIFD.ReadRational($4, 2, 0);
EXIF_GPSAltitudeRef := IEIntToStr(GpsIFD.ReadInteger($5, 0, 0));
EXIF_GPSAltitude := GpsIFD.ReadRational($6, 0, 0);
EXIF_GPSTimeStampHour := GpsIFD.ReadRational($7, 0, 0);
EXIF_GPSTimeStampMinute := GpsIFD.ReadRational($7, 1, 0);
EXIF_GPSTimeStampSecond := GpsIFD.ReadRational($7, 2, 0);
EXIF_GPSSatellites := GpsIFD.ReadString($8);
EXIF_GPSStatus := GpsIFD.ReadString($9);
EXIF_GPSMeasureMode := GpsIFD.ReadString($A);
EXIF_GPSDOP := GpsIFD.ReadRational($B, 0, 0);
EXIF_GPSSpeedRef := GpsIFD.ReadString($C);
EXIF_GPSSpeed := GpsIFD.ReadRational($D, 0, 0);
EXIF_GPSTrackRef := GpsIFD.ReadString($E);
EXIF_GPSTrack := GpsIFD.ReadRational($F, 0, 0);
EXIF_GPSImgDirectionRef := GpsIFD.ReadString($10);
EXIF_GPSImgDirection := GpsIFD.ReadRational($11, 0, 0);
EXIF_GPSMapDatum := GpsIFD.ReadString($12);
EXIF_GPSDestLatitudeRef := GpsIFD.ReadString($13);
EXIF_GPSDestLatitudeDegrees := GpsIFD.ReadRational($14, 0, 0);
EXIF_GPSDestLatitudeMinutes := GpsIFD.ReadRational($14, 1, 0);
EXIF_GPSDestLatitudeSeconds := GpsIFD.ReadRational($14, 2, 0);
EXIF_GPSDestLongitudeRef := GpsIFD.ReadString($15);
EXIF_GPSDestLongitudeDegrees := GpsIFD.ReadRational($16, 0, 0);
EXIF_GPSDestLongitudeMinutes := GpsIFD.ReadRational($16, 1, 0);
EXIF_GPSDestLongitudeSeconds := GpsIFD.ReadRational($16, 2, 0);
EXIF_GPSDestBearingRef := GpsIFD.ReadString($17);
EXIF_GPSDestBearing := GpsIFD.ReadRational($18, 0, 0);
EXIF_GPSDestDistanceRef := GpsIFD.ReadString($19);
EXIF_GPSDestDistance := GpsIFD.ReadRational($1A, 0, 0);
EXIF_GPSDateStamp := GpsIFD.ReadString($1D);
AdjustGPSCoordinates();
end;
// Interoperability IFD
EXIF_InteropIndex := InteropIFD.ReadString($0001);
EXIF_InteropVersion := InteropIFD.ReadString($0002);
// Colormap
FreeColorMap;
if self.ColorMap_Num > 0 then
begin
fColorMapCount := self.ColorMap_Num;
getmem(fColorMap, self.ColorMap_Num * sizeof(TRGB));
CopyMemory(ColorMap, self.ColorMap, self.ColorMap_Num * sizeof(TRGB));
end;
// resolution unit and dpi
if EXIF_ResolutionUnit = 3 then
dd := CM_per_Inch
else
dd := 1;
xRes := EXIF_XResolution * dd;
yRes := EXIF_YResolution * dd;
DpiX := round( xRes );
DpiY := round( yRes );
if DpiX = 0 then
DpiX := IEGlobalSettings().DefaultDPIX;
if DpiY = 0 then
DpiY := IEGlobalSettings().DefaultDPIY;
EXIF_XResolution := xRes; // (re-set because DpiX=V assigns also EXIF_?Resolution)
EXIF_YResolution := yRes; // (re-set because DpiX=V assigns also EXIF_?Resolution)
TIFF_XPos := trunc(MainIFD.ReadRational(286, 0, 0) * dd);
TIFF_YPos := trunc(MainIFD.ReadRational(287, 0, 0) * dd);
if ((Width = 0) or (Height = 0)) and (not IsExifThumb) then
begin
Progress.Aborting^ := True;
exit;
end;
end;
if Compression = 5 then
begin
// verify that exists a LZW function for decompression
if assigned(IOParams.TIFF_LZWDecompFunc) then
LZWDecompFunc := IOParams.TIFF_LZWDecompFunc
else
if assigned(IEGlobalSettings().DefTIFF_LZWDECOMPFUNC) then
LZWDecompFunc := IEGlobalSettings().DefTIFF_LZWDECOMPFUNC
else
begin
Progress.Aborting^ := True;
exit;
end;
end;
self.IgnoreAlpha := IgnoreAlpha;
if not Preview then
begin
// Load the image
if not self.IgnoreAlpha then
begin
if (((SamplesPerPixel = 4) and (ExtraSamples = 2)) or
((SamplesPerPixel > 3) and (ExtraSamplesCount>0)) or
((SamplesPerPixel = 2) and (BitsPerSample = 8)) or
((SamplesPerPixel > 1) and (ExtraSamplesCount>0) and (ExtraSamplesVal[0] = 1)) or
((SamplesPerPixel = 4) and (PhotometricInterpretation = 2)))
and (not assigned(AlphaChannel)) then
// alpha required
AlphaChannel := TIEMask.Create;
if assigned(AlphaChannel) then
begin
AlphaChannel.AllocateBits(ImageWidth, ImageHeight, 8);
AlphaChannel.Fill(255);
end
else
self.IgnoreAlpha := true;
end;
self.AlphaChannel := AlphaChannel;
laccess := Bitmap.Access;
Bitmap.Access := [iedWrite]; // write only
if ((ImageWidth > 400) or (ImageHeight > 400)) and IsExifThumb then
begin
Progress.Aborting^ := True;
exit;
end;
if ((Compression = 6) or ((JPEGInterchangeFormat <> 0) and (Compression <> 5) and (Compression <> 7))) and (JPEGProc < 2) then
begin
LoadSimpleJpegV6(MainIFD, self, Bitmap, Progress);
end
else
begin
if (ImageWidth = 0) or (ImageHeight = 0) then
begin
Progress.Aborting^ := True;
exit;
end;
// adjust PhotometricInterpretation to 1 (black is zero) if SamplesPerPixel=1 and BitsPerSample=1 and PhotoMetricinterpretation = 2 (RGB)
if (BitsPerSample = 1) and (SamplesPerPixel = 1) and (PhotometricInterpretation = 2) then
begin
PhotometricInterpretation := 1;
IOParams.TIFF_PhotometInterpret := ioTIFF_BLACKISZERO;
end;
// allocate destination bitmap
if (BitsPerSample = 1) and (SamplesPerPixel = 1) and (PhotometricInterpretation <> 3) then
// black/white (1 bit gray scale)
imageAllocationOk := Bitmap.Allocate(ImageWidth, ImageHeight, ie1g)
else
if IOParams.IsNativePixelFormat then
begin
// native pixel formats
if (BitsPerSample = 8) and (SamplesPerPixel = 1) and (PhotometricInterpretation = 3) then
begin
// 8 bit palette
imageAllocationOk := Bitmap.Allocate(ImageWidth, ImageHeight, ie8p);
for q := 0 to IOParams.ColorMapCount - 1 do
Bitmap.Palette[q] := IOParams.ColorMap[q];
end
else
if (BitsPerSample = 8) and (SamplesPerPixel = 1) and (PhotometricInterpretation < 2) then
// 8 bit gray scale
imageAllocationOk := Bitmap.Allocate(ImageWidth, ImageHeight, ie8g)
else
if (BitsPerSample = 16) and (PhotometricInterpretation < 2) then
// 16 bit gray scale
imageAllocationOk := Bitmap.Allocate(ImageWidth, ImageHeight, ie16g)
else
if (BitsPerSample = 12) and (SamplesPerPixel = 1) and (PhotometricInterpretation < 2) then
// 12 bit gray scale (convert to 16 bit)
imageAllocationOk := Bitmap.Allocate(ImageWidth, ImageHeight, ie16g)
else
if (BitsPerSample = 8) and (SamplesPerPixel >= 4) and (PhotometricInterpretation = 5) then
// CMYK->x*8
imageAllocationOk := Bitmap.Allocate(ImageWidth, ImageHeight, ieCMYK)
else
if (BitsPerSample = 16) and (SamplesPerPixel = 4) and (PhotometricInterpretation = 5) then
// CMYK-4*16
imageAllocationOk := Bitmap.Allocate(ImageWidth, ImageHeight, ieCMYK)
else
if (BitsPerSample = 16) and (SamplesPerPixel = 3) and (PhotometricInterpretation = 2) then
// 48 bit RGB
imageAllocationOk := Bitmap.Allocate(ImageWidth, ImageHeight, ie48RGB)
else
// otherwise 24 bit RGB
imageAllocationOk := Bitmap.Allocate(ImageWidth, ImageHeight, ie24RGB);
end
else
// 24 bit RGB
imageAllocationOk := Bitmap.Allocate(ImageWidth, ImageHeight, ie24RGB);
if not imageAllocationOk then
begin
Progress.Aborting^ := True;
exit;
end;
if IsExifThumb then
Bitmap.Fill(0);
if (TileWidth > 0) or (TileLength > 0) then
begin
// tiled
if TileOffsets_Num > 0 then
Tiles2Bitmap(MainIFD, self, Bitmap, Progress)
else
if StripOffsets_Num > 0 then
begin
// old tiff, uses Strips instead of Tiles...
TileOffsets_Num := MainIFD.ReadArrayIntegers(TileOffsets, 273);
TileByteCounts_Num := MainIFD.ReadArrayIntegers(TileByteCounts, 279);
Tiles2Bitmap(MainIFD, self, Bitmap, Progress)
end;
end
else
begin
// stripped
if StripOffsets_Num > 0 then
Strips2Bitmap(MainIFD, self, Bitmap, Progress)
else
begin
Progress.Aborting^ := True;
exit;
end;
end;
end;
Bitmap.Access := laccess;
// adjust orientation if <>1
if IOParams.TIFF_EnableAdjustOrientation then
begin
IEAdjustEXIFOrientation(Bitmap, Orientation);
Orientation := 1;
end;
end;
finally
// ICC
if assigned(IOParams) and assigned(IOParams.fInputICC) then
begin
if IOParams.InputICCProfile.IsTransforming then
IOParams.InputICCProfile.FreeTransform()
else
if assigned(Bitmap) and not Preview then
Bitmap.ColorProfile.Assign(IOParams.InputICCProfile);
end;
end;
end;
//////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////
//**********************************************************************************//
//* WRITE TIFF *//
//**********************************************************************************//
////////////////////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////////////////
type
TTIFFWriterContext = class
LZWCompFunc: TTIFFLZWCompFunc; // LZW compression function
Compression: integer;
T4Options: integer;
FillOrder: integer;
Photomet: TIOTIFFPhotometInterpret;
Predictor: integer;
qt: TIEQuantizer;
BitsPerSample: integer;
jpegquality: integer; // jpeg quality
jpegcolorspace: TIOJPEGColorSpace;
RefParams: TIOParams;
hasalpha: boolean;
constructor Create();
destructor Destroy(); override;
end;
constructor TTIFFWriterContext.Create();
begin
inherited;
end;
destructor TTIFFWriterContext.Destroy();
begin
if qt <> nil then
FreeAndNil(qt);
inherited;
end;
procedure WriteEXIFMakerNote(IFD: TIETIFFIFDWriter; Stream: TStream; tagid: integer; tagsHandler: TIETagsHandler; var Aborting: boolean);
var
datapos: dword;
begin
if (((tagsHandler.Data.Size < 12) and (IEGlobalSettings().EXIFMakerNotesHandling = iemhDecodeOrMaintainRaw)) or (IEGlobalSettings().EXIFMakerNotesHandling = iemhDecodeAndSaveRaw))
and assigned(tagsHandler.UnparsedData) and (tagsHandler.UnparsedDataLength > 0) then
begin
// unparsed tags, write raw data
IEStreamWordAlign(Stream, Aborting);
IFD.AddTag(tagid, IETIFFTYPE_UNDEFINED, tagsHandler.UnparsedDataLength, Stream.Position);
SafeStreamWrite(Stream, Aborting, pbyte(tagsHandler.UnparsedData)^, tagsHandler.UnparsedDataLength);
end
else
if (tagsHandler.Data.Size > 12) then
begin
datapos := IEStreamWordAlign(stream, Aborting);
IFD.AddTag(tagid, IETIFFTYPE_UNDEFINED, tagsHandler.WriteToStream(Stream, 0), datapos);
end;
end;
// writes tag EXIF user comment
procedure WriteEXIFUserComment(IFD: TIETIFFIFDWriter; Stream: TStream; EXIF_UserCommentCode: AnsiString; EXIF_UserComment: WideString; var Aborting: boolean);
var
strLength: integer;
zerow: dword;
ansiTemp: AnsiString;
datanum, datapos: dword;
begin
if EXIF_UserCommentCode = '' then
EXIF_UserCommentCode := IEEXIFUSERCOMMENTCODE_UNICODE;
strLength := length(EXIF_UserComment);
if (strLength = 0) or (length(EXIF_UserCommentCode) <> 8) then
exit;
datapos := IEStreamWordAlign(Stream, Aborting);
zerow := 0;
if EXIF_UserCommentCode = IEEXIFUSERCOMMENTCODE_UNICODE then
begin
// IEEXIFUSERCOMMENTCODE_UNICODE
datanum := 8 + 2 * strLength + 2;
SafeStreamWrite(Stream, Aborting, EXIF_UserCommentCode[1], 8);
SafeStreamWrite(Stream, Aborting, EXIF_UserComment[1], 2 * strLength);
SafeStreamWrite(Stream, Aborting, zerow, 2);
end
else
if EXIF_UserCommentCode = IEEXIFUSERCOMMENTCODE_ASCII then
begin
// IEEXIFUSERCOMMENTCODE_ASCII
datanum := 8 + strLength + 1;
SafeStreamWrite(Stream, Aborting, EXIF_UserCommentCode[1], 8);
ansiTemp := AnsiString(EXIF_UserComment);
SafeStreamWrite(Stream, Aborting, ansiTemp[1], strLength);
SafeStreamWrite(Stream, Aborting, zerow, 1);
end
else
begin
// IEEXIFUSERCOMMENTCODE_JIS, IEEXIFUSERCOMMENTCODE_UNDEFINED
datanum := strLength * 2 + length(EXIF_UserCommentCode);
SafeStreamWrite(Stream, Aborting, EXIF_UserCommentCode[1], length(EXIF_UserCommentCode));
SafeStreamWrite(Stream, Aborting, EXIF_UserComment[1], strLength * 2);
end;
IFD.AddTag($9286, IETIFFTYPE_UNDEFINED, datanum, datapos);
end;
procedure WriteIPTC(IFD: TIETIFFIFDWriter; Stream: TStream; Params: TIOParams; var Aborting: boolean);
var
buf: pointer;
buflen: integer;
datanum: dword;
begin
Params.IPTC_Info.SaveToStandardBuffer(buf, buflen, false);
try
if buf <> nil then
begin
datanum := buflen div 4;
if (buflen and 7) <> 0 then
inc(datanum);
IFD.AddTag(IETIFFTAG_IPTC, IETIFFTYPE_LONG, datanum, IEStreamWordAlign(Stream, Aborting));
SafeStreamWrite(Stream, Aborting, pbyte(buf)^, buflen);
end;
finally
freemem(buf);
end;
end;
procedure WriteXMP(IFD: TIETIFFIFDWriter; Stream: TStream; Params: TIOParams; var Aborting: boolean);
begin
if Params.XMP_Info <> '' then
begin
IFD.AddTag(IETIFFTAG_XMP, IETIFFTYPE_BYTE, length(Params.XMP_Info), IEStreamWordAlign(Stream, Aborting));
SafeStreamWrite(Stream, Aborting, Params.XMP_Info[1], length(Params.XMP_Info));
end;
end;
procedure WriteICC(IFD: TIETIFFIFDWriter; Stream: TStream; Params: TIOParams; var Aborting: boolean);
begin
if assigned(Params.InputICCProfile) and Params.InputICCProfile.IsValid and not Params.InputICCProfile.IsApplied then
begin
IFD.AddTag(IETIFFTAG_ICC, IETIFFTYPE_UNDEFINED, Params.InputICCProfile.RawLength, IEStreamWordAlign(Stream, Aborting));
Params.InputICCProfile.SaveToStream(Stream, true);
end;
end;
{$ifdef IEINCLUDEIMAGINGANNOT}
procedure WriteWang(IFD: TIETIFFIFDWriter; Stream: TStream; Params: TIOParams; var Aborting: boolean);
var
buf: pointer;
buflen: integer;
begin
Params.ImagingAnnot.SaveToStandardBuffer(buf, buflen);
try
if buf <> nil then
begin
IFD.AddTag(IETIFFTAG_WANGIMAGING, IETIFFTYPE_BYTE, buflen, IEStreamWordAlign(Stream, Aborting));
SafeStreamWrite(Stream, Aborting, pbyte(buf)^, buflen);
end;
finally
freemem(buf);
end;
end;
{$endif}
procedure WriteImageEnAnnot(IFD: TIETIFFIFDWriter; Stream: TStream; Params: TIOParams; var Aborting: boolean);
var
buf: pointer;
buflen: integer;
begin
Params.ImageEnAnnot.SaveToBuffer(buf, buflen);
try
if buf <> nil then
begin
IFD.AddTag(IEGlobalSettings().ObjectsTIFFTag, IETIFFTYPE_BYTE, buflen, IEStreamWordAlign(Stream, Aborting));
SafeStreamWrite(Stream, Aborting, pbyte(buf)^, buflen);
end;
finally
freemem(buf);
end;
end;
// Writes rowbuf (of sz bytes) in Stream, PackBits compressed
procedure _WritePackBits(rowbuf: pbyte; sz: integer; Stream: TStream; var Aborting: boolean);
var
pa: pbytearray;
n, rl: integer;
si: shortint;
bp: integer;
procedure SavB;
var
qq: integer;
begin
// writes absolute bytes from bp to n-1
qq := n - bp;
if qq > 0 then
begin
// more bytes
si := qq - 1;
SafeStreamWrite(Stream, Aborting, si, 1);
SafeStreamWrite(Stream, Aborting, pbyte(@pa^[bp])^, qq);
end;
end;
begin
pa := pbytearray(rowbuf);
n := 0; // n is the initial position of the first group to compress
bp := 0;
while n < sz do
begin
// look for equal bytes
rl := 1;
while ((n + rl) < sz) and (pa^[n] = pa^[n + rl]) and (rl < 128) do
inc(rl);
if rl > 3 then
begin
SavB; // write absolute bytes from bp to n-1
// replicates bytes
si := -1 * (rl - 1);
SafeStreamWrite(Stream, Aborting, si, 1);
SafeStreamWrite(Stream, Aborting, pa^[n], 1);
inc(n, rl);
bp := n;
end
else
if (n - bp) = 128 then
begin
SavB;
bp := n;
end
else
inc(n);
end;
SavB; // writes absolute bytes from bp to n-1
end;
// old jpeg compression
procedure WriteOldJpeg(Stream: TStream; WBitmap: TIEBitmap; IFD: TIETIFFIFDWriter; context: TTIFFWriterContext; var Progress: TProgressRec);
var
iop: TIOParams;
ps1, ps2: integer;
ms: TMemoryStream;
pw: pword;
begin
iop := TIOParams.Create( nil );
ms := TMemoryStream.Create();
try
iop.JPEG_Quality := context.jpegquality;
iop.JPEG_ColorSpace := context.jpegcolorspace;
WriteJpegStream(ms, WBitmap, iop, Progress);
ps1 := Stream.Position;
IECopyFrom(Stream, ms, 0);
IFD.WriteSingleLong(514, ms.Size); // JPEGInterchangeFormatLength
IFD.WriteSingleLong(513, ps1); // JPEGInterchangeFormat
// search for SOS marker
ps2 := 0;
pw := ms.Memory;
while true do
begin
if pw^ = $DAFF then
break;
inc(pbyte(pw));
inc(ps2);
end;
IFD.WriteSingleLong(278, WBitmap.Height); // RowsPerStrip
IFD.WriteSingleLong(279, ms.Size - ps2); // StripByteCounts
IFD.WriteSingleLong(273, ps1 + ps2); // StripOffsets
IFD.WriteSingleShort(512, 1); // JPEGProc
IFD.WriteMultiShort(Stream, 530, [2, 2], Progress.Aborting^);
finally
ms.Free();
iop.Free();
end;
end;
// jpeg compression (DRAFT TIFF Technical Note #2)
procedure WriteStripJpeg(Stream: TStream; Bitmap: TIEBitmap; context: TTIFFWriterContext; var Progress: TProgressRec);
var
iop: TIOParams;
begin
iop := TIOParams.Create( nil );
try
iop.JPEG_Quality := context.jpegquality;
iop.JPEG_ColorSpace := context.jpegcolorspace;
WriteJpegStream(Stream, Bitmap, iop, Progress);
finally
iop.Free();
end;
end;
procedure WriteStrip(Stream: TStream; Bitmap: TIEBitmap; IFD: TIETIFFIFDWriter; context: TTIFFWriterContext; var Progress: TProgressRec);
const
MAXSTRIPDIM = 512 * 1024; // 512 K
var
row, q, ww, dbit, sbit: integer;
rowbuf, tmpbuf: array of byte;
bufb, pb: pbyte;
bufw: pword;
inrow, buf1, buf2: PRGB;
inrow_48, buf1_48, buf2_48: PRGB48;
buf1_cmyk, buf2_cmyk: PCMYK;
inrow_alpha, buf2_alpha: pbyte;
bwr, bb: byte; // byte to write
bwrl: integer; // remaining bits in bwr to write
p_byte, predline: pbyte; // predline allocated by compressing function
Samples: integer; // Samples per pixel
lzwid: pointer;
bitmapwidth1, bitmapheight1: integer;
StripsPerImage: integer;
RowsPerStrip: integer;
striprow: integer; // current row of strip
stripidx: integer; // current strip
pos_ar: array of dword;
siz_ar: array of dword;
p_word: pword;
zstream: TZCompressionStream;
rl: integer;
bitmapWidth: integer;
procedure FinalizeCompressors;
begin
if (context.Compression = 3) and (context.T4Options = 0) then
// finalize G3FAX1D
CCITTHuffmanPutLineG3(nil, 0, Stream, bwr, bwrl, Progress.Aborting^, context.FillOrder);
if (context.Compression = 3) and (context.T4Options = 1) then
// finalize G3FAX2D
CCITTHuffmanPutLineG32D(nil, 0, Stream, bwr, bwrl, predline, Progress.Aborting^, context.FillOrder);
if (context.Compression = 4) then
// finalize G4FAX
CCITTHuffmanPutLineG4(nil, 0, Stream, bwr, bwrl, predline, Progress.Aborting^, context.FillOrder);
if context.Compression = 5 then
// finalize LZW
context.LZWCompFunc(nil, 0, Stream, lzwid);
if (context.Compression = 32946) or (context.Compression = 8) then
// finalize zip
zstream.free;
end;
begin
if (context.Compression = 7) then
begin
StripsPerImage := 1;
RowsPerStrip := Bitmap.Height;
end
else
if (context.Compression = 32946) or (context.Compression = 8) then
begin
StripsPerImage := 1;
RowsPerStrip := Bitmap.Height;
case context.RefParams.TIFF_ZIPCompression of
0: zstream := TZCompressionStream.Create(Stream, zcFastest, 15);
1: zstream := TZCompressionStream.Create(Stream, zcDefault, 15);
2: zstream := TZCompressionStream.Create(Stream, zcMax, 15);
end;
end
else
begin
if context.RefParams.TIFF_StripCount = 0 then
StripsPerImage := imax((Bitmap.Height * Bitmap.RowLen) div MAXSTRIPDIM, 1)
else
StripsPerImage := context.RefParams.TIFF_StripCount;
RowsPerStrip := Bitmap.Height div StripsPerImage;
if frac(Bitmap.Height / StripsPerImage) > 0 then
inc(StripsPerImage);
end;
SetLength(pos_ar, StripsPerImage * 2);
SetLength(siz_ar, StripsPerImage * 2);
StripsPerImage := 0; // above values was only an estimation. Now calculates the actual value.
case context.Photomet of
ioTIFF_WHITEISZERO,
ioTIFF_BLACKISZERO,
ioTIFF_RGBPALETTE,
ioTIFF_TRANSPMASK: Samples := 1;
ioTIFF_CMYK: Samples := 4;
else
Samples := 3; // RGB, CIELab, etc...
end;
if bitmap.HasAlphaChannel and not bitmap.AlphaChannel.Full and ((samples = 3) or (samples = 4)) and ((context.Compression = 1) or (context.Compression = 32773) or (context.Compression = 5)) then
begin
context.hasalpha := true;
inc(Samples);
end;
bitmapwidth1 := bitmap.width - 1;
bitmapheight1 := bitmap.height - 1;
lzwid := nil;
if context.Compression = 7 then
begin
pos_ar[0] := Stream.Position;
WriteStripJpeg(Stream, Bitmap, context, Progress);
siz_ar[0] := Stream.Position - int64(pos_ar[0]);
StripsPerImage := 1;
end
else
begin
case Bitmap.PixelFormat of
ie8p, ie8g, ie16g:
begin
if context.Compression = 7 then
exit;
ww := (Samples * context.BitsPerSample * Bitmap.Width);
if (ww and 7) <> 0 then
ww := (ww div 8) + 1
else
ww := ww div 8;
Progress.per1 := 100 / Bitmap.Height;
SetLength(rowbuf, (Bitmap.Width * Samples) * imax(1, context.BitsPerSample div 8) + 4);
striprow := 0;
stripidx := 0;
pos_ar[0] := Stream.Position;
for row := 0 to BitmapHeight1 do
begin
// OnProgress
with Progress do
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * row));
// PALETTE or GRAYSCALE
if context.BitsPerSample = 8 then
begin
// 8 bits per pixel
p_byte := Bitmap.Scanline[row];
bufb := @rowbuf[0];
for q := 0 to BitmapWidth1 do
begin
bufb^ := p_byte^;
inc(p_byte);
inc(bufb);
end;
end
else
if context.BitsPerSample = 16 then
begin
// 16 bits per pixel (grayscale)
p_word := Bitmap.Scanline[row];
bufw := pword(@rowbuf[0]);
for q := 0 to BitmapWidth1 do
begin
bufw^ := p_word^;
inc(p_word);
inc(bufw);
end;
end
else
begin
// 7, 6, 5, 4, 3, 2 bits per pixel
// compact pixels in bytes
p_byte := Bitmap.Scanline[row];
dbit := 0; // dest bit (0..7)
bufb := @rowbuf[0]; // dest buffer
for q := 0 to BitmapWidth1 do
begin
bb := p_byte^;
for sbit := 0 to context.BitsPerSample - 1 do
begin
if (bb and (1 shl (context.BitsPerSample - 1 - sbit))) <> 0 then
// write 1
bufb^ := bufb^ or iebitmask1[dbit]
else
// write 0
bufb^ := bufb^ and not iebitmask1[dbit];
inc(dbit);
if dbit = 8 then
begin
dbit := 0;
inc(bufb);
end;
end;
inc(p_byte);
end;
end;
// from here in rowbuf there is the row do compress and write
case context.Compression of
1:
// NO COMPRESSION
SafeStreamWrite(Stream, Progress.Aborting^, rowbuf[0], ww);
5:
// LZW
context.LZWCompFunc(@rowbuf[0], ww, Stream, lzwid);
32773:
// PACKBITS
_WritePackBits(@rowbuf[0], ww, Stream, Progress.Aborting^);
32946:
// zip
SafeStreamWrite(zstream, Progress.Aborting^, rowbuf[0], ww);
end;
if Progress.Aborting^ then
break;
inc(striprow);
if (striprow = RowsPerStrip) or (row = BitmapHeight1) then
begin
FinalizeCompressors;
lzwid := nil;
//
siz_ar[stripidx] := Stream.Position - int64(pos_ar[stripidx]);
StripsPerImage := stripidx + 1;
striprow := 0;
if row < BitmapHeight1 then
begin
// this isn't the last one
inc(stripidx);
pos_ar[stripidx] := Stream.Position;
end;
end;
end; // of row for
end;
ie24RGB:
///////////// COLOR IMAGES
begin
if context.Compression = 7 then
exit;
// RGB/CMYK/CIELAB/PALETTE
if (Samples < 3) and (context.Photomet <> ioTIFF_RGBPALETTE) and (context.Photomet <> ioTIFF_BLACKISZERO) then
Samples := 3;
ww := (Samples * context.BitsPerSample * Bitmap.Width);
if (ww and 7) <> 0 then
ww := (ww div 8) + 1
else
ww := ww div 8;
Progress.per1 := 100 / Bitmap.Height;
SetLength(rowbuf, (Bitmap.Width * Samples) * imax(1, context.BitsPerSample div 8) + 4);
striprow := 0;
stripidx := 0;
pos_ar[0] := Stream.Position;
for row := 0 to BitmapHeight1 do
begin
// OnProgress
with Progress do
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * row));
// prepare buffer to write
if context.Photomet = ioTIFF_CMYK then
begin
// CMYK
inrow := Bitmap.Scanline[row];
// from BGR to CMYK
IEGlobalSettings().ConvertColorFunction(inrow, iecmsBGR, @rowbuf[0], iecmsCMYK, Bitmap.Width, context.RefParams);
pb := @rowbuf[0];
rl := Bitmap.Width * 4;
for q := 0 to rl - 1 do
begin
pb^ := 255 - pb^;
inc(pb);
end;
// insert alpha channel
if context.hasalpha then
begin
SetLength(tmpbuf, length(rowbuf));
inrow_alpha := Bitmap.AlphaChannel.ScanLine[row];
bitmapWidth := Bitmap.Width;
for q := 0 to bitmapWidth - 1 do
begin
tmpbuf[q * 5 + 0] := rowbuf[q * 4 + 0];
tmpbuf[q * 5 + 1] := rowbuf[q * 4 + 1];
tmpbuf[q * 5 + 2] := rowbuf[q * 4 + 2];
tmpbuf[q * 5 + 3] := rowbuf[q * 4 + 3];
tmpbuf[q * 5 + 4] := inrow_alpha^;
inc(inrow_alpha);
end;
rowbuf := tmpbuf;
end;
end
else
if context.Photomet = ioTIFF_CIELAB then
begin
// CIELAB
inrow := Bitmap.Scanline[row];
IEGlobalSettings().ConvertColorFunction(inrow, iecmsBGR, @rowbuf[0], iecmsCIELab, Bitmap.Width, context.RefParams);
end
else
if (context.Photomet = ioTIFF_RGBPALETTE) or (context.Photomet = ioTIFF_BLACKISZERO) then
begin
// PALETTE or GRAYSCALE
inrow := PRGB(Bitmap.Scanline[row]);
if context.BitsPerSample = 8 then
begin
// 8 bits per pixel
bufb := @rowbuf[0];
for q := 0 to BitmapWidth1 do
begin
bufb^ := context.qt.RGBIndex[inrow^];
inc(inrow);
inc(bufb);
end;
end
else
if context.BitsPerSample = 16 then
begin
// 16 bits per pixel (grayscale)
bufw := pword(@rowbuf[0]);
for q := 0 to BitmapWidth1 do
begin
bufw^ := context.qt.RGBIndex[inrow^] *257;
inc(inrow);
inc(bufw);
end;
end
else
begin
// 7, 6, 5, 4, 3, 2 bits per pixel
// compact pixels in bytes
dbit := 0; // dest bit (0..7)
bufb := @rowbuf[0]; // dest buffer
for q := 0 to BitmapWidth1 do
begin
bb := context.qt.RGBIndex[inrow^];
for sbit := 0 to context.BitsPerSample - 1 do
begin
if (bb and (1 shl (context.BitsPerSample - 1 - sbit))) <> 0 then
// write 1
bufb^ := bufb^ or iebitmask1[dbit]
else
// write 0
bufb^ := bufb^ and not iebitmask1[dbit];
inc(dbit);
if dbit = 8 then
begin
dbit := 0;
inc(bufb);
end;
end;
inc(inrow);
end;
end;
end
else
begin
// RGB
if context.Predictor = 2 then
begin
// Predictor, BGR to RGB
buf1 := PRGB(@rowbuf[BitmapWidth1 * 3]);
inrow := PRGB(Bitmap.Scanline[row]);
inc(inrow, BitmapWidth1);
buf2 := inrow;
dec(buf2);
for q := BitmapWidth1 downto 1 do
begin
buf1^.r := inrow^.b - buf2^.b;
buf1^.g := inrow^.g - buf2^.g;
buf1^.b := inrow^.r - buf2^.r;
dec(buf1);
dec(inrow);
dec(buf2);
end;
buf1^.r := inrow^.b;
buf1^.g := inrow^.g;
buf1^.b := inrow^.r;
end
else
if context.hasalpha then
begin
// RGB with alpha channel and no predictor
inrow := PRGB(Bitmap.Scanline[row]);
bufb := pbyte(@rowbuf[0]);
pb := Bitmap.AlphaChannel.Scanline[row];
for q := 0 to BitmapWidth1 do
begin
(*
bufb^ := (inrow^.r * pb^) div 255; inc(bufb);
bufb^ := (inrow^.g * pb^) div 255; inc(bufb);
bufb^ := (inrow^.b * pb^) div 255; inc(bufb);
*)
bufb^ := inrow^.r; inc(bufb);
bufb^ := inrow^.g; inc(bufb);
bufb^ := inrow^.b; inc(bufb);
bufb^ := pb^; inc(bufb);
inc(inrow);
inc(pb);
end;
end
else
begin
// No predictor, from BGR to RGB
inrow := PRGB(Bitmap.Scanline[row]);
buf1 := PRGB(@rowbuf[0]);
CopyMemory(@rowbuf[0], inrow, Bitmap.Width * Samples);
for q := 0 to BitmapWidth1 do
begin
bswap(buf1.r, buf1.b);
inc(buf1);
end;
end;
end;
// from here in rowbuf there is the row do compress and write
case context.Compression of
1:
// NO COMPRESSION
SafeStreamWrite(Stream, Progress.Aborting^, rowbuf[0], ww);
5:
// LZW
context.LZWCompFunc(@rowbuf[0], ww, Stream, lzwid);
32773:
// PACKBITS
_WritePackBits(@rowbuf[0], ww, Stream, Progress.Aborting^);
32946:
// zip
SafeStreamWrite(zstream, Progress.Aborting^, rowbuf[0], ww);
end;
if Progress.Aborting^ then
break;
inc(striprow);
if (striprow = RowsPerStrip) or (row = BitmapHeight1) then
begin
FinalizeCompressors;
lzwid := nil;
//
siz_ar[stripidx] := Stream.Position - int64(pos_ar[stripidx]);
StripsPerImage := stripidx + 1;
striprow := 0;
if row < BitmapHeight1 then
begin
// this isn't the last one
inc(stripidx);
pos_ar[stripidx] := Stream.Position;
end;
end;
end; // of row for
end;
ie48RGB:
///////////// 48 bit color images
begin
if context.Compression = 7 then
exit;
// RGB 48
Samples := 3;
ww := (Samples * context.BitsPerSample * Bitmap.Width);
if (ww and 7) <> 0 then
ww := (ww div 8) + 1
else
ww := ww div 8;
Progress.per1 := 100 / Bitmap.Height;
SetLength(rowbuf, (Bitmap.Width * Samples) * imax(1, context.BitsPerSample div 8) + 4);
striprow := 0;
stripidx := 0;
pos_ar[0] := Stream.Position;
for row := 0 to BitmapHeight1 do
begin
// OnProgress
with Progress do
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * row));
// prepare buffer to write
if context.Predictor = 2 then
begin
// Predictor, BGR to RGB
buf1_48 := PRGB48(@rowbuf[BitmapWidth1 * 6]);
inrow_48 := PRGB48(Bitmap.Scanline[row]);
inc(inrow_48, BitmapWidth1);
buf2_48 := inrow_48;
dec(buf2_48);
for q := BitmapWidth1 downto 1 do
begin
buf1_48^.b := inrow_48^.b - buf2_48^.b;
buf1_48^.g := inrow_48^.g - buf2_48^.g;
buf1_48^.r := inrow_48^.r - buf2_48^.r;
dec(buf1_48);
dec(inrow_48);
dec(buf2_48);
end;
buf1_48^.b := inrow_48^.b;
buf1_48^.g := inrow_48^.g;
buf1_48^.r := inrow_48^.r;
end
else
begin
// No predictor, from BGR to RGB
CopyMemory(@rowbuf[0], Bitmap.Scanline[row], Bitmap.Width * Samples *2);
end;
// from here in rowbuf there is the row do compress and write
case context.Compression of
1:
// NO COMPRESSION
SafeStreamWrite(Stream, Progress.Aborting^, rowbuf[0], ww);
5:
// LZW
context.LZWCompFunc(@rowbuf[0], ww, Stream, lzwid);
32773:
// PACKBITS
_WritePackBits(@rowbuf[0], ww, Stream, Progress.Aborting^);
32946:
// zip
SafeStreamWrite(zstream, Progress.Aborting^, rowbuf[0], ww);
end;
if Progress.Aborting^ then
break;
inc(striprow);
if (striprow = RowsPerStrip) or (row = BitmapHeight1) then
begin
FinalizeCompressors;
lzwid := nil;
//
siz_ar[stripidx] := Stream.Position - int64(pos_ar[stripidx]);
StripsPerImage := stripidx + 1;
striprow := 0;
if row < BitmapHeight1 then
begin
// this isn't the last one
inc(stripidx);
pos_ar[stripidx] := Stream.Position;
end;
end;
end; // of row for
end;
ieCMYK:
///////////// CMYK
begin
if context.Compression = 7 then
exit;
// CMYK
Samples := 4;
if context.hasalpha then
inc(Samples);
ww := (Samples * context.BitsPerSample * Bitmap.Width);
if (ww and 7) <> 0 then
ww := (ww div 8) + 1
else
ww := ww div 8;
Progress.per1 := 100 / Bitmap.Height;
SetLength(rowbuf, (Bitmap.Width * Samples) * imax(1, context.BitsPerSample div 8) + 4);
striprow := 0;
stripidx := 0;
pos_ar[0] := Stream.Position;
for row := 0 to BitmapHeight1 do
begin
// OnProgress
with Progress do
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * row));
// prepare buffer to write (Predictor must be 1)
if context.hasalpha then
begin
// with alpha channel
buf1_cmyk := PCMYK(@rowbuf[0]);
buf2_cmyk := Bitmap.Scanline[row];
buf2_alpha := Bitmap.AlphaChannel.Scanline[row];
for q := 0 to BitmapWidth1 do
begin
buf1_cmyk^.c := 255 - buf2_cmyk^.c;
buf1_cmyk^.m := 255 - buf2_cmyk^.m;
buf1_cmyk^.y := 255 - buf2_cmyk^.y;
buf1_cmyk^.k := 255 - buf2_cmyk^.k;
inc(buf1_cmyk);
inc(buf2_cmyk);
pbyte(buf1_cmyk)^ := buf2_alpha^;
inc(pbyte(buf1_cmyk));
inc(buf2_alpha);
end;
end
else
begin
// no alpha channel
buf1_cmyk := PCMYK(@rowbuf[0]);
buf2_cmyk := Bitmap.Scanline[row];
for q := 0 to BitmapWidth1 do
begin
buf1_cmyk^.c := 255 - buf2_cmyk^.c;
buf1_cmyk^.m := 255 - buf2_cmyk^.m;
buf1_cmyk^.y := 255 - buf2_cmyk^.y;
buf1_cmyk^.k := 255 - buf2_cmyk^.k;
inc(buf1_cmyk);
inc(buf2_cmyk);
end;
end;
// from here in rowbuf there is the row do compress and write
case context.Compression of
1:
// NO COMPRESSION
SafeStreamWrite(Stream, Progress.Aborting^, rowbuf[0], ww);
5:
// LZW
context.LZWCompFunc(@rowbuf[0], ww, Stream, lzwid);
32773:
// PACKBITS
_WritePackBits(@rowbuf[0], ww, Stream, Progress.Aborting^);
32946:
// zip
SafeStreamWrite(zstream, Progress.Aborting^, rowbuf[0], ww);
end;
if Progress.Aborting^ then
break;
inc(striprow);
if (striprow = RowsPerStrip) or (row = BitmapHeight1) then
begin
FinalizeCompressors;
lzwid := nil;
//
siz_ar[stripidx] := Stream.Position - int64(pos_ar[stripidx]);
StripsPerImage := stripidx + 1;
striprow := 0;
if row < BitmapHeight1 then
begin
// this isn't the last one
inc(stripidx);
pos_ar[stripidx] := Stream.Position;
end;
end;
end; // of row for
end;
ie1g:
///////////// B/W IMAGES
begin
Progress.per1 := 100 / Bitmap.Height;
// calculates row length in bytes
ww := Bitmap.Width div 8;
if (Bitmap.Width mod 8) <> 0 then
inc(ww);
//
striprow := 0;
stripidx := 0;
pos_ar[0] := Stream.Position;
bwrl := 0;
bwr := 0;
predline := nil;
for row := 0 to BitmapHeight1 do
begin
// OnProgress
with Progress do
if assigned(fOnProgress) then
fOnProgress(Sender, trunc(per1 * row));
//
case context.Compression of
1:
// NO COMPRESSION
SafeStreamWrite(Stream, Progress.Aborting^, pbyte(Bitmap.Scanline[row])^, ww);
2:
// CCITT HUFFMAN 1D
CCITTHuffmanPutLine(pbyte(Bitmap.Scanline[row]), Bitmap.Width, Stream, Progress.Aborting^, context.FillOrder);
3:
if context.T4Options = 0 then
// CCITT G3FAX1D
CCITTHuffmanPutLineG3(pbyte(Bitmap.Scanline[row]), Bitmap.Width, Stream, bwr, bwrl, Progress.Aborting^, context.FillOrder)
else
// CCITT G3FAX2D
CCITTHuffmanPutLineG32D(pbyte(Bitmap.Scanline[row]), Bitmap.Width, Stream, bwr, bwrl, predline, Progress.Aborting^, context.FillOrder);
4:
// CCITT G4FAX
CCITTHuffmanPutLineG4(pbyte(Bitmap.Scanline[row]), Bitmap.Width, Stream, bwr, bwrl, predline, Progress.Aborting^, context.FillOrder);
5:
// LZW
context.LZWCompFunc(pbyte(Bitmap.Scanline[row]), ww, Stream, lzwid);
32773:
// PACKBITS
_WritePackBits(pbyte(Bitmap.Scanline[row]), ww, Stream, Progress.Aborting^);
32946:
// zip
SafeStreamWrite(zstream, Progress.Aborting^, pbyte(Bitmap.Scanline[row])^, ww);
end;
if Progress.Aborting^ then
break;
inc(striprow);
if (striprow = RowsPerStrip) or (row = BitmapHeight1) then
begin
FinalizeCompressors;
bwrl := 0;
bwr := 0;
predline := nil;
lzwid := nil;
//
siz_ar[stripidx] := Stream.Position - int64(pos_ar[stripidx]);
StripsPerImage := stripidx + 1;
striprow := 0;
if row < BitmapHeight1 then
begin
// this isn't the last one
inc(stripidx);
pos_ar[stripidx] := Stream.Position;
end;
end;
end;
end;
end; // end PixelFormat case
end; // end if (jpeg compression)
IFD.WriteSingleLong(278, RowsPerStrip); // RowsPerStrip
if StripsPerImage = 1 then
begin
IFD.WriteSingleLong(273, pos_ar[0]); // StripOffsets (array)
IFD.WriteSingleLong(279, siz_ar[0]); // StripByteCounts (array)
end
else
begin
IFD.WriteMultiLongEx(Stream, 273, pos_ar, StripsPerImage, Progress.Aborting^);
IFD.WriteMultiLongEx(Stream, 279, siz_ar, StripsPerImage, Progress.Aborting^);
end;
end;
procedure RelocateIFD(Stream: TStream; IFDPosition: int64; offset: int64; TagsStream: TStream; littleEndian: boolean = true);
var
oldpos: int64;
w: word;
IFD: array of TTIFFTAG;
i: integer;
makerNotesRelocator: TIETagsHandlerRelocator;
begin
oldpos := Stream.Position;
Stream.Position := IFDPosition;
Stream.Read(w, 2);
SetLength(IFD, w);
Stream.Read(IFD[0], length(IFD) * sizeof(TTIFFTAG));
for i := 0 to high(IFD) do
begin
if (IFD[i].IdTag = IETIFFTAG_EXIFMAKERNOTE) then
begin
makerNotesRelocator := TIETagsHandlerRelocator.Create(TagsStream, IFD[i].DataPos, offset, littleEndian);
try
makerNotesRelocator.Relocate();
finally
makerNotesRelocator.Free();
end;
inc(IFD[i].DataPos, offset);
end
else
if IETIFFCalcTagSize(IFD[i].DataType) * IFD[i].DataNum > 4 then
begin
inc(IFD[i].DataPos, offset);
end
else
if (IFD[i].IdTag = IETIFFTAG_EXIFIFD) or
(IFD[i].IdTag = IETIFFTAG_EXIFGPSIFD) or
(IFD[i].IdTag = IETIFFTAG_INTEROPIFD) then
begin
RelocateIFD(TagsStream, IFD[i].DataPos, offset, TagsStream, littleEndian);
inc(IFD[i].DataPos, offset);
end;
end;
Stream.Position := IFDPosition + 2;
Stream.Write(IFD[0], length(IFD) * sizeof(TTIFFTAG));
Stream.Position := oldpos;
end;
procedure WriteExifBlock(parentIFD: TIETIFFIFDWriter; OStream: TStream; var IOParams: TIOParams; var Aborting: boolean); forward;
// Ins: true insert an image of index IOParams.TIFF_ImageIndex, false saves as unique image
// If Ins is True, Stream must be open as fmOpenReadWrite
// returns the number of images inside the file (always 1 if Ins=false)
// note: Bitmap can be nil. If it is nil write only parameters (for EXIF inside Jpeg)
function TIFFWriteStream(OStream: TStream; Ins: boolean; Bitmap: TIEBitmap; var IOParams: TIOParams; var Progress: TProgressRec): integer;
var
tifhead: TTIFFHEADER;
mainIFD: TIETIFFIFDWriter; // the main IFD
i: integer;
BasePos: int64;
PosIFD: int64;
WBitmap: TIEBitmap;
BackCol, ForeCol: TRGB;
context: TTIFFWriterContext;
inv1bit: boolean;
numi: integer;
nt: word;
WPosIFD: int64; // where to write position of new IFD
SPosIFD: int64; // position of IFD to connect to the new IFD
NullProgress: TProgressRec;
GlobalColorMap: array[0..255] of TRGB;
wcolormap: array[0..255 * 3] of word;
ncol: integer;
laccess: TIEDataAccess;
ms: TMemoryStream;
XStream: TStream;
ofs: int64;
dw: dword;
ww: word;
apos: int64;
samples: integer;
begin
mainIFD := nil;
wbitmap := nil;
ncol := 0;
ms := nil;
context := TTIFFWriterContext.Create();
try
context.RefParams := IOParams;
mainIFD := TIETIFFIFDWriter.Create();
NullProgress := NullProgressRec( Progress.Aborting, False );
wbitmap := bitmap;
if wbitmap <> nil then
begin
// adjust wrong combinations
if IOParams.TIFF_Compression = ioTIFF_JPEG then
begin
IOParams.BitsPerSample := 8;
if (IOParams.SamplesPerPixel <> 1) and (IOParams.SamplesPerPixel <> 3) then
IOParams.SamplesPerPixel := 3;
end;
if (wbitmap.PixelFormat = ie1g) and
((IOParams.TIFF_PhotoMetInterpret <> ioTIFF_WHITEISZERO) or (IOParams.TIFF_PhotoMetInterpret <> ioTIFF_BLACKISZERO) or (IOParams.TIFF_PhotoMetInterpret <> ioTIFF_RGBPALETTE) or (IOParams.TIFF_PhotoMetInterpret <> ioTIFF_TRANSPMASK)) and
(IOParams.SamplesPerPixel = 1) and
(IOParams.BitsPerSample = 1) then
IOParams.TIFF_PhotometInterpret := ioTIFF_BLACKISZERO;
if (wbitmap.PixelFormat = ie24RGB) and (IOParams.SamplesPerPixel = 1) and (IOParams.BitsPerSample = 1) then
IOParams.TIFF_PhotometInterpret := ioTIFF_BLACKISZERO;
if (wbitmap.PixelFormat = ie24RGB) and (IOParams.SamplesPerPixel <= 2) and (IOParams.BitsPerSample = 8) and not wbitmap.HasAlphaChannel then
begin
IOParams.TIFF_PhotometInterpret := ioTIFF_RGBPALETTE;
IOParams.SamplesPerPixel := 1;
end;
if (wbitmap.PixelFormat = ie24RGB) and (IOParams.SamplesPerPixel <= 2) and (IOParams.BitsPerSample = 8) and wbitmap.HasAlphaChannel then
begin
// alpha supported only on 24 bit RGB - uncompressed
IOParams.TIFF_PhotometInterpret := ioTIFF_RGB;
IOParams.SamplesPerPixel := 4;
IOParams.BitsPerSample := 8;
IOParams.TIFF_Compression := ioTIFF_UNCOMPRESSED;
end;
// convert bitmap when necessary
if (IOParams.BitsPerSample = 1) and
(IOParams.SamplesPerPixel = 1) and
((IOParams.TIFF_PhotometInterpret = ioTIFF_WHITEISZERO) or (IOParams.TIFF_PhotometInterpret = ioTIFF_BLACKISZERO)) then
begin
// save to black/white
if Bitmap.PixelFormat <> ie1g then
begin
// Converts to 1 bit
WBitmap := _ConvertTo1bitEx(Bitmap, BackCol, ForeCol);
if WBitmap = nil then
begin
// impossible to convert to 1 bit, converts from color to black/white
// 3.0.0
WBitmap := TIEBitmap.Create(Bitmap.Width, Bitmap.Height, ie1g);
WBitmap.CopyAndConvertFormat(Bitmap);
end;
end;
end
else
begin
// save in true color
if Bitmap.PixelFormat = ie1g then
begin
// Converts to 24 bit
WBitmap := TIEBitmap.Create();
WBitmap.Assign(Bitmap);
WBitmap.PixelFormat := ie24RGB;
end;
end;
if (IOParams.SamplesPerPixel = 1) and
((IOParams.BitsPerSample <= 8) or (IOParams.BitsPerSample = 16)) and
((IOParams.BitsPerSample > 1) or (IOParams.TIFF_PhotometInterpret = ioTIFF_RGBPALETTE)) then
begin
// paletted image
ncol := imin(1 shl IOParams.BitsPerSample, 256);
context.qt := TIEQuantizer.Create(wBitmap, GlobalColorMap, ncol);
if context.qt.grayScale then
IOParams.TIFF_PhotometInterpret := ioTIFF_BLACKISZERO
else
begin
if (IOParams.TIFF_Compression <> ioTIFF_LZW) and (IOParams.TIFF_Compression <> ioTIFF_PACKBITS) and (IOParams.TIFF_Compression <> ioTIFF_ZIP) then
IOParams.TIFF_Compression := ioTIFF_UNCOMPRESSED;
IOParams.TIFF_PhotometInterpret := ioTIFF_RGBPALETTE;
if IOParams.BitsPerSample = 16 then
IOParams.BitsPerSample := 8; // color image cannot be 16 bit gray scale
end;
end;
if (IOParams.TIFF_PhotometInterpret = ioTIFF_RGBPALETTE) and (IOParams.SamplesPerPixel > 1) then
IOParams.TIFF_PhotometInterpret := ioTIFF_RGB;
if WBitmap.PixelFormat = ie48RGB then
begin
IOParams.SamplesPerPixel := 3;
IOParams.BitsPerSample := 16;
IOParams.TIFF_PhotometInterpret := ioTIFF_RGB;
end;
if (IOParams.BitsPerSample > 8) and (IOParams.SamplesPerPixel <> 1) then
begin
IOParams.SamplesPerPixel := 3;
IOParams.BitsPerSample := 8;
IOParams.TIFF_PhotometInterpret := ioTIFF_RGB;
end;
if ((IOParams.TIFF_PhotometInterpret = ioTIFF_BLACKISZERO) or (IOParams.TIFF_PhotometInterpret = ioTIFF_WHITEISZERO)) and
(IOParams.BitsPerSample = 8) and (IOParams.SamplesPerPixel = 3) then
IOParams.TIFF_PhotometInterpret := ioTIFF_RGB;
if (IOParams.TIFF_PhotoMetInterpret = ioTIFF_RGB) and (IOParams.SamplesPerPixel = 1) and (IOParams.BitsPerSample = 1) then
IOParams.TIFF_PhotometInterpret := ioTIFF_BLACKISZERO;
if (IOParams.TIFF_PhotoMetInterpret = ioTIFF_YCBCR) and (IOParams.TIFF_Compression <> ioTIFF_JPEG) then
IOParams.TIFF_PhotoMetInterpret := ioTIFF_RGB;
if (IOParams.TIFF_PhotoMetInterpret = ioTIFF_RGB) and (IOParams.SamplesPerPixel > 3) then
IOParams.SamplesPerPixel := 3;
if WBitmap.PixelFormat = ie48RGB then
begin
IOParams.SamplesPerPixel := 3;
IOParams.BitsPerSample := 16;
IOParams.TIFF_PhotometInterpret := ioTIFF_RGB;
end;
if WBitmap.PixelFormat = ieCMYK then
begin
IOParams.SamplesPerPixel := 4;
IOParams.BitsPerSample := 8;
IOParams.TIFF_PhotometInterpret := ioTIFF_CMYK;
end;
//
context.T4Options := 0;
case IOParams.TIFF_PhotometInterpret of
ioTIFF_WHITEISZERO: context.Photomet := ioTIFF_BLACKISZERO;
ioTIFF_BLACKISZERO: context.Photomet := ioTIFF_BLACKISZERO;
ioTIFF_RGBPALETTE: context.Photomet := ioTIFF_RGBPALETTE;
ioTIFF_RGB: context.Photomet := ioTIFF_RGB;
ioTIFF_TRANSPMASK: context.Photomet := ioTIFF_RGB;
ioTIFF_CMYK:
begin
context.Photomet := ioTIFF_CMYK;
IOParams.SamplesPerPixel := 4;
end;
ioTIFF_YCBCR: context.Photomet := ioTIFF_RGB;
ioTIFF_CIELAB: context.Photomet := ioTIFF_CIELAB;
else
context.Photomet := ioTIFF_RGB;
end;
inv1bit := false;
case IOParams.TIFF_Compression of
ioTIFF_LZW:
begin
context.Compression := 5; // LZW
context.Predictor := 2;
if assigned(IOParams.TIFF_LZWCompFunc) then
context.LZWCompFunc := IOParams.TIFF_LZWCompFunc
else
if assigned(IEGlobalSettings().DefTIFF_LZWCOMPFUNC) then
context.LZWCompFunc := IEGlobalSettings().DefTIFF_LZWCOMPFUNC
else
begin
context.Compression := 1;
context.Predictor := 1;
end;
end;
ioTIFF_PACKBITS:
context.Compression := 32773; // Packbits
ioTIFF_CCITT1D:
begin
context.Compression := 2; // CCITT1D
context.Photomet := ioTIFF_WHITEISZERO;
inv1bit := true;
end;
ioTIFF_G3FAX1D:
begin
context.Compression := 3; // G3FAX1D
context.Photomet := ioTIFF_WHITEISZERO;
inv1bit := true;
end;
ioTIFF_G3FAX2D:
begin
context.Compression := 3; // G3FAX2D
context.T4Options := 1;
context.Photomet := ioTIFF_WHITEISZERO;
inv1bit := true;
end;
ioTIFF_G4FAX:
begin
context.Compression := 4; // G4FAX
context.Photomet := ioTIFF_WHITEISZERO;
inv1bit := true;
end;
ioTIFF_JPEG, ioTIFF_OLDJPEG:
begin
if IOParams.TIFF_Compression = ioTIFF_JPEG then
context.Compression := 7 // new jpeg
else
context.Compression := 6; // old jpeg
context.jpegquality := IOParams.TIFF_JPEGQuality;
context.jpegcolorspace := IOParams.TIFF_JPEGColorSpace;
case context.jpegcolorspace of
ioJPEG_RGB: context.Photomet := ioTIFF_RGB;
ioJPEG_GRAYLEV: context.Photomet := ioTIFF_BLACKISZERO;
ioJPEG_YCbCr: context.Photomet := ioTIFF_YCBCR;
ioJPEG_CMYK: context.Photomet := ioTIFF_CMYK;
ioJPEG_YCbCrK:
begin
context.Photomet := ioTIFF_RGB;
context.jpegcolorspace := ioJPEG_RGB;
end;
end;
end;
ioTIFF_ZIP, ioTIFF_Deflate:
begin
context.Compression := 32946;
end;
else
context.Compression := 1; // no compression
end;
context.FillOrder := IOParams.TIFF_FillOrder;
if (WBitmap.PixelFormat <> ie1g) and (context.Compression > 1) and (context.Compression < 5) then
begin
context.Compression := 1; // no compression
inv1bit := false;
end;
if (IOParams.BitsPerSample <> 8) or ((IOParams.SamplesPerPixel <> 1) and (IOParams.SamplesPerPixel <> 3)) or (context.PhotoMet = ioTIFF_RGBPALETTE) or ((IOParams.BitsPerSample > 1) and (context.PhotoMet = ioTIFF_BLACKISZERO)) or (WBitmap.HasAlphaChannel) then
context.Predictor := 1;
if inv1bit then
begin
if wbitmap = bitmap then
begin
wbitmap := TIEBitmap.Create();
wbitmap.Assign(bitmap);
end;
_Negative1BitEx(wbitmap);
end;
end; // end of WBitmap<>nil
BasePos := OStream.Position;
XStream := OStream;
WPosIFD := 0;
SPosIFD := 0;
if Ins then
begin
// insert as TIFF_ImageIndex image
OStream.Read(tifhead, sizeof(TTIFFHEADER) - 4); // read header minus posifd
if tifhead.Id <> $4949 then
begin
Progress.Aborting^ := true;
result := 0;
exit;
end;
numi := 0;
repeat
apos := OStream.Position;
OStream.Read(dw, 4);
PosIFD := dw;
if (numi = IOParams.TIFF_ImageIndex) or
((PosIFD = 0) and (numi < IOParams.TIFF_ImageIndex)) then
begin
WPosIFD := apos;
SPosIFD := PosIFD;
end;
if (PosIFD = 0) then
break;
OStream.Position := PosIFD;
OStream.Read(nt, 2);
OStream.Seek(nt * sizeof(TTIFFTAG), soCurrent);
inc(numi);
until false;
result := numi + 1;
OStream.Seek(0, soEnd); // write from the end
end
else
begin
SafeStreamWrite(OStream, Progress.Aborting^, tifhead, sizeof(TTIFFHEADER)); // writes an empty header
result := 1;
if Bitmap = nil then
begin
// we can put IFD before actual tags (common case: writing EXIF)
ms := TMemoryStream.Create();
XStream := ms;
end
end;
// exif
if IOParams.EXIF_HasEXIFData then
begin
// this also write imagedescription, dpix, dpiy and dpi unit
WriteExifBlock(mainIFD, XStream, IOParams, Progress.Aborting^);
end
else
begin
// WriteExifBlock not called, then we must write this
mainIFD.WriteString(XStream, 270, IOParams.TIFF_ImageDescription, Progress.Aborting^);
mainIFD.WriteSingleRational(XStream, 282, IOParams.DpiX, Progress.Aborting^); // dpix
mainIFD.WriteSingleRational(XStream, 283, IOParams.DpiY, Progress.Aborting^); // dpiy
mainIFD.WriteSingleShort(296, 2); // inches units
end;
if WBitmap <> nil then
begin
mainIFD.WriteSingleLong(256, WBitmap.Width); // ImageWidth
mainIFD.WriteSingleLong(257, WBitmap.Height); // ImageHeight
case WBitmap.PixelFormat of
ie1g:
// BitsPerSample: 1 bit x sample
mainIFD.WriteSingleShort(258, 1);
ie8g:
mainIFD.WriteSingleShort(258, 8);
ie8p:
mainIFD.WriteSingleShort(258, 8);
ie16g:
mainIFD.WriteSingleShort(258, 16);
ie48RGB:
// RGB 48 bit
mainIFD.WriteMultiShort(XStream, 258, [16, 16, 16], Progress.Aborting^);
ieCMYK:
// CMYK
mainIFD.WriteMultiShort(XStream, 258, [8, 8, 8, 8], Progress.Aborting^);
ie24RGB:
begin
case context.Photomet of
ioTIFF_CMYK: mainIFD.WriteMultiShort(XStream, 258, [8, 8, 8, 8], Progress.Aborting^); // CMYK
ioTIFF_RGBPALETTE: mainIFD.WriteSingleShort(258, IOParams.BitsPerSample); // RGBPALETTE
ioTIFF_BLACKISZERO: mainIFD.WriteSingleShort(258, IOParams.BitsPerSample); // RGBPALETTE
else
mainIFD.WriteMultiShort(XStream, 258, [8, 8, 8], Progress.Aborting^); // RGB/YCBCR
end;
end;
end;
mainIFD.WriteSingleShort(259, context.Compression); // Compression
if WBitmap.pixelformat = ie1g then
begin
case context.Photomet of
ioTIFF_WHITEISZERO: mainIFD.WriteSingleShort(262, 0); // PhotometricInterpretation=0 (0=white)
ioTIFF_BLACKISZERO: mainIFD.WriteSingleShort(262, 1); // PhotometricInterpretation=1 (0=black)
end;
end
else
begin
case context.Photomet of
ioTIFF_CMYK: mainIFD.WriteSingleShort(262, 5); // CMYK
ioTIFF_CIELAB: mainIFD.WriteSingleShort(262, 8); // CIELAB
ioTIFF_RGBPALETTE: mainIFD.WriteSingleShort(262, 3); // RGBPAlette
ioTIFF_BLACKISZERO: mainIFD.WriteSingleShort(262, 1); // PhotometricInterpretation=1 (0=black)
ioTIFF_YCBCR: mainIFD.WriteSingleShort(262, 6); // YCBCR
else
mainIFD.WriteSingleShort(262, 2); // PhotometricInterpretation=2 (RGB)
end;
end;
mainIFD.WriteString(XStream, 269, IOParams.TIFF_DocumentName, Progress.Aborting^);
// some fax programs require to send default and other parameters to work
if (context.Compression = 2) or (context.Compression = 3) or (context.Compression = 4) then
begin
mainIFD.WriteSingleShort(266, context.FillOrder); // FillOrder
mainIFD.WriteSingleShort(284, 1); // Planar configuration
mainIFD.WriteSingleShort(327, 0); // CleanFaxData (0=no incorrect lines)
end;
context.BitsPerSample := IOParams.BitsPerSample;
// write image
laccess := WBitmap.Access;
WBitmap.Access := [iedRead];
if context.Compression = 6 then
WriteOldJpeg(XStream, WBitmap, mainIFD, context, Progress)
else
WriteStrip(XStream, WBitmap, mainIFD, context, Progress);
WBitmap.Access := laccess;
end;
if not Progress.Aborting^ then
begin
if WBitmap <> nil then
begin
if WBitmap.pixelformat = ie1g then
samples := 1
else
case context.Photomet of
ioTIFF_CMYK: samples := 4; // CMYK 4 sample x pixel
ioTIFF_RGBPALETTE: samples := 1; // RGBPALETTE, 1 sample x pixel
ioTIFF_BLACKISZERO: samples := 1; // GRAYSCALE, 1 sample x pixel
else
samples := 3;
end;
if context.hasalpha then
begin
inc(samples);
mainIFD.WriteMultiShort(XStream, 338, [1], Progress.Aborting^); // extra sample is alpha channel
end;
mainIFD.WriteSingleShort(277, samples);
if context.Predictor = 2 then
mainIFD.WriteSingleShort(317, 2); // Predictor
mainIFD.WriteString(XStream, 285, IOParams.TIFF_PageName, Progress.Aborting^);
if IOParams.TIFF_XPos <> 0 then
mainIFD.WriteSingleRational(XStream, 286, IOParams.TIFF_XPos, Progress.Aborting^);
if IOParams.TIFF_YPos <> 0 then
mainIFD.WriteSingleRational(XStream, 287, IOParams.TIFF_YPos, Progress.Aborting^);
if (context.Compression = 3) then
mainIFD.WriteSingleLong(292, context.T4Options)
else
if (context.Compression = 4) then
mainIFD.WriteSingleLong(292, 0);
if (context.Compression = 3) or (context.Compression = 4) then
mainIFD.WriteSingleLong(293, 0); // T6Options
// NewSubfileType
mainIFD.WriteSingleLong(254, IOParams.TIFF_NewSubfileType);
// Page number
if (IOParams.TIFF_PageNumber > -1) or (IOParams.TIFF_PageCount > -1) then
mainIFD.WriteMultiShort(XStream, 297, [IOParams.TIFF_PageNumber, IOParams.TIFF_PageCount], Progress.Aborting^);
// IPTC
WriteIPTC(mainIFD, XStream, IOParams, Progress.Aborting^);
// XMP
WriteXMP(mainIFD, XStream, IOParams, Progress.Aborting^);
{$ifdef IEINCLUDEIMAGINGANNOT}
// Wang Imaging
WriteWang(mainIFD, XStream, IOParams, Progress.Aborting^);
{$endif}
// ImageEn annotations
WriteImageEnAnnot(mainIFD, XStream, IOParams, Progress.Aborting^);
// ICC
WriteICC(mainIFD, XStream, IOParams, Progress.Aborting^);
// Photoshop image resources information
mainIFD.WriteArrayOfByte(XStream, IETIFFTAG_PHOTOSHOP, 1, IOParams.TIFF_PhotoshopImageResources, Progress.Aborting^);
// Photoshop "ImageSourceData"
mainIFD.WriteArrayOfByte(XStream, 37724, 7, IOParams.TIFF_PhotoshopImageSourceData, Progress.Aborting^);
// colormap
if context.Photomet = ioTIFF_RGBPALETTE then
begin
for i := 0 to ncol - 1 do
begin
wcolormap[i] := GlobalColorMap[i].r * 257;
wcolormap[i + ncol] := GlobalColorMap[i].g * 257;
wcolormap[i + ncol * 2] := GlobalColorMap[i].b * 257;
end;
mainIFD.WriteMultiShort(XStream, IETIFFTAG_COLORMAP, slice(wcolormap, ncol * 3), Progress.Aborting^);
end;
end;
apos := IEStreamWordAlign(OStream, Progress.Aborting^);
if Ins then
begin
// insert image
OStream.Position := WPosIFD;
dw := apos;
SafeStreamWrite(OStream, Progress.Aborting^, dw, 4);
end
else
begin
// write header
OStream.Position := BasePos;
tifhead.Id := $4949;
tifhead.Ver := 42;
tifhead.PosIFD := apos;
SafeStreamWrite(OStream, Progress.Aborting^, tifhead, sizeof(TTIFFHEADER));
end;
// write IFD
OStream.Position := apos;
ofs := OStream.Position + 2 + mainIFD.Count * sizeof(TTIFFTAG) + 4;
ww := mainIFD.Count;
SafeStreamWrite(OStream, Progress.Aborting^, ww, 2); // tags count
mainIFD.ReorderTags();
for i := 0 to mainIFD.Count - 1 do
SafeStreamWrite(OStream, Progress.Aborting^, mainIFD.Tag[i]^, sizeof(TTIFFTAG));
if Ins then
begin
// insert image
dw := SPosIFD;
SafeStreamWrite(OStream, Progress.Aborting^, dw, 4);
end
else
begin
dw := 0;
SafeStreamWrite(OStream, Progress.Aborting^, dw, 4); // next IFD (null)
end;
if assigned(ms) then
begin
RelocateIFD(OStream, apos, ofs, ms);
SafeStreamWrite(OStream, Progress.Aborting^, pbyte(ms.Memory)^, ms.Size); // write tags (when IFD precedes tags)
end;
end; // end of aborting
finally
mainIFD.Free();
ms.Free();
if (WBitmap <> nil) and (wbitmap <> bitmap) then
FreeAndNil(WBitmap);
context.Free();
end;
end;
procedure WriteExifInteropBlock(parentIFD: TIETIFFIFDWriter; Stream: TStream; var IOParams: TIOParams; var Aborting: boolean);
var
InteropIFD: TIETIFFIFDWriter;
q: integer;
tw: word;
w: dword;
begin
InteropIFD := nil;
try
InteropIFD := TIETIFFIFDWriter.Create();
InteropIFD.WriteString(Stream, $0001, IOParams.EXIF_InteropIndex, Aborting);
InteropIFD.WriteMiniString($0002, IOParams.EXIF_InteropVersion);
w := Stream.Position;
if (w and 1) <> 0 then
begin
inc(w); // align to word
q := 0;
SafeStreamWrite(Stream, Aborting, q, 1); // write an align byte
end;
// write IFD
Stream.Position := w;
tw := InteropIFD.Count;
SafeStreamWrite(Stream, Aborting, tw, 2); // tags count
InteropIFD.ReorderTags();
for q := 0 to InteropIFD.Count - 1 do
SafeStreamWrite(Stream, Aborting, InteropIFD.Tag[q]^, sizeof(TTIFFTAG));
q := 0;
SafeStreamWrite(Stream, Aborting, q, 4); // next IFD (null)
finally
InteropIFD.Free();
end;
// write EXIF-Interop tag (point to IFD)
parentIFD.AddTag(IETIFFTAG_INTEROPIFD, IETIFFTYPE_LONG, 1, w); // w already aligned
end;
procedure WriteExifGPSBlock(parentIFD: TIETIFFIFDWriter; OStream: TStream; var IOParams: TIOParams; var Aborting: boolean);
var
GPSifd: TIETIFFIFDWriter;
q: integer;
tw: word;
w: dword;
ms: TMemoryStream;
ofs: dword;
begin
GPSifd := nil;
ms := nil;
try
GPSifd := TIETIFFIFDWriter.Create();
ms := TMemoryStream.Create();
with IOParams do
begin
GPSifd.WriteMiniByteString($0, convVersionStrtoID(EXIF_GPSVersionID));
if EXIF_GPSLatitudeRef <> '' then
begin
GPSifd.WriteMiniString($1, EXIF_GPSLatitudeRef);
GPSifd.WriteMultiRational(ms, $2, [
EXIF_GPSLatitudeDegrees,
EXIF_GPSLatitudeMinutes,
EXIF_GPSLatitudeSeconds], Aborting);
end;
if EXIF_GPSLongitudeRef <> '' then
begin
GPSifd.WriteMiniString($3, EXIF_GPSLongitudeRef);
GPSifd.WriteMultiRational(ms, $4, [
EXIF_GPSLongitudeDegrees,
EXIF_GPSLongitudeMinutes,
EXIF_GPSLongitudeSeconds], Aborting);
end;
if EXIF_GPSAltitudeRef <> '' then
begin
GPSifd.WriteSingleByte($5, IEStrToIntDef(EXIF_GPSAltitudeRef, 0));
GPSifd.WriteSingleRational(ms, $6, EXIF_GPSAltitude, Aborting);
end;
GPSifd.WriteMultiRational(ms, $7, [
EXIF_GPSTimeStampHour,
EXIF_GPSTimeStampMinute,
EXIF_GPSTimeStampSecond], Aborting);
GPSifd.WriteString(ms, $8, EXIF_GPSSatellites, Aborting);
GPSifd.WriteMiniString($9, EXIF_GPSStatus);
GPSifd.WriteMiniString($A, EXIF_GPSMeasureMode);
GPSifd.WriteSingleRational(ms, $B, EXIF_GPSDOP, Aborting);
if EXIF_GPSSpeedRef <> '' then
begin
GPSifd.WriteMiniString($C, EXIF_GPSSpeedRef);
GPSifd.WriteSingleRational(ms, $D, EXIF_GPSSpeed, Aborting);
end;
if EXIF_GPSTrackRef <> '' then
begin
GPSifd.WriteMiniString($E, EXIF_GPSTrackRef);
GPSifd.WriteSingleRational(ms, $F, EXIF_GPSTrack, Aborting);
end;
if EXIF_GPSImgDirectionRef <> '' then
begin
GPSifd.WriteMiniString($10, EXIF_GPSImgDirectionRef);
GPSifd.WriteSingleRational(ms, $11, EXIF_GPSImgDirection, Aborting);
end;
GPSifd.WriteString(ms, $12, EXIF_GPSMapDatum, Aborting);
if EXIF_GPSDestLatitudeRef <> '' then
begin
GPSifd.WriteMiniString($13, EXIF_GPSDestLatitudeRef);
GPSifd.WriteMultiRational(ms, $14, [
EXIF_GPSDestLatitudeDegrees,
EXIF_GPSDestLatitudeMinutes,
EXIF_GPSDestLatitudeSeconds], Aborting);
end;
if EXIF_GPSDestLongitudeRef <> '' then
begin
GPSifd.WriteMiniString($15, EXIF_GPSDestLongitudeRef);
GPSifd.WriteMultiRational(ms, $16, [
EXIF_GPSDestLongitudeDegrees,
EXIF_GPSDestLongitudeMinutes,
EXIF_GPSDestLongitudeSeconds], Aborting);
end;
if EXIF_GPSDestBearingRef <> '' then
begin
GPSifd.WriteMiniString($17, EXIF_GPSDestBearingRef);
GPSifd.WriteSingleRational(ms, $18, EXIF_GPSDestBearing, Aborting);
end;
if EXIF_GPSDestDistanceRef <> '' then
begin
GPSifd.WriteMiniString($19, EXIF_GPSDestDistanceRef);
GPSifd.WriteSingleRational(ms, $1A, EXIF_GPSDestDistance, Aborting);
end;
GPSifd.WriteString(ms, $1D, EXIF_GPSDateStamp, Aborting);
end;
// align to word
w := OStream.Position;
if (w and 1) <> 0 then
begin
inc(w);
q := 0;
SafeStreamWrite(OStream, Aborting, q, 1); // write an align byte
end;
// write IFD
ofs := OStream.Position + 2 + GPSifd.Count * sizeof(TTIFFTAG) + 4;
tw := GPSifd.Count;
SafeStreamWrite(OStream, Aborting, tw, 2); // tags count
GPSifd.ReorderTags();
for q := 0 to GPSifd.Count - 1 do
SafeStreamWrite(OStream, Aborting, GPSifd.Tag[q]^, sizeof(TTIFFTAG));
q := 0;
SafeStreamWrite(OStream, Aborting, q, 4); // next IFD (null)
RelocateIFD(OStream, w, ofs, ms);
SafeStreamWrite(OStream, Aborting, pbyte(ms.Memory)^, ms.Size); // write tags
finally
GPSifd.Free();
ms.Free();
end;
// write EXIF-GPS tag (point to IFD)
parentIFD.AddTag(IETIFFTAG_EXIFGPSIFD, IETIFFTYPE_LONG, 1, w); // w already aligned
end;
procedure WriteExifBlock(parentIFD: TIETIFFIFDWriter; OStream: TStream; var IOParams: TIOParams; var Aborting: boolean);
var
EXIFifd: TIETIFFIFDWriter;
q, w: integer;
tw: word;
ms: TMemoryStream;
ofs: dword;
begin
// tags in parentIFD
with IOParams do
begin
if EXIF_ImageDescription <> '' then
parentIFD.WriteString(OStream, 270, EXIF_ImageDescription, Aborting);
if EXIF_XResolution <> 0 then
parentIFD.WriteSingleRational(OStream, 282, EXIF_XResolution, Aborting); // dpix
if EXIF_YResolution <> 0 then
parentIFD.WriteSingleRational(OStream, 283, EXIF_YResolution, Aborting); // dpiy
parentIFD.WriteSingleShort(274, TIFF_Orientation); // Orientation
parentIFD.WriteSingleShort(296, 2); // inches units
if EXIF_Software <> '' then
parentIFD.WriteString(OStream, 305, EXIF_Software, Aborting);
if EXIF_XPRating > -1 then
parentIFD.WriteSingleShort($4746, EXIF_XPRating);
if EXIF_XPTitle <> '' then
parentIFD.WriteWideString(OStream, $9C9B, EXIF_XPTitle, Aborting);
if EXIF_XPComment <> '' then
parentIFD.WriteWideString(OStream, $9C9C, EXIF_XPComment, Aborting);
if EXIF_XPAuthor <> '' then
parentIFD.WriteWideString(OStream, $9C9D, EXIF_XPAuthor, Aborting);
if EXIF_XPKeywords <> '' then
parentIFD.WriteWideString(OStream, $9C9E, EXIF_XPKeywords, Aborting);
if EXIF_XPSubject <> '' then
parentIFD.WriteWideString(OStream, $9C9F, EXIF_XPSubject, Aborting);
if EXIF_Artist <> '' then
parentIFD.WriteString(OStream, 315, EXIF_Artist, Aborting);
if EXIF_Make <> '' then
parentIFD.WriteString(OStream, 271, EXIF_Make, Aborting);
if EXIF_Model <> '' then
parentIFD.WriteString(OStream, 272, EXIF_Model, Aborting);
if EXIF_DateTime <> '' then
parentIFD.WriteString(OStream, 306, EXIF_DateTime, Aborting);
if (EXIF_WhitePoint[0] <> -1) or (EXIF_WhitePoint[1] <> -1) then
parentIFD.WriteMultiRational(OStream, 318, [EXIF_WhitePoint[0], EXIF_WhitePoint[1]], Aborting);
if EXIF_YCbCrPositioning <> 0 then
parentIFD.WriteSingleShort(531, EXIF_YCbCrPositioning);
if (EXIF_PrimaryChromaticities[0] <> -1) or (EXIF_PrimaryChromaticities[1] <> -1) or (EXIF_PrimaryChromaticities[2] <> -1) or
(EXIF_PrimaryChromaticities[3] <> -1) or (EXIF_PrimaryChromaticities[4] <> -1) or (EXIF_PrimaryChromaticities[5] <> -1) then
parentIFD.WriteMultiRational(OStream, 319, [
EXIF_PrimaryChromaticities[0],
EXIF_PrimaryChromaticities[1],
EXIF_PrimaryChromaticities[2],
EXIF_PrimaryChromaticities[3],
EXIF_PrimaryChromaticities[4],
EXIF_PrimaryChromaticities[5] ], Aborting);
if (EXIF_YCbCrCoefficients[0] <> -1) or (EXIF_YCbCrCoefficients[1] <> -1) or (EXIF_YCbCrCoefficients[2] <> -1) then
parentIFD.WriteMultiRational(OStream, 529, [
EXIF_YCbCrCoefficients[0],
EXIF_YCbCrCoefficients[1],
EXIF_YCbCrCoefficients[2] ], Aborting);
if (EXIF_ReferenceBlackWhite[0] <> -1) or (EXIF_ReferenceBlackWhite[1] <> -1) or (EXIF_ReferenceBlackWhite[2] <> -1) or
(EXIF_ReferenceBlackWhite[3] <> -1) or (EXIF_ReferenceBlackWhite[4] <> -1) or (EXIF_ReferenceBlackWhite[5] <> -1) then
parentIFD.WriteMultiRational(OStream, 532, [
EXIF_ReferenceBlackWhite[0],
EXIF_ReferenceBlackWhite[1],
EXIF_ReferenceBlackWhite[2],
EXIF_ReferenceBlackWhite[3],
EXIF_ReferenceBlackWhite[4],
EXIF_ReferenceBlackWhite[5] ], Aborting);
if EXIF_Copyright <> '' then
parentIFD.WriteString(OStream, IETIFFTAG_COPYRIGHT, EXIF_Copyright, Aborting);
end;
EXIFifd := nil;
ms := nil;
try
EXIFifd := TIETIFFIFDWriter.Create();
ms := TMemoryStream.Create();
// tags in EXIFifd
with IOParams do
begin
EXIFifd.WriteSingleRational(ms, $829A, EXIF_ExposureTime, Aborting, EXIF_Tags);
EXIFifd.WriteSingleRational(ms, $829D, EXIF_FNumber, Aborting, EXIF_Tags);
EXIFifd.WriteSingleShort($8822, EXIF_ExposureProgram, EXIF_Tags);
if EXIF_ISOSpeedRatings[1] <> 0 then
EXIFifd.WriteMultiShort(ms, $8827, [EXIF_ISOSpeedRatings[0], EXIF_ISOSpeedRatings[1]], Aborting)
else
if EXIF_ISOSpeedRatings[0] <> 0 then
EXIFifd.WriteSingleShort($8827, EXIF_ISOSpeedRatings[0]);
EXIFifd.WriteMiniString($9000, EXIF_ExifVersion);
if EXIF_DateTimeOriginal <> '' then
EXIFifd.WriteString(ms, $9003, EXIF_DateTimeOriginal, Aborting);
if EXIF_DateTimeDigitized <> '' then
EXIFifd.WriteString(ms, $9004, EXIF_DateTimeDigitized, Aborting);
EXIFifd.WriteSingleRational(ms, $9102, EXIF_CompressedBitsPerPixel, Aborting, EXIF_Tags);
EXIFifd.WriteSingleRational(ms, $9201, EXIF_ShutterSpeedValue, Aborting, EXIF_Tags);
EXIFifd.WriteSingleRational(ms, $9202, EXIF_ApertureValue, Aborting, EXIF_Tags);
EXIFifd.WriteSingleRational(ms, $9203, EXIF_BrightnessValue, Aborting, EXIF_Tags);
EXIFifd.WriteSingleRational(ms, $9204, EXIF_ExposureBiasValue, Aborting, EXIF_Tags);
EXIFifd.WriteSingleRational(ms, $9205, EXIF_MaxApertureValue, Aborting, EXIF_Tags);
EXIFifd.WriteSingleRational(ms, $9206, EXIF_SubjectDistance, Aborting, EXIF_Tags);
EXIFifd.WriteSingleShort($9207, EXIF_MeteringMode, EXIF_Tags);
EXIFifd.WriteSingleShort($9208, EXIF_LightSource, EXIF_Tags);
EXIFifd.WriteSingleShort($9209, EXIF_Flash, EXIF_Tags);
EXIFifd.WriteSingleRational(ms, $920A, EXIF_FocalLength, Aborting, EXIF_Tags);
if EXIF_SubsecTime <> '' then
EXIFifd.WriteString(ms, $9290, EXIF_SubsecTime, Aborting);
if EXIF_SubsecTimeOriginal <> '' then
EXIFifd.WriteString(ms, $9291, EXIF_SubsecTimeOriginal, Aborting);
if EXIF_SubsecTimeDigitized <> '' then
EXIFifd.WriteString(ms, $9292, EXIF_SubsecTimeDigitized, Aborting);
if EXIF_FlashPixVersion <> '' then
EXIFifd.WriteMiniString($A000, EXIF_FlashPixVersion);
EXIFifd.WriteSingleShort($A001, EXIF_ColorSpace, EXIF_Tags);
EXIFifd.WriteSingleShort($A002, EXIF_ExifImageWidth, EXIF_Tags); // could be also LONG
EXIFifd.WriteSingleShort($A003, EXIF_ExifImageHeight, EXIF_Tags); // could be also LONG
if EXIF_RelatedSoundFile <> '' then
EXIFifd.WriteString(ms, $A004, EXIF_RelatedSoundFile, Aborting);
EXIFifd.WriteSingleRational(ms, $A20E, EXIF_FocalPlaneXResolution, Aborting, EXIF_Tags);
EXIFifd.WriteSingleRational(ms, $A20F, EXIF_FocalPlaneYResolution, Aborting, EXIF_Tags);
EXIFifd.WriteSingleShort($A210, EXIF_FocalPlaneResolutionUnit, EXIF_Tags);
EXIFifd.WriteSingleRational(ms, $A215, EXIF_ExposureIndex, Aborting, EXIF_Tags);
EXIFifd.WriteSingleShort($A217, EXIF_SensingMethod, EXIF_Tags);
EXIFifd.WriteSingleUndefined($A300, EXIF_FileSource, EXIF_Tags);
EXIFifd.WriteSingleUndefined($A301, EXIF_SceneType, EXIF_Tags);
if EXIF_ExposureMode <> -1 then
EXIFifd.WriteSingleShort($A402, EXIF_ExposureMode);
if EXIF_WhiteBalance <> -1 then
EXIFifd.WriteSingleShort($A403, EXIF_WhiteBalance);
if EXIF_DigitalZoomRatio <> -1 then
EXIFifd.WriteSingleRational(ms, $A404, EXIF_DigitalZoomRatio, Aborting);
if EXIF_FocalLengthIn35mmFilm <> -1 then
EXIFifd.WriteSingleShort($A405, EXIF_FocalLengthIn35mmFilm);
if EXIF_SceneCaptureType <> -1 then
EXIFifd.WriteSingleShort($A406, EXIF_SceneCaptureType);
if EXIF_GainControl <> -1 then
EXIFifd.WriteSingleShort($A407, EXIF_GainControl);
if EXIF_Contrast <> -1 then
EXIFifd.WriteSingleShort($A408, EXIF_Contrast);
if EXIF_Saturation <> -1 then
EXIFifd.WriteSingleShort($A409, EXIF_Saturation);
if EXIF_Sharpness <> -1 then
EXIFifd.WriteSingleShort($A40A, EXIF_Sharpness);
if EXIF_SubjectDistanceRange <> -1 then
EXIFifd.WriteSingleShort($A40C, EXIF_SubjectDistanceRange);
if EXIF_ImageUniqueID <> '' then
EXIFifd.WriteString(ms, $A420, EXIF_ImageUniqueID, Aborting);
if EXIF_CameraOwnerName <> '' then
ExifIFD.WriteString(ms, $A430, EXIF_CameraOwnerName, Aborting);
if EXIF_BodySerialNumber <> '' then
ExifIFD.WriteString(ms, $A431, EXIF_BodySerialNumber, Aborting);
if EXIF_LensMake <> '' then
ExifIFD.WriteString(ms, $A433, EXIF_LensMake, Aborting);
if EXIF_LensModel <> '' then
ExifIFD.WriteString(ms, $A434, EXIF_LensModel, Aborting);
if EXIF_LensSerialNumber <> '' then
ExifIFD.WriteString(ms, $A435, EXIF_LensSerialNumber, Aborting);
if EXIF_Gamma <> -1 then
EXIFifd.WriteSingleRational(ms, $A500, EXIF_Gamma, Aborting);
// Can have 2, 3 or 4 values
if EXIF_SubjectArea[ 3 ] <> -1 then
EXIFifd.WriteMultiShort(ms, $9214, [EXIF_SubjectArea[0], EXIF_SubjectArea[1],EXIF_SubjectArea[2], EXIF_SubjectArea[3]], Aborting)
else
if EXIF_SubjectArea[ 2 ] <> -1 then
EXIFifd.WriteMultiShort(ms, $9214, [EXIF_SubjectArea[0], EXIF_SubjectArea[1],EXIF_SubjectArea[2]], Aborting)
else
if EXIF_SubjectArea[ 1 ] <> -1 then
EXIFifd.WriteMultiShort(ms, $9214, [EXIF_SubjectArea[0], EXIF_SubjectArea[1]], Aborting);
if ( EXIF_SubjectLocationX <> -1 ) and ( EXIF_SubjectLocationY <> -1 ) then
ExifIFD.WriteMultiShort(ms, $A214, [EXIF_SubjectLocationX, EXIF_SubjectLocationY], Aborting);
WriteEXIFUserComment(EXIFifd, ms, EXIF_UserCommentCode, EXIF_UserComment, Aborting); // tag $9286
WriteEXIFMakerNote(EXIFifd, ms, IETIFFTAG_EXIFMAKERNOTE, EXIF_MakerNote, Aborting);
if EXIF_InteropIndex <> '' then
WriteExifInteropBlock(EXIFifd, ms, IOParams, Aborting);
end;
// align to word
w := OStream.Position;
if (w and 1) <> 0 then
begin
inc(w);
q := 0;
SafeStreamWrite(OStream, Aborting, q, 1); // write an align byte
end;
// write IFD
ofs := OStream.Position + 2 + EXIFifd.Count * sizeof(TTIFFTAG) + 4;
tw := EXIFifd.Count;
SafeStreamWrite(OStream, Aborting, tw, 2); // tags count
EXIFifd.ReorderTags();
for q := 0 to EXIFifd.Count - 1 do
SafeStreamWrite(OStream, Aborting, EXIFifd.Tag[q]^, sizeof(TTIFFTAG));
q := 0;
SafeStreamWrite(OStream, Aborting, q, 4); // next IFD (null)
RelocateIFD(OStream, w, ofs, ms);
SafeStreamWrite(OStream, Aborting, pbyte(ms.Memory)^, ms.Size); // write tags
finally
EXIFifd.Free();
ms.Free();
end;
// write EXIF tag (point to IFD)
parentIFD.AddTag(IETIFFTAG_EXIFIFD, IETIFFTYPE_LONG, 1, w); // w is already aligned
if IOParams.EXIF_GPSVersionID <> '' then
WriteExifGPSBlock(parentIFD, OStream, IOParams, Aborting);
end;
//////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////
//**********************************************************************************//
//* TIFF Utilities *//
//**********************************************************************************//
////////////////////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////////////////
// return images count
function TIFFEnumImages(Stream: TStream): integer;
var
NullProgress: TProgressRec;
tempAlphaChannel: TIEMask;
ab: boolean;
params: TIOParams;
begin
tempAlphaChannel := nil;
NullProgress := NullProgressRec( ab );
params := TIOParams.Create( nil );
try
TIFFReadStream(nil, Stream, result, params, NullProgress, true, tempAlphaChannel, true, true, false, false); // result is inside...
finally
params.Free();
end;
end;
function TIFFDeleteImStream(Stream: TStream; idx: integer): integer;
begin
result := TIFFDeleteImStreamGroup(Stream, @idx, 1);
end;
function TIFFDeleteImStreamGroup(Stream: TStream; idxlist: pintegerarray; idxcount: integer): integer;
var
TIFFHeader: TTIFFHeader;
PosIFD, t, q: integer;
LittleEndian: boolean;
numi, ii: integer;
os: TMemoryStream;
IFD: array of TTIFFTAG;
nt, ww: word;
wp, bp, lp1, lp2, lp3, lp4: integer;
sz, sz2: integer;
ia1, ia2: pintegerarray;
wa1, wa2: pwordarray;
xIdTag: word; // tag identifier
xDataType, lxDataType: word; // data type
xDataNum: integer; // data count
xDataPos: integer; // data position
idx: integer;
begin
result := 0;
// read header (minus IFD position)
bp := Stream.Position;
Stream.read(TIFFHeader, sizeof(TTIFFHeader) - 4); // doesn't read IFD position
if (TIFFHeader.Id <> $4949) and (TIFFHeader.id <> $4D4D) then
exit;
LittleEndian := TIFFHeader.Id = $4949;
// write header (minus IFD position)
os := TMemoryStream.Create();
try
os.Size := Stream.Size;
os.Write(TIFFHeader, sizeof(TIFFHeader) - 4);
// IFD read loop
numi := 0;
idx := 0;
wp := os.Position;
PosIFD := 0;
os.Write(PosIFD, 4); // blank space for IFD position
lp4 := 0; // watch-dog for auto-looping IFD
repeat
Stream.Read(PosIFD, 4); // read IFD position
if (PosIFD = 0) or (lp4 = PosIFD) then
break; // end of images
lp4 := PosIFD;
PosIFD := IECSwapDWord(PosIFD, not LittleEndian);
Stream.Position := PosIFD; // go to the IFD
Stream.read(nt, 2); // read tags count
nt := IECSwapWord(nt, not LittleEndian);
// read tags
SetLength(IFD, nt);
Stream.read(IFD[0], sizeof(TTIFFTAG) * nt);
lp3 := Stream.Position; // save reading position
//
if (idx < idxcount) and (idxlist[idx] = numi) then
inc(idx)
else
begin
// write tags
ia1 := nil;
ia2 := nil;
wa1 := nil;
lxDataType := 0;
// search for StripByteCount or TileByteCount (we need them now)
for t := 0 to nt - 1 do
with IFD[t] do
begin
xIdTag := IECSwapWord(IdTag, not LittleEndian);
if (xIdTag = 279) or (xIdTag = 325) then
begin
xDataType := IECSwapWord(DataType, not LittleEndian);
xDataNum := IECSwapDWord(DataNum, not LittleEndian);
xDataPos := IECSwapDWord(DataPos, not LittleEndian);
sz := IETIFFCalcTagSize(xDataType) * xDataNum;
lxDataType := xDataType;
getmem(ia1, sz);
wa1 := pwordarray(ia1);
if sz > 4 then
begin
Stream.Position := xDataPos;
Stream.Read(ia1^, sz);
end
else
CopyMemory(ia1, @DataPos, sz);
end;
end;
for t := 0 to nt - 1 do
with IFD[t] do
begin
xIdTag := IECSwapWord(IdTag, not LittleEndian);
xDataType := IECSwapWord(DataType, not LittleEndian);
xDataNum := IECSwapDWord(DataNum, not LittleEndian);
xDataPos := IECSwapDWord(DataPos, not LittleEndian);
sz := IETIFFCalcTagSize(xDataType) * xDataNum;
if (xIdTag = 273) or (xIdTag = 324) then
begin
// we are reading StripOffsets or TileOffsets
getmem(ia2, sz);
wa2 := pwordarray(ia2);
if sz > 4 then
begin
Stream.Position := xDataPos;
Stream.Read(ia2^, sz);
end
else
CopyMemory(ia2, @DataPos, sz);
// write data referenced by array
for q := 0 to xDataNum - 1 do
begin
if xDataType = IETIFFTYPE_SHORT then
begin
// SHORT
Stream.Position := IECSwapWord(wa2^[q], not LittleEndian);
ww := os.Position;
wa2^[q] := IECSwapWord(ww, not LittleEndian);
end
else
begin
// LONG
Stream.Position := IECSwapDWord(ia2^[q], not LittleEndian);
ia2^[q] := IECSwapDWord(os.Position, not LittleEndian);
end;
if lxDataType = IETIFFTYPE_SHORT then
begin
sz2 := IECSwapWord(wa1^[q], not LittleEndian);
if sz2 > 0 then
IECopyFrom(os, Stream, sz2) // SHORT
end
else
begin
sz2 := IECSwapDWord(ia1^[q], not LittleEndian);
if sz2 > 0 then
IECopyFrom(os, Stream, sz2); // LONG
end;
end;
// write array
if sz > 4 then
begin
DataPos := IECSwapDWord(os.Position, not LittleEndian);
os.Write(ia2^, sz);
end
else
CopyMemory(@DataPos, ia2, sz);
end
else
if (sz > 4) or (xDataType = IETIFFTYPE_ASCII) then
begin
// DataPos now point to an area of the file (it can be ASCII, too)
DataPos := IECSwapDWord(os.Position, not LittleEndian);
Stream.Position := xDataPos;
if Stream.Position < os.Size then
begin
if sz > 0 then
IECopyFrom(os, Stream, sz);
end
else
os.Position := os.Position+sz;
end;
end;
freemem(ia2);
freemem(ia1);
// write IFD
lp1 := os.Position; // save IFD position
ww := IECSwapWord(nt, not LittleEndian);
os.Write(ww, 2); // write tags count
os.Write(IFD[0], nt * sizeof(TTIFFTAG));
lp2 := os.Position; // save position of next reading
// write IFD position
os.Position := wp;
ii := IECSwapDWord(lp1, not LittleEndian);
os.Write(ii, 4);
os.Position := lp2; // point to next byte to reading
wp := lp2;
PosIFD := 0;
os.Write(PosIFD, 4); // write blank space for IFD position
//
inc(result);
end;
inc(numi);
// point to the next byte to read
Stream.Position := lp3;
until false;
// write final IFD position (0)
lp1 := os.Position;
os.Position := wp;
PosIFD := 0;
os.Write(PosIFD, 4);
// write "os" to Stream
Stream.size := bp;
os.Position := 0;
if lp1 + 1 > 0 then
IECopyFrom(Stream, os, lp1 + 1);
finally
FreeAndNil(os);
end;
end;
function TIFFLoadTags(Stream: TStream; var numi: integer; ImageIndex: integer; IFD: TIETIFFIFDReader): boolean;
var
TIFFHeader: TTIFFHeader;
PosIFD: integer;
begin
result := false;
IFD.Clear();
// read header
IFD.Stream := Stream;
IFD.StreamBase := 0;
Stream.read(TIFFHeader, sizeof(TTIFFHeader));
if (TIFFHeader.Id <> $4949) and (TIFFHeader.id <> $4D4D) then
exit;
IFD.LittleEndian := TIFFHeader.Id = $4949;
if not IFD.LittleEndian then
TIFFHeader.PosIFD := IESwapDWord(TIFFHeader.PosIFD); // converts to LittleEndian
// read main IFD (of the selected image)
IFD.IFD := nil;
numi := 0;
PosIFD := TIFFHeader.PosIFD;
if PosIFD = 0 then
exit;
if not IFD.ReadIFD(ImageIndex, TIFFHeader.PosIFD, numi) then
exit;
result := true;
end;
// extract a TIFF from a multipage TIFF
procedure TIFFExtractImStream(Stream: TStream; idx: integer; OutStream: TStream);
var
TIFFHeader: TTIFFHeader;
PosIFD: int64;
t: integer;
LittleEndian: boolean;
numi, ii: integer;
IFD: PIFD;
nt, ww: word;
wp, lp1, lp2, lp3, lp4: int64;
sz: integer;
t279, t325, t514: pointer;
xIdTag: word; // tag identifier
xDataType, lxDataType: word; // data type
xDataNum: integer; // data count
xDataPos: dword; // data position
procedure ReadByteCountTag(ntag: integer; var ptr: pointer);
begin
with IFD^[ntag] do
begin
xDataType := IECSwapWord(DataType, not LittleEndian);
xDataNum := IECSwapDWord(DataNum, not LittleEndian);
xDataPos := IECSwapDWord(DataPos, not LittleEndian);
sz := IETIFFCalcTagSize(xDataType) * xDataNum;
lxDataType := xDataType;
getmem(ptr, sz);
try
if sz > 4 then
begin
Stream.Position := xDataPos;
Stream.Read(pbyte(ptr)^, sz);
end
else
CopyMemory(ptr, @DataPos, sz);
except
FreeAndNil(ptr);
raise;
end;
end;
end;
procedure ProcessOffsetsTag(ntag: integer; var ByteCountTag: pointer);
var
OffsetsTag: pointer;
q: integer;
pw: pwordarray;
pd: pdwordarray;
sz2: integer;
begin
with IFD^[ntag] do
begin
getmem(OffsetsTag, sz);
try
if sz > 4 then
begin
Stream.Position := xDataPos;
Stream.Read(pbyte(OffsetsTag)^, sz);
end
else
CopyMemory(OffsetsTag, @DataPos, sz);
// write data referenced by array
for q := 0 to xDataNum - 1 do
begin
if xDataType = IETIFFTYPE_SHORT then
begin
// SHORT
pw := pwordarray(OffsetsTag);
Stream.Position := IECSwapWord(pw^[q], not LittleEndian);
ww := OutStream.Position;
pw^[q] := IECSwapWord(ww, not LittleEndian);
end
else
begin
// LONG
pd := pdwordarray(OffsetsTag);
Stream.Position := IECSwapDWord(pd^[q], not LittleEndian);
pd^[q] := IECSwapDWord(OutStream.Position, not LittleEndian);
end;
if (ByteCountTag=nil) then
begin
if Stream.Size-Stream.Position > 0 then
IECopyFrom(OutStream, Stream, Stream.Size-Stream.Position);
end
else
begin
if lxDataType = IETIFFTYPE_SHORT then
begin
pw := pwordarray(ByteCountTag);
sz2 := IECSwapWord(pw^[q], not LittleEndian);
if sz2 > 0 then
IECopyFrom(OutStream, Stream, sz2); // SHORT
end
else
begin
pd := pdwordarray(ByteCountTag);
sz2 := IECSwapDWord(pd^[q], not LittleEndian);
if sz2 > 0 then
IECopyFrom(OutStream, Stream, sz2); // LONG
end;
end;
end;
// write array
if sz > 4 then
begin
DataPos := IECSwapDWord(OutStream.Position, not LittleEndian);
OutStream.Write(pbyte(OffsetsTag)^, sz);
end
else
CopyMemory(@DataPos, OffsetsTag, sz);
finally
freemem(OffsetsTag);
end;
end;
end;
begin
Stream.Position := 0;
// read header (minus IFD position)
Stream.read(TIFFHeader, sizeof(TTIFFHeader) - 4); // doesn't read IFD position
if (TIFFHeader.Id <> $4949) and (TIFFHeader.id <> $4D4D) then
exit;
LittleEndian := TIFFHeader.Id = $4949;
// write header (minus IFD position)
OutStream.Write(TIFFHeader, sizeof(TIFFHeader) - 4);
// IFD read loop
numi := 0;
wp := OutStream.Position;
PosIFD := 0;
OutStream.Write(PosIFD, 4); // blank space for IFD position
lp4 := 0; // watch-dog for auto-looping IFD
repeat
Stream.Read(PosIFD, 4); // read IFD position
if (PosIFD = 0) or (lp4 = PosIFD) then
break; // end of images
lp4 := PosIFD;
PosIFD := IECSwapDWord(PosIFD, not LittleEndian);
Stream.Position := PosIFD; // go to the IFD
Stream.read(nt, 2); // read tags count
nt := IECSwapWord(nt, not LittleEndian);
getmem(IFD, nt * sizeof(TTIFFTAG));
try
// read tags
Stream.read(pbyte(IFD)^, sizeof(TTIFFTAG) * nt);
lp3 := Stream.Position; // save reading position
if numi = idx then
begin
// write tags
t279 := nil;
t325 := nil;
t514 := nil;
lxDataType := 0;
try
// search for byteCounts tags (we need them now)
for t := 0 to nt - 1 do
case IECSwapWord(IFD^[t].IdTag, not LittleEndian) of
279: ReadByteCountTag(t, t279);
325: ReadByteCountTag(t, t325);
514: ReadByteCountTag(t, t514);
end;
for t := 0 to nt - 1 do
with IFD^[t] do
begin
xIdTag := IECSwapWord(IdTag, not LittleEndian);
xDataType := IECSwapWord(DataType, not LittleEndian);
xDataNum := IECSwapDWord(DataNum, not LittleEndian);
xDataPos := IECSwapDWord(DataPos, not LittleEndian);
sz := IETIFFCalcTagSize(xDataType) * xDataNum;
case xIdTag of
273: ProcessOffsetsTag(t, t279);
324: ProcessOffsetsTag(t, t325);
513: ProcessOffsetsTag(t, t514);
else
if (sz > 4) then
begin
// DataPos now point to an area of the file (it can be ASCII, too)
DataPos := IECSwapDWord(OutStream.Position, not LittleEndian);
Stream.Position := xDataPos;
if sz > 0 then
IECopyFrom(OutStream, Stream, sz);
end;
end;
end;
finally
freemem(t279);
freemem(t325);
freemem(t514);
end;
// write IFD
lp1 := OutStream.Position; // save IFD position
ww := IECSwapWord(nt, not LittleEndian);
OutStream.Write(ww, 2); // write tags count
OutStream.Write(IFD^, nt * sizeof(TTIFFTAG));
lp2 := OutStream.Position; // save position of next reading
// write IFD position
OutStream.Position := wp;
ii := IECSwapDWord(lp1, not LittleEndian);
OutStream.Write(ii, 4);
OutStream.Position := lp2; // point to next byte to reading
wp := lp2;
PosIFD := 0;
OutStream.Write(PosIFD, 4); // write blank space for IFD position
end;
finally
// free tags
freemem(IFD);
end;
inc(numi);
// point to the next byte to read
Stream.Position := lp3;
until false;
// write final IFD position (0)
OutStream.Position := wp;
PosIFD := 0;
OutStream.Write(PosIFD, 4);
end;
//*)
function TIFFInsertImStream(Stream: TStream; ToInsert: TStream; idx: integer; OutStream: TStream; internal: boolean): integer;
var
TIFFHeader: TTIFFHeader;
PosIFD, t, q: integer;
numi, ii: integer;
IFD: PIFD;
nt, ww: word;
wp, lp1, lp2, lp3, lp4: integer;
sz, sz2: integer;
ia1, ia2: pintegerarray;
wa1, wa2: pwordarray;
xIdTag: word; // tag identifier
xDataType, lxDataType: word; // data type
xDataNum: integer; // data count
xDataPos: integer; // data position
LittleEndian: boolean;
begin
result := 0;
Stream.Position := 0;
// read header (minus IFD position)
Stream.read(TIFFHeader, sizeof(TTIFFHeader) - 4); // doesn't read IFD position
if (TIFFHeader.Id <> $4949) and (TIFFHeader.id <> $4D4D) then
exit;
LittleEndian := TIFFHeader.Id = $4949;
if not Internal then
begin
// write header (minus IFD position)
OutStream.Write(TIFFHeader, sizeof(TIFFHeader) - 4);
end;
// IFD read loop
numi := 0;
wp := OutStream.Position;
PosIFD := 0;
OutStream.Write(PosIFD, 4); // blank space for IFD position
lp4 := 0; // watch-dog for auto-looping IFD
repeat
//
if numi = idx then
begin
// insert ToInsert here
OutStream.Position := OutStream.Position - 4;
wp := TIFFInsertImStream(ToInsert, nil, -1, OutStream, true);
inc(numi);
end
else
begin
Stream.Read(PosIFD, 4); // read IFD position
if (PosIFD = 0) or (lp4 = PosIFD) then
break; // end of images
lp4 := PosIFD;
PosIFD := IECSwapDWord(PosIFD, not LittleEndian);
Stream.Position := PosIFD; // go to the IFD
Stream.read(nt, 2); // read tags count
nt := IECSwapWord(nt, not LittleEndian);
// read tags
getmem(IFD, nt * sizeof(TTIFFTAG));
Stream.read(pbyte(IFD)^, sizeof(TTIFFTAG) * nt);
lp3 := Stream.Position; // save reading position
// write tags
ia1 := nil;
ia2 := nil;
wa1 := nil;
lxDataType := 0;
// search for StripByteCount or TileByteCount (we need them now)
for t := 0 to nt - 1 do
with IFD^[t] do
begin
xIdTag := IECSwapWord(IdTag, not LittleEndian);
if (xIdTag = 279) or (xIdTag = 325) then
begin
xDataType := IECSwapWord(DataType, not LittleEndian);
xDataNum := IECSwapDWord(DataNum, not LittleEndian);
xDataPos := IECSwapDWord(DataPos, not LittleEndian);
sz := IETIFFCalcTagSize(xDataType) * xDataNum;
lxDataType := xDataType;
getmem(ia1, sz);
wa1 := pwordarray(ia1);
if sz > 4 then
begin
Stream.Position := xDataPos;
Stream.Read(ia1^, sz);
end
else
CopyMemory(ia1, @DataPos, sz);
end;
end;
for t := 0 to nt - 1 do
with IFD^[t] do
begin
xIdTag := IECSwapWord(IdTag, not LittleEndian);
xDataType := IECSwapWord(DataType, not LittleEndian);
xDataNum := IECSwapDWord(DataNum, not LittleEndian);
xDataPos := IECSwapDWord(DataPos, not LittleEndian);
sz := IETIFFCalcTagSize(xDataType) * xDataNum;
if (xIdTag = 273) or (xIdTag = 324) then
begin
// we are reading StripOffsets or TileOffsets
getmem(ia2, sz);
wa2 := pwordarray(ia2);
if sz > 4 then
begin
Stream.Position := xDataPos;
Stream.Read(ia2^, sz);
end
else
CopyMemory(ia2, @DataPos, sz);
// write data referenced by array
for q := 0 to xDataNum - 1 do
begin
if xDataType = IETIFFTYPE_SHORT then
begin
// SHORT
Stream.Position := IECSwapWord(wa2^[q], not LittleEndian);
ww := OutStream.Position;
wa2^[q] := IECSwapWord(ww, not LittleEndian);
end
else
begin
// LONG
Stream.Position := IECSwapDWord(ia2^[q], not LittleEndian);
ia2^[q] := IECSwapDWord(OutStream.Position, not LittleEndian);
end;
if lxDataType = IETIFFTYPE_SHORT then
begin
sz2 := IECSwapWord(wa1^[q], not LittleEndian);
if sz2 > 0 then
IECopyFrom(OutStream, Stream, sz2); // SHORT
end
else
begin
sz2 := IECSwapDWord(ia1^[q], not LittleEndian);
if sz2 > 0 then
IECopyFrom(OutStream, Stream, sz2); // LONG
end;
end;
// write array
if sz > 4 then
begin
DataPos := IECSwapDWord(OutStream.Position, not LittleEndian);
OutStream.Write(ia2^, sz);
end
else
CopyMemory(@DataPos, ia2, sz);
end
else
if xIdTag = 254 then
begin
// correct NewSubfileType
DataPos := IECSwapDWord(xDataPos or 2, not LittleEndian); // 2 means this is a single page of a multipage image
end
else
if (sz > 4) then
begin
// DataPos now points to an area of the file (it can be ASCII, too)
DataPos := IECSwapDWord(OutStream.Position, not LittleEndian);
Stream.Position := xDataPos;
if sz > 0 then
IECopyFrom(OutStream, Stream, sz);
end;
end;
freemem(ia2);
freemem(ia1);
// write IFD
lp1 := OutStream.Position; // save IFD position
ww := IECSwapWord(nt, not LittleEndian);
OutStream.Write(ww, 2); // write tags count
OutStream.Write(IFD^, nt * sizeof(TTIFFTAG));
lp2 := OutStream.Position; // save position of next reading
// write IFD position
OutStream.Position := wp;
ii := IECSwapDWord(lp1, not LittleEndian);
OutStream.Write(ii, 4);
OutStream.Position := lp2; // point to next byte to write
wp := lp2;
PosIFD := 0;
OutStream.Write(PosIFD, 4); // write blank space for IFD position
// free tags
freemem(IFD);
inc(numi);
// point to the next byte to read
Stream.Position := lp3;
end;
until false;
if not Internal then
begin
// write final IFD position (0)
OutStream.Position := wp;
PosIFD := 0;
OutStream.Write(PosIFD, 4);
end;
result := wp;
end;
procedure TIFFInsertImStream(Stream: TStream; ToInsert: TStream; idx: integer; OutStream: TStream);
begin
TIFFInsertImStream(Stream, ToInsert, idx, OutStream, false);
end;
// find DNG or TIFF-EP raw encoded image
function IsDNGStream(fs: TStream): boolean;
var
lp: int64;
IFD: TIETIFFIFDReader;
TIFFHeader: TTIFFHeader;
numi: integer;
i: integer;
begin
lp := fs.Position;
result := false;
IFD := TIETIFFIFDReader.Create();
try
IFD.Stream := fs;
IFD.StreamBase := 0;
fs.read(TIFFHeader, sizeof(TTIFFHeader));
if (TIFFHeader.Id <> $4949) and (TIFFHeader.id <> $4D4D) then
exit;
IFD.LittleEndian := TIFFHeader.Id = $4949;
if not IFD.LittleEndian then
TIFFHeader.PosIFD := IESwapDWord(TIFFHeader.PosIFD); // converts to LittleEndian header
IFD.IFD := nil;
numi := 0;
if not IFD.ReadIFD(0, TIFFHeader.PosIFD, numi) then
exit;
// check for DNGVersion tag
i := IFD.FindTAG(IETIFFTAG_DNGVERSION);
if (i > -1) and (IFD.IFD[i].DataType = IETIFFTYPE_BYTE) and (IFD.IFD[i].DataNum = IETIFFTYPE_LONG) then
begin
result := true;
exit;
end;
// check for photometricInterpretation=32803 or 34892
i := IFD.FindTAG(262);
if (i > -1) and (IFD.IFD[i].DataType = IETIFFTYPE_SHORT) and (IFD.IFD[i].DataNum = 1) and ((IFD.ReadInteger(262, 0, 0) = 32803) or (IFD.ReadInteger(262, 0, 0) = 34892)) then
begin
result := true;
exit;
end;
//
if (IFD.FindTAG($014A) > -1) and (IFD.FindTAG($9216) > -1) then
begin
// Has SubIFD and TIFF/EPStandardID, now check if it is a thumbnail
if (IFD.ReadInteger(256, 0, 0) < 200) and (IFD.ReadInteger(257, 0, 0) < 200) then
begin
result := true;
exit;
end;
end;
finally
IFD.Free();
fs.Position := lp;
end;
end;
function IsTIFFStream(fs: TStream): boolean;
var
IFD: TIETIFFIFDReader;
lp: int64;
numi: integer;
BufStream: TIEBufferedReadStream;
LittleEndian: boolean;
BigTIFF: boolean;
DataPosSize: integer;
IFDPosition: int64;
begin
result := false;
lp := fs.Position;
BufStream := TIEBufferedReadStream.Create(fs, 1024, IEGlobalSettings().UseRelativeStreams);
IFD := TIETIFFIFDReader.Create();
try
if BufStream.Size > 20 then
begin
result := TIFFReadHeader(BufStream, nil, LittleEndian, BigTIFF, DataPosSize, IFDPosition);
if not result then
exit; // fail
// check some tags
IFD.Stream := BufStream;
IFD.StreamBase := 0;
IFD.LittleEndian := LittleEndian;
IFD.IsBigTIFF := BigTIFF;
IFD.DataPosSize := DataPosSize;
numi := 0;
if (IFD.ReadIFD(0, IFDPosition, numi) = false) // has a valid IFD?
or (IFD.FindTAG(256) = -1) // has ImageWidth?
or (IFD.FindTAG(257) = -1) // has ImageLength?
then
result := false
end;
finally
IFD.Free();
BufStream.Free();
fs.Position := lp;
end;
end;
// Try Microsoft PhotoHD 1.0
function IsHDPStream(fs: TStream): boolean;
var
HeaderTIFF: TTIFFHeader;
IFD: TIETIFFIFDReader;
lp: int64;
numi: integer;
BufStream: TIEBufferedReadStream;
begin
result := false;
lp := fs.Position;
BufStream := TIEBufferedReadStream.Create(fs, 1024, IEGlobalSettings().UseRelativeStreams);
IFD := TIETIFFIFDReader.Create();
try
if BufStream.Size > sizeof(TTIFFHeader) then
begin
BufStream.Read(HeaderTIFF, sizeof(HeaderTIFF));
BufStream.Position := lp;
result := HeaderTIFF.Id=$4949;
if not result then
exit;
// check some tags
BufStream.Position := BufStream.Position-1;
IFD.Stream := BufStream;
IFD.StreamBase := 0;
IFD.LittleEndian := true;
numi := 0;
if (IFD.ReadIFD(0, HeaderTIFF.PosIFD, numi) = false) // has a valid IFD?
or (IFD.FindTAG(48256) = -1) // has ImageWidth?
or (IFD.FindTAG(48257) = -1) // has ImageLength?
or (IFD.FindTAG(48129) = -1) // has PixelFormat?
or (IFD.FindTAG(48320) = -1) // has ImageOffset?
or (IFD.FindTAG(48321) = -1) // has ImageByteCount?
then
result := false
end;
finally
IFD.Free();
BufStream.Free;
fs.Position := lp;
end;
end;
// if InputStream=nil, then load from InputFileName
// if OutputStream=nil, then save to OutputFileName
// InputStream=OutputStream allowed
{$ifdef IEINCLUDETIFFHANDLER}
function IEInjectTIFFEXIF(InputStream, OutputStream: TStream; const InputFileName, OutputFileName: WideString; pageIndex: integer; IOParams: TIOParams): boolean;
const
EXIFTags: array [0..22] of integer = (
271, 272, 306, 274, 282, 283, 296, 305, 315, 318, 531, 319, 529, 532, IETIFFTAG_COPYRIGHT // TIFF 6 standard
, $4746, $9C9B, $9C9C, $9C9D, $9C9E, $9C9F // XP specific
, IETIFFTAG_EXIFIFD // EXIF sub ifd
, IETIFFTAG_EXIFGPSIFD // EXIF-GPS
);
var
target: TIETIFFHandler;
source_tags: TIETIFFHandler;
tempTiffStream: TIEMemStream;
i: integer;
NullProgress: TProgressRec;
Aborting: boolean;
buffer: pointer;
bufferLength: integer;
lp: int64;
begin
result := true;
NullProgress := NullProgressRec( Aborting );
tempTiffStream := nil;
source_tags := nil;
target := nil;
buffer := nil;
lp := 0;
try
SaveEXIFToStandardBuffer(IOParams, buffer, bufferLength, false);
tempTiffStream := TIEMemStream.Create(buffer, bufferLength);
tempTiffStream.Position := 0;
source_tags := TIETIFFHandler.Create(tempTiffStream);
if InputStream=nil then
target := TIETIFFHandler.Create(InputFileName)
else
begin
lp := InputStream.Position; // save input stream position, to allow InputStream=OutputStream
target := TIETIFFHandler.Create(InputStream);
end;
for i := 0 to High(EXIFTags) do
target.CopyTag(0, source_tags.FindTag(0, EXIFTags[i]), source_tags, pageIndex);
if OutputStream=nil then
target.WriteFile(OutputFileName)
else
begin
if InputStream=OutputStream then
OutputStream.Position := lp;
target.WriteStream(OutputStream);
end;
finally
if buffer<>nil then
freemem(buffer);
source_tags.Free;
target.Free;
tempTiffStream.Free;
end;
end;
{$endif}
end.
Reference in New Issue View Git Blame Copy Permalink