1 // SPDX-License-Identifier: GPL-3.0-only
2 unit UTiff;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 Classes, SysUtils, fgl;
10
11 const
12 TiffTagNewSubFileType = 254;
13 TiffTagSubfileType = 255;
14 TiffTagImageWidth = 256;
15 TiffTagImageLength = 257;
16 TiffTagBitsPerSample = 258;
17 TiffTagCompression = 259;
18 TiffTagPhotometricInterpretation = 262;
19 TiffTagThresholding = 263;
20 TiffTagCellWidth = 264;
21 TiffTagCellLength = 265;
22 TiffTagFillOrder = 266;
23 TiffTagDocumentName = 269;
24 TiffTagImageDescription = 270;
25 TiffTagMake = 271;
26 TiffTagModel = 272;
27 TiffTagStripOffsets = 273;
28 TiffTagOrientation = 274;
29 TiffTagSamplesPerPixel = 277;
30 TiffTagRowsPerStrip = 278;
31 TiffTagStripByteCounts = 279;
32 TiffTagMinSampleValue = 280;
33 TiffTagMaxSampleValue = 281;
34 TiffTagXResolution = 282;
35 TiffTagYResolution = 283;
36 TiffTagPlanarConfiguration = 284;
37 TiffTagPageName = 285;
38 TiffTagXPosition = 286;
39 TiffTagYPosition = 287;
40 TiffTagFreeOffsets = 288;
41 TiffTagFreeByteCounts = 289;
42 TiffTagGrayResponseUnit = 290;
43 TiffTagGrayResponseCurve = 291;
44 TiffTagT4Options = 292;
45 TiffTagT6Options = 293;
46 TiffTagResolutionUnit = 296;
47 TiffTagPageNumber = 297;
48 TiffTagTransferFunction = 301;
49 TiffTagSoftware = 305;
50 TiffTagDateTime = 306;
51 TiffTagArtist = 315;
52 TiffTagHostComputer = 316;
53 TiffTagPredictor = 317;
54 TiffTagWhitePoint = 318;
55 TiffTagPrimaryChromacities = 319;
56 TiffTagColorMap = 320;
57 TiffTagHalftoneHints = 321;
58 TiffTagTileWidth = 322;
59 TiffTagTileLength = 323;
60 TiffTagTileOffsets = 324;
61 TiffTagTileByteCounts = 325;
62 TiffTagBadFaxLines = 326;
63 TiffTagCleanFaxData = 327;
64 TiffTagConsecutiveBadFaxLines = 328;
65 TiffTagInkSet = 332;
66 TiffTakInkNames = 333;
67 TiffTagNumberOfInks = 334;
68 TiffTagDotRange = 336;
69 TiffTagTargetPrinter = 337;
70 TiffTagExtraSamples = 338;
71 TiffTagSampleFormat = 339;
72 TiffTagSMinSampleValue = 340;
73 TiffTagSMaxSampleValue = 341;
74 TiffTagTransferRange = 342;
75 TiffTagJPEGTables = 347;
76 TiffTagJPEGProc = 512;
77 TiffTagJPEGInterchangeFormat = 513;
78 TiffTagJPEGInterchangeFormatLength = 514;
79 TiffTagJPEGRestartInterval = 515;
80 TiffTagJPEGLosslessPerdictors = 517;
81 TiffTagJPEGPointTransforms = 518;
82 TiffTagJPEGQTables = 519;
83 TiffTagJPEGDCTables = 520;
84 TiffTagJPEGACTables = 521;
85 TiffTagYCbCrCoefficients = 529;
86 TiffTafYCbCrSubSampling = 530;
87 TiffTagYCbCrPositioning = 531;
88 TiffTagReferenceBlackWhite = 532;
89 TiffTagXMLPacket = 700;
90 TiffTagCopyright = 33432;
91 TiffTagRichTiffIPTC = 33723;
92 TiffTagPhotoshopImageResourceBlocks = 34377;
93 TiffTagExifIFD = 34665;
94 TiffTagICCProfile = 34675;
95
96 TiffTagHylaFaxReceiveParams = 34908;
97 TiffTagHylaFaxReceiveTimeSecs = 34910;
98
99 ExifTagColorspace = 40961;
100 ExifTagPixelXDimension = 40962;
101 ExifTagPixelYDimension = 40963;
102
103 type
104 TTiffError = (teNone,
105 teUnexpectedEndOfStream,
106 teInvalidHeader,
107 teInvalidStreamOffset,
108 teCircularOffset,
109 teUnhandledException,
110 teUnknownValueType,
111 teDuplicateTag);
112
113 { TTiffIO }
114
115 TTiffIO = object
116 private
117 FStream: TStream;
118 FStartPos: int64;
119 FLittleEndian: boolean;
GetPositionnull120 function GetPosition: int64;
GetSizenull121 function GetSize: int64;
122 procedure SetPosition(AValue: int64);
123 public
124 procedure Init(AStream: TStream; AStartPos: int64);
CopyTonull125 function CopyTo(AStream: TStream; ACount: LongWord): TTiffError;
126 procedure CopyFrom(AStream: TStream; ACount: LongWord);
ReadBuffernull127 function ReadBuffer(var ABuffer; ACount: integer): TTiffError;
128 procedure WriteBuffer(var ABuffer; ACount: integer);
ReadBytenull129 function ReadByte(out AValue: byte): TTiffError;
ReadWordnull130 function ReadWord(out AValue: Word): TTiffError;
ReadLongnull131 function ReadLong(out AValue: LongWord): TTiffError;
132 procedure WriteByte(AValue: byte);
133 procedure WriteWord(AValue: Word);
134 procedure WriteLong(AValue: LongWord);
FixEndiannull135 function FixEndian(AValue: Word): Word;
FixEndiannull136 function FixEndian(AValue: LongWord): LongWord;
FixEndiannull137 function FixEndian(AValue: QWord): QWord;
138 property LittleEndian: boolean read FLittleEndian write FLittleEndian;
139 property Position: int64 read GetPosition write SetPosition;
140 property Size: int64 read GetSize;
141 end;
142
143 TTiffValueType = (tvtUnknown, tvtByte, tvtAscii, tvtWord, tvtLong, tvtRational,
144 tvtSignedByte, tvtRawByte, tvtSignedWord, tvtSignedLongWord, tvtSignedRational,
145 tvtSingle, tvtDouble);
146
147 const
148 TiffValueSize : array[TTiffValueType] of Byte =
149 (0, 1, 1, 2, 4, 8,
150 1, 1, 2, 4, 8, 4, 8);
151 TiffValueTypeStr : array[TTiffValueType] of string =
152 ('Unknown','Byte','Ascii','Word','Long','Rational',
153 'SignedByte','RawByte','SignedWord','SignedLong','SignedRational',
154 'Single','Double');
155
156 type
157 TTiffRawDirEntry = packed record
158 Tag: Word;
159 ValueType: Word;
160 ValueCount: LongWord;
161 case boolean of
162 false: (ShortData: array[1..4] of Byte);
163 true: (ValueOffset: LongWord);
164 end;
165
166 { TTiffRational }
167
168 TTiffRational = object
169 Numerator, Denominator: LongWord;
170 Negative: boolean;
AsStringnull171 function AsString: string;
AsDoublenull172 function AsDouble: double;
173 end;
174
TiffRationalnull175 function TiffRational(ANumerator,ADenominator: LongWord): TTiffRational;
TiffRationalnull176 function TiffRational(ANumerator,ADenominator: Integer): TTiffRational;
177
178 type
179 ArrayOfLongWord = array of LongWord;
180 ArrayOfWord = array of Word;
181
182 { TTiffDirEntry }
183 PTiffDirEntry = ^TTiffDirEntry;
184 TTiffDirEntry = object
185 private
186 FTag: Word;
187 FValueType: TTiffValueType;
188 FValueCount: LongWord;
189 FShortData: array[1..4] of byte;
190 FLongData: pointer;
191 procedure FixEndianData(AData: Pointer; AIO: TTiffIO);
GetDatanull192 function GetData: Pointer;
GetDoubleValuenull193 function GetDoubleValue(AIndex: LongWord): Double;
GetRationalValuenull194 function GetRationalValue(AIndex: LongWord): TTiffRational;
GetNamenull195 function GetName: string;
GetSignedValuenull196 function GetSignedValue(AIndex: LongWord): Integer;
GetStringValuenull197 function GetStringValue: string;
GetUnsignedValuenull198 function GetUnsignedValue(AIndex: LongWord): LongWord;
199 public
200 procedure Free;
201 procedure Realloc(AValueType: TTiffValueType; AValueCount: LongWord);
202 procedure InitNew(ATag: Word);
LoadFromInputnull203 function LoadFromInput(AInput: TTiffIO; const ARaw: TTiffRawDirEntry): TTiffError;
204 procedure SaveToOutput(AOutput: TTiffIO; out ARaw: TTiffRawDirEntry);
205 procedure SetLong(AValue: LongWord);
206 procedure SetWord(AValue: Word);
207 procedure SetByte(AValue: Byte);
208 procedure SetLongArray(AValues: ArrayOfLongWord);
209 procedure SetWordArray(AValues: ArrayOfWord);
210 property Tag: Word read FTag;
211 property ValueType: TTiffValueType read FValueType;
212 property ValueCount: LongWord read FValueCount;
213 property Data: Pointer read GetData;
214 property Name: string read GetName;
215 property StringValue: string read GetStringValue;
216 property SignedValue[AIndex: LongWord]: Integer read GetSignedValue;
217 property UnsignedValue[AIndex: LongWord]: LongWord read GetUnsignedValue;
218 property RationalValue[AIndex: LongWord]: TTiffRational read GetRationalValue;
219 property DoubleValue[AIndex: LongWord]: Double read GetDoubleValue;
220 end;
221
222 TStreamList = specialize TFPGObjectList<TStream>;
223
224 { TTiffDirectory }
225
226 TTiffDirectory = class
227 private
228 FDirEntries: packed array of TTiffDirEntry;
229 FDirEntryCount: integer;
GetEntrynull230 function GetEntry(AIndex: integer): PTiffDirEntry;
LoadChunksnull231 function LoadChunks(AInput: TTiffIO): TTiffError; virtual; abstract;
232 procedure SaveChunks(AOutput: TTiffIO); virtual; abstract;
LoadChunkListnull233 function LoadChunkList(AInput: TTiffIO; ATagOffsets, ATagByteCounts: Word; var AList: TStreamList): TTiffError;
234 procedure SaveChunkList(AOutput: TTiffIO; ATagOffsets, ATagByteCounts: Word; AList: TStreamList);
235 procedure ClearChunkList(var AList: TStreamList);
236 public
237 constructor Create;
238 destructor Destroy; override;
239 procedure Clear;
240 procedure SortEntries;
AddEntrynull241 function AddEntry(const AEntry: TTiffDirEntry): TTiffError;
LoadFromInputnull242 function LoadFromInput(AInput: TTiffIO; ADirectoryPos: LongWord; out ANextDirectoryPos: LongWord): TTiffError;
243 procedure SaveToOutput(AOutput: TTiffIO; out ADirectoryPos: LongWord; out ANextDirectoryPosStreamPos: int64);
ToStringnull244 function ToString: ansistring; override;
GetOrCreateTagnull245 function GetOrCreateTag(ATag: Word): PTiffDirEntry;
RemoveTagnull246 function RemoveTag(ATag: Word): boolean;
IndexOfTagnull247 function IndexOfTag(ATag: Word): integer;
248 property EntryCount: integer read FDirEntryCount;
249 property Entry[AIndex: integer]: PTiffDirEntry read GetEntry;
250 end;
251
252 { TTiffExifDirectory }
253
254 TTiffExifDirectory = class(TTiffDirectory)
255 private
LoadChunksnull256 function LoadChunks({%H-}AInput: TTiffIO): TTiffError; override;
257 procedure SaveChunks({%H-}AOutput: TTiffIO); override;
258 public
259 constructor Create;
260 end;
261
262 { TTiffImageDirectory }
263
264 TTiffImageDirectory = class(TTiffDirectory) //also called IFD
265 private
266 FExif: TTiffExifDirectory;
267 FStripChunks, FTileChunks, FFreeChunks: TStreamList;
GetBitDepthnull268 function GetBitDepth: Word;
GetExtraBitDepthnull269 function GetExtraBitDepth: Word;
GetHeightnull270 function GetHeight: LongWord;
GetTotalBitDepthnull271 function GetTotalBitDepth: Word;
GetWidthnull272 function GetWidth: LongWord;
LoadChunksnull273 function LoadChunks(AInput: TTiffIO): TTiffError; override;
274 procedure SaveChunks(AOutput: TTiffIO); override;
LoadExifChunknull275 function LoadExifChunk(AInput: TTiffIO): TTiffError;
276 procedure SaveExifChunk(AOutput: TTiffIO);
277 public
278 constructor Create;
279 destructor Destroy; override;
280 property Width: LongWord read GetWidth;
281 property Height: LongWord read GetHeight;
282 property BitDepth: Word read GetBitDepth;
283 property ExtraBitDepth: Word read GetExtraBitDepth;
284 property TotalBitDepth: Word read GetTotalBitDepth;
285 end;
286
287 TTiffImageDirectoryList = specialize TFPGObjectList<TTiffImageDirectory>;
288
289 { TTiff }
290
291 TTiff = class
292 private
293 FImageEntries: TTiffImageDirectoryList;
294 FLittleEndian: boolean;
GetCountnull295 function GetCount: integer;
GetEntrynull296 function GetEntry(AIndex: integer): TTiffImageDirectory;
297 protected
ReadHeadernull298 function ReadHeader(var AInput: TTiffIO; out AFirstImagePos: LongWord): TTiffError;
299 procedure WriteHeader(var AOutput: TTiffIO; out AFirstImagePosStreamPos: int64);
LoadImageEntriesnull300 function LoadImageEntries(var AInput: TTiffIO; AFirstImagePos: LongWord): TTiffError;
301 public
302 constructor Create;
303 procedure Clear;
LoadFromStreamnull304 function LoadFromStream(AStream: TStream): TTiffError;
305 procedure SaveToStream(AStream: TStream); overload;
306 procedure SaveToStream(AStream: TStream; AEntryIndices: array of integer); overload;
307 procedure Delete(AIndex: integer);
308 procedure Move(AFromTiff: TTiff; AFromIndex: integer; AToIndex: integer); overload;
Movenull309 function Move(AFromTiff: TTiff; AFromIndex: integer): integer; overload;
310 procedure Move(AFromIndex, AToIndex: integer); overload;
311 destructor Destroy; override;
ToStringnull312 function ToString: ansistring; override;
GetBiggestImagenull313 function GetBiggestImage: TTiffImageDirectory;
IndexOfImagenull314 function IndexOfImage(AImage: TTiffImageDirectory): integer;
315 property Count: integer read GetCount;
316 property Entry[AIndex: integer]: TTiffImageDirectory read GetEntry;
317 property LittleEndian: boolean read FLittleEndian write FLittleEndian;
318 end;
319
GetTiffTagNamenull320 function GetTiffTagName(ATag: Word): string;
321
322 implementation
323
324 uses math;
325
TiffRationalnull326 function TiffRational(ANumerator, ADenominator: LongWord): TTiffRational;
327 begin
328 result.Numerator := ANumerator;
329 result.Denominator:= ADenominator;
330 result.Negative := false;
331 end;
332
TiffRationalnull333 function TiffRational(ANumerator, ADenominator: Integer): TTiffRational;
334 begin
335 result.Numerator := abs(ANumerator);
336 result.Denominator:= abs(ADenominator);
337 result.Negative := (ANumerator < 0) xor (ADenominator < 0);
338 end;
339
GetTiffTagNamenull340 function GetTiffTagName(ATag: Word): string;
341 begin
342 case ATag of
343 TiffTagNewSubFileType: result := 'NewSubFileType';
344 TiffTagSubfileType: result := 'SubfileType';
345 TiffTagImageWidth: result := 'ImageWidth';
346 TiffTagImageLength: result := 'ImageLength';
347 TiffTagBitsPerSample: result := 'BitsPerSample';
348 TiffTagCompression: result := 'Compression';
349 TiffTagPhotometricInterpretation: result := 'PhotometricInterpretation';
350 TiffTagThresholding: result := 'Thresholding';
351 TiffTagCellWidth: result := 'CellWidth';
352 TiffTagCellLength: result := 'CellLength';
353 TiffTagFillOrder: result := 'FillOrder';
354 TiffTagDocumentName: result := 'DocumentName';
355 TiffTagImageDescription: result := 'ImageDescription';
356 TiffTagMake: result := 'Make';
357 TiffTagModel: result := 'Model';
358 TiffTagStripOffsets: result := 'StripOffsets';
359 TiffTagOrientation: result := 'Orientation';
360 TiffTagSamplesPerPixel: result := 'SamplesPerPixel';
361 TiffTagRowsPerStrip: result := 'RowsPerStrip';
362 TiffTagStripByteCounts: result := 'StripByteCounts';
363 TiffTagMinSampleValue: result := 'MinSampleValue';
364 TiffTagMaxSampleValue: result := 'MaxSampleValue';
365 TiffTagXResolution: result := 'XResolution';
366 TiffTagYResolution: result := 'YResolution';
367 TiffTagPlanarConfiguration: result := 'PlanarConfiguration';
368 TiffTagPageName: result := 'PageName';
369 TiffTagXPosition: result := 'XPosition';
370 TiffTagYPosition: result := 'YPosition';
371 TiffTagFreeOffsets: result := 'FreeOffsets';
372 TiffTagFreeByteCounts: result := 'FreeByteCounts';
373 TiffTagGrayResponseUnit: result := 'GrayResponseUnit';
374 TiffTagGrayResponseCurve: result := 'GrayResponseCurve';
375 TiffTagT4Options: result := 'T4Options';
376 TiffTagT6Options: result := 'T6Options';
377 TiffTagResolutionUnit: result := 'ResolutionUnit';
378 TiffTagPageNumber: result := 'PageNumber';
resultnull379 TiffTagTransferFunction: result := 'TransferFunction';
380 TiffTagSoftware: result := 'Software';
381 TiffTagDateTime: result := 'DateTime';
382 TiffTagArtist: result := 'Artist';
383 TiffTagHostComputer: result := 'HostComputer';
384 TiffTagPredictor: result := 'Predictor';
385 TiffTagWhitePoint: result := 'WhitePoint';
386 TiffTagPrimaryChromacities: result := 'PrimaryChromacities';
387 TiffTagColorMap: result := 'ColorMap';
388 TiffTagHalftoneHints: result := 'HalftoneHints';
389 TiffTagTileWidth: result := 'TileWidth';
390 TiffTagTileLength: result := 'TileLength';
391 TiffTagTileOffsets: result := 'TileOffsets';
392 TiffTagTileByteCounts: result := 'TileByteCounts';
393 TiffTagBadFaxLines: result := 'BadFaxLines';
394 TiffTagCleanFaxData: result := 'CleanFaxData';
395 TiffTagConsecutiveBadFaxLines: result := 'ConsecutiveBadFaxLines';
396 TiffTagInkSet: result := 'InkSet';
397 TiffTakInkNames: result := 'InkNames';
398 TiffTagNumberOfInks: result := 'NumberOfInks';
399 TiffTagDotRange: result := 'DotRange';
400 TiffTagTargetPrinter: result := 'TargetPrinter';
401 TiffTagExtraSamples: result := 'ExtraSamples';
402 TiffTagSampleFormat: result := 'SampleFormat';
403 TiffTagSMinSampleValue: result := 'SMinSampleValue';
404 TiffTagSMaxSampleValue: result := 'SMaxSampleValue';
405 TiffTagTransferRange: result := 'TransferRange';
406 TiffTagJPEGTables: result := 'JPEGTables';
407 TiffTagJPEGProc: result := 'JPEGProc';
408 TiffTagJPEGInterchangeFormat: result := 'JPEGInterchangeFormat';
409 TiffTagJPEGInterchangeFormatLength: result := 'JPEGInterchangeFormatLength';
410 TiffTagJPEGRestartInterval: result := 'JPEGRestartInterval';
411 TiffTagJPEGLosslessPerdictors: result := 'JPEGLosslessPerdictors';
412 TiffTagJPEGPointTransforms: result := 'JPEGPointTransforms';
413 TiffTagJPEGQTables: result := 'JPEGQTables';
414 TiffTagJPEGDCTables: result := 'JPEGDCTables';
415 TiffTagJPEGACTables: result := 'JPEGACTables';
416 TiffTagYCbCrCoefficients: result := 'YCbCrCoefficients';
417 TiffTafYCbCrSubSampling: result := 'YCbCrSubSampling';
418 TiffTagYCbCrPositioning: result := 'YCbCrPositioning';
419 TiffTagReferenceBlackWhite: result := 'ReferenceBlackWhite';
420 TiffTagXMLPacket: result := 'XMLPacket';
421 TiffTagCopyright: result := 'Copyright';
422 TiffTagRichTiffIPTC: result := 'RichTiffIPTC';
423 TiffTagPhotoshopImageResourceBlocks: result := 'PhotoshopImageResourceBlocks';
424 TiffTagExifIFD: result := 'ExifIFD';
425 TiffTagICCProfile: result := 'ICCProfile';
426
427 TiffTagHylaFaxReceiveParams: result := 'HylaFaxReceiveParams';
428 TiffTagHylaFaxReceiveTimeSecs: result := 'HylaFaxReceiveTimeSecs';
429
430 ExifTagColorspace: result := 'Colorspace';
431 ExifTagPixelXDimension: result := 'PixelXDimension';
432 ExifTagPixelYDimension: result := 'PixelYDimension';
433 else
434 result := 'Tag'+IntToStr(ATag);
435 end;
436 end;
437
438 { TTiffExifDirectory }
439
LoadChunksnull440 function TTiffExifDirectory.LoadChunks(AInput: TTiffIO): TTiffError;
441 begin
442 result := teNone;
443 end;
444
445 procedure TTiffExifDirectory.SaveChunks(AOutput: TTiffIO);
446 begin
447 //nothing
448 end;
449
450 constructor TTiffExifDirectory.Create;
451 begin
452 inherited Create;
453 end;
454
455 { TTiffImageDirectory }
456
LoadChunksnull457 function TTiffImageDirectory.LoadChunks(AInput: TTiffIO): TTiffError;
458 var subError: TTiffError;
459 begin
460 LoadExifChunk(AInput); //ignore error as Exif is optional
461
462 subError := LoadChunkList(AInput, TiffTagStripOffsets, TiffTagStripByteCounts, FStripChunks);
463 if subError <> teNone then Exit(subError);
464
465 subError := LoadChunkList(AInput, TiffTagTileOffsets, TiffTagTileByteCounts, FTileChunks);
466 if subError <> teNone then Exit(subError);
467
468 subError := LoadChunkList(AInput, TiffTagFreeOffsets, TiffTagFreeByteCounts, FFreeChunks);
469 if subError <> teNone then Exit(subError);
470
471 result := teNone;
472 end;
473
474 procedure TTiffImageDirectory.SaveChunks(AOutput: TTiffIO);
475 begin
476 SaveChunkList(AOutput, TiffTagStripOffsets, TiffTagStripByteCounts, FStripChunks);
477 SaveChunkList(AOutput, TiffTagTileOffsets, TiffTagTileByteCounts, FTileChunks);
478 SaveChunkList(AOutput, TiffTagFreeOffsets, TiffTagFreeByteCounts, FFreeChunks);
479 SaveExifChunk(AOutput);
480 end;
481
GetWidthnull482 function TTiffImageDirectory.GetWidth: LongWord;
483 var idxWidth: integer;
484 begin
485 idxWidth := IndexOfTag(TiffTagImageWidth);
486 if idxWidth = -1 then result := 0
487 else result := Entry[idxWidth]^.UnsignedValue[0];
488 end;
489
TTiffImageDirectory.GetHeightnull490 function TTiffImageDirectory.GetHeight: LongWord;
491 var idxHeight: integer;
492 begin
493 idxHeight := IndexOfTag(TiffTagImageLength);
494 if idxHeight = -1 then result := 0
495 else result := Entry[idxHeight]^.UnsignedValue[0];
496 end;
497
TTiffImageDirectory.GetBitDepthnull498 function TTiffImageDirectory.GetBitDepth: Word;
499 begin
500 result := TotalBitDepth - ExtraBitDepth;
501 end;
502
TTiffImageDirectory.GetExtraBitDepthnull503 function TTiffImageDirectory.GetExtraBitDepth: Word;
504 var
505 idxDepth, i: Integer;
506 begin
507 idxDepth := IndexOfTag(TiffTagExtraSamples);
508 result := 0;
509 if idxDepth <> -1 then
510 with Entry[idxDepth]^ do
511 for i := 0 to ValueCount-1 do
512 inc(result, UnsignedValue[i]);
513 end;
514
TTiffImageDirectory.GetTotalBitDepthnull515 function TTiffImageDirectory.GetTotalBitDepth: Word;
516 var
517 idxDepth, i: Integer;
518 begin
519 idxDepth := IndexOfTag(TiffTagBitsPerSample);
520 result := 0;
521 if idxDepth <> -1 then
522 with Entry[idxDepth]^ do
523 for i := 0 to ValueCount-1 do
524 inc(result, UnsignedValue[i]);
525 end;
526
527 constructor TTiffImageDirectory.Create;
528 begin
529 inherited Create;
530 FExif := nil;
531 FStripChunks := nil;
532 FTileChunks := nil;
533 FFreeChunks := nil;
534 end;
535
536 destructor TTiffImageDirectory.Destroy;
537 begin
538 ClearChunkList(FStripChunks);
539 ClearChunkList(FTileChunks);
540 ClearChunkList(FFreeChunks);
541 FreeAndNil(FExif);
542 inherited Destroy;
543 end;
544
TTiffImageDirectory.LoadExifChunknull545 function TTiffImageDirectory.LoadExifChunk(AInput: TTiffIO): TTiffError;
546 var idxExif: integer;
547 nextExifPos: LongWord;
548 begin
549 idxExif := IndexOfTag(TiffTagExifIFD);
550 if (idxExif = -1) then exit;
551 with Entry[idxExif]^ do
552 if (ValueCount = 1) and (ValueType in[tvtLong,tvtWord,tvtByte]) then
553 begin
554 FreeAndNil(FExif);
555 FExif := TTiffExifDirectory.Create;
556 result := FExif.LoadFromInput(AInput, UnsignedValue[0], nextExifPos);
557 if result <> teNone then FreeAndNil(FExif);
558 end else
559 result := teInvalidStreamOffset;
560 end;
561
562 procedure TTiffImageDirectory.SaveExifChunk(AOutput: TTiffIO);
563 var
564 exifPos: LongWord;
565 nextExifPosStreamPos: int64;
566 exifEntry: PTiffDirEntry;
567 begin
568 if Assigned(FExif) then
569 exifEntry := GetOrCreateTag(TiffTagExifIFD)
570 else
571 begin
572 RemoveTag(TiffTagExifIFD);
573 exit;
574 end;
575 FExif.SaveToOutput(AOutput, exifPos, nextExifPosStreamPos);
576 exifEntry^.SetLong(exifPos);
577 end;
578
579 { TTiffRational }
580
AsStringnull581 function TTiffRational.AsString: string;
582 begin
583 if Negative then result := '-' else result := '';
584 result += IntToStr(Numerator)+'/'+IntToStr(Denominator);
585 end;
586
AsDoublenull587 function TTiffRational.AsDouble: double;
588 begin
589 result := Numerator/Denominator;
590 if Negative then result := -result;
591 end;
592
593 { TTiffIO }
594
GetPositionnull595 function TTiffIO.GetPosition: int64;
596 begin
597 result := FStream.Position - FStartPos;
598 end;
599
TTiffIO.GetSizenull600 function TTiffIO.GetSize: int64;
601 begin
602 result := FStream.Size - FStartPos;
603 end;
604
605 procedure TTiffIO.SetPosition(AValue: int64);
606 begin
607 FStream.Position := AValue + FStartPos;
608 end;
609
610 procedure TTiffIO.Init(AStream: TStream; AStartPos: int64);
611 begin
612 FStream := AStream;
613 FLittleEndian:= false;
614 FStartPos := AStartPos;
615 if AStream.Position <> AStartPos then
616 AStream.Position:= AStartPos;
617 end;
618
CopyTonull619 function TTiffIO.CopyTo(AStream: TStream; ACount: LongWord): TTiffError;
620 begin
621 if AStream.CopyFrom(FStream, ACount) <> ACount then
622 result := teUnexpectedEndOfStream
623 else
624 result := teNone;
625 end;
626
627 procedure TTiffIO.CopyFrom(AStream: TStream; ACount: LongWord);
628 begin
629 if FStream.CopyFrom(AStream, ACount) <> ACount then
630 raise exception.Create('Unexpected end of stream');
631 end;
632
ReadBuffernull633 function TTiffIO.ReadBuffer(var ABuffer; ACount: integer): TTiffError;
634 begin
635 fillchar(ABuffer, ACount, 0);
636 if FStream.Read(ABuffer, ACount) <> ACount then
637 exit(teUnexpectedEndOfStream)
638 else
639 exit(teNone);
640 end;
641
642 procedure TTiffIO.WriteBuffer(var ABuffer; ACount: integer);
643 begin
644 FStream.WriteBuffer(ABuffer, ACount);
645 end;
646
ReadBytenull647 function TTiffIO.ReadByte(out AValue: byte): TTiffError;
648 begin
649 AValue := 0;
650 result := ReadBuffer(AValue, sizeof(AValue));
651 end;
652
ReadWordnull653 function TTiffIO.ReadWord(out AValue: Word): TTiffError;
654 begin
655 AValue := 0;
656 result := ReadBuffer(AValue, sizeof(AValue));
657 AValue := FixEndian(AValue);
658 end;
659
ReadLongnull660 function TTiffIO.ReadLong(out AValue: LongWord): TTiffError;
661 begin
662 AValue := 0;
663 result := ReadBuffer(AValue, sizeof(AValue));
664 AValue := FixEndian(AValue);
665 end;
666
667 procedure TTiffIO.WriteByte(AValue: byte);
668 begin
669 FStream.WriteByte(AValue);
670 end;
671
672 procedure TTiffIO.WriteWord(AValue: Word);
673 begin
674 AValue := FixEndian(AValue);
675 WriteBuffer(AValue, sizeof(AValue));
676 end;
677
678 procedure TTiffIO.WriteLong(AValue: LongWord);
679 begin
680 AValue := FixEndian(AValue);
681 WriteBuffer(AValue, sizeof(AValue));
682 end;
683
TTiffIO.FixEndiannull684 function TTiffIO.FixEndian(AValue: Word): Word;
685 begin
686 If FLittleEndian then
687 result := LEtoN(AValue)
688 else
689 result := BEtoN(AValue);
690 end;
691
TTiffIO.FixEndiannull692 function TTiffIO.FixEndian(AValue: LongWord): LongWord;
693 begin
694 If FLittleEndian then
695 result := LEtoN(AValue)
696 else
697 result := BEtoN(AValue);
698 end;
699
TTiffIO.FixEndiannull700 function TTiffIO.FixEndian(AValue: QWord): QWord;
701 begin
702 If FLittleEndian then
703 result := LEtoN(AValue)
704 else
705 result := BEtoN(AValue);
706 end;
707
708 { TTiffDirEntry }
709
GetDatanull710 function TTiffDirEntry.GetData: Pointer;
711 begin
712 if Assigned(FLongData) then
713 result := FLongData
714 else
715 result := @FShortData;
716 end;
717
GetDoubleValuenull718 function TTiffDirEntry.GetDoubleValue(AIndex: LongWord): Double;
719 begin
720 case ValueType of
721 tvtSingle: result := PSingle(Data)[AIndex];
722 tvtDouble: result := PDouble(Data)[AIndex];
723 tvtSignedByte,tvtSignedWord,tvtSignedLongWord: result := GetSignedValue(AIndex);
724 tvtByte,tvtWord,tvtLong: result := GetUnsignedValue(AIndex);
725 tvtRational,tvtSignedRational: result := GetRationalValue(AIndex).AsDouble;
726 else
727 raise Exception.Create('Incompatible types');
728 end;
729 end;
730
TTiffDirEntry.GetRationalValuenull731 function TTiffDirEntry.GetRationalValue(AIndex: LongWord): TTiffRational;
732 begin
733 case ValueType of
734 tvtRational: result := TiffRational(PLongWord(Data)[AIndex*2],PLongWord(Data)[AIndex*2+1]);
735 tvtSignedRational: result := TiffRational(PInteger(Data)[AIndex*2],PInteger(Data)[AIndex*2+1]);
736 tvtSignedByte,tvtSignedWord,tvtSignedLongWord: result := TiffRational(GetSignedValue(AIndex),1);
737 tvtByte,tvtWord,tvtLong: TiffRational(GetUnsignedValue(AIndex),1);
738 else
739 raise Exception.Create('Incompatible types');
740 end;
741 end;
742
TTiffDirEntry.GetNamenull743 function TTiffDirEntry.GetName: string;
744 begin
745 result := GetTiffTagName(Tag);
746 end;
747
TTiffDirEntry.GetSignedValuenull748 function TTiffDirEntry.GetSignedValue(AIndex: LongWord): Integer;
749 begin
750 if AIndex >= ValueCount then
751 raise ERangeError.Create('Index out of bounds');
752 case ValueType of
753 tvtSignedByte: result := PShortInt(Data)[AIndex];
754 tvtSignedWord: result := PSmallInt(Data)[AIndex];
755 tvtSignedLongWord: result := PLongInt(Data)[AIndex];
756 else result := GetUnsignedValue(AIndex);
757 end;
758 end;
759
GetStringValuenull760 function TTiffDirEntry.GetStringValue: string;
761 var
762 i: LongWord;
763 begin
764 case ValueType of
765 tvtAscii: begin
766 setlength(result, ValueCount-1);
767 if result <> '' then
768 move(Data^, result[1], length(result));
769 result := '''' + StringReplace(result, '''', '''''', [rfReplaceAll]) + '''';
770 end;
771 tvtRawByte: result := '<'+inttostr(ValueCount)+' raw bytes>';
772 tvtUnknown: result := '?';
773 else
774 begin
775 if (ValueCount > 40) and (ValueType = tvtByte) then
776 result := '<'+inttostr(ValueCount)+' bytes>'
777 else
778 if (ValueCount > 40) and (ValueType = tvtWord) then
779 result := '<'+inttostr(ValueCount)+' words>'
780 else
781 if (ValueCount > 40) and (ValueType = tvtLong) then
782 result := '<'+inttostr(ValueCount)+' longs>'
783 else
784 begin
785 if ValueCount <> 1 then result := '[' else result := '';
786 if ValueCount > 0 then
787 for i := 0 to ValueCount-1 do
788 begin
789 if i > 0 then result += ', ';
790 case ValueType of
791 tvtByte,tvtWord,tvtLong:
792 result += IntToStr(UnsignedValue[i]);
793 tvtSignedByte,tvtSignedWord,tvtSignedLongWord:
794 result += IntToStr(SignedValue[i]);
795 tvtRational,tvtSignedRational:
796 result += RationalValue[i].AsString;
797 tvtSingle,tvtDouble:
798 result += FloatToStr(DoubleValue[i]);
799 else
800 result += '?';
801 end;
802 end;
803 if ValueCount <> 1 then result += ']';
804 end;
805 end;
806 end;
807 end;
808
GetUnsignedValuenull809 function TTiffDirEntry.GetUnsignedValue(AIndex: LongWord): LongWord;
810 var
811 signed: Integer;
812 begin
813 if AIndex >= ValueCount then
814 raise ERangeError.Create('Index out of bounds');
815 case ValueType of
816 tvtSignedByte,tvtSignedWord,tvtSignedLongWord:
817 begin
818 signed := GetSignedValue(AIndex);
819 if signed < 0 then result := 0
820 else result := signed;
821 end;
822 tvtByte,tvtAscii,tvtRawByte: result := PByte(Data)[AIndex];
823 tvtWord: result := PWord(Data)[AIndex];
824 tvtLong: result := PLongWord(Data)[AIndex];
825 else
826 raise Exception.Create('Not implemented');
827 end;
828 end;
829
830 procedure TTiffDirEntry.Free;
831 begin
832 ReallocMem(FLongData, 0);
833 end;
834
835 procedure TTiffDirEntry.Realloc(AValueType: TTiffValueType; AValueCount: LongWord);
836 var dataSize: PtrUInt;
837 begin
838 FValueType := AValueType;
839 FValueCount := AValueCount;
840 dataSize := PtrUInt(TiffValueSize[AValueType])*AValueCount;
841 if dataSize <= 4 then
842 Free
843 else
844 ReallocMem(FLongData, dataSize);
845 end;
846
847 procedure TTiffDirEntry.InitNew(ATag: Word);
848 begin
849 FTag := ATag;
850 FValueCount:= 0;
851 FValueType := tvtUnknown;
852 fillchar(FShortData, sizeof(FShortData), 0);
853 FLongData := nil;
854 end;
855
856 procedure TTiffDirEntry.FixEndianData(AData: Pointer; AIO: TTiffIO);
857 var i: LongWord;
858 begin
859 if FValueCount = 0 then exit;
860
861 if FValueType in[tvtWord, tvtSignedWord] then
862 begin
863 for i := 0 to FValueCount-1 do
864 PWord(AData)[i] := AIO.FixEndian(PWord(AData)[i]);
865 end else
866 if FValueType in [tvtLong,tvtRational, tvtSignedLongWord,tvtSignedRational, tvtSingle] then
867 begin
868 for i := 0 to FValueCount-1 do
869 PLongWord(AData)[i] := AIO.FixEndian(PLongWord(AData)[i]);
870 end else
871 if FValueType = tvtDouble then
872 begin
873 for i := 0 to FValueCount-1 do
874 PQWord(AData)[i] := AIO.FixEndian(PQWord(AData)[i]);
875 end;
876 end;
877
LoadFromInputnull878 function TTiffDirEntry.LoadFromInput(AInput: TTiffIO; const ARaw: TTiffRawDirEntry): TTiffError;
879 var dataSize: PtrUInt;
880 valueTypeWord: Word;
881 valueOffset: LongWord;
882 begin
883 FTag := AInput.FixEndian(ARaw.Tag);
884 FValueCount:= AInput.FixEndian(ARaw.ValueCount);
885 FValueType := tvtUnknown;
886 fillchar(FShortData, sizeof(FShortData), 0);
887 FLongData := nil;
888
889 valueTypeWord := AInput.FixEndian(ARaw.ValueType);
890 if (valueTypeWord = 0) or (valueTypeWord > ord(high(TTiffValueType))) then
891 Exit(teUnknownValueType);
892 FValueType := TTiffValueType(valueTypeWord);
893
894 dataSize := PtrUInt(TiffValueSize[FValueType]) * FValueCount;
895 if dataSize > 4 then
896 begin
897 valueOffset := AInput.FixEndian(ARaw.ValueOffset);
898 if (valueOffset < 8) or (valueOffset > AInput.Size - dataSize) then
899 Exit(teInvalidStreamOffset);
900 AInput.Position := valueOffset;
901
902 GetMem(FLongData, dataSize);
903 result := AInput.ReadBuffer(FLongData^, dataSize);
904 if result <> teNone then
905 ReallocMem(FLongData, 0)
906 else
907 FixEndianData(FLongData, AInput);
908 end else
909 begin
910 move(ARaw.ShortData, FShortData, dataSize);
911 FixEndianData(@FShortData, AInput);
912 Exit(teNone);
913 end;
914 end;
915
916 procedure TTiffDirEntry.SaveToOutput(AOutput: TTiffIO; out
917 ARaw: TTiffRawDirEntry);
918 var
919 dataSize: PtrUInt;
920 begin
921 ARaw.Tag := AOutput.FixEndian(Tag);
922 ARaw.ValueCount := AOutput.FixEndian(ValueCount);
923 ARaw.ValueType := AOutput.FixEndian(Word(ValueType));
924 dataSize := PtrUInt(TiffValueSize[ValueType]) * ValueCount;
925 if dataSize > 4 then
926 begin
927 if not Assigned(FLongData) then
928 raise exception.Create('Long data not allocated');
929 if dataSize > maxLongint then
930 raise exception.Create('Data too long');
931
932 {$PUSH}{$RANGECHECKS ON}
933 ARaw.ValueOffset:= AOutput.FixEndian(LongWord(AOutput.Position));
934 {$POP}
935 FixEndianData(FLongData, AOutput);
936 AOutput.WriteBuffer(FLongData^, dataSize);
937 FixEndianData(FLongData, AOutput);
938 end else
939 begin
940 move(FShortData, ARaw.ShortData, dataSize);
941 FixEndianData(@ARaw.ShortData, AOutput);
942 end;
943 end;
944
945 procedure TTiffDirEntry.SetLong(AValue: LongWord);
946 begin
947 Realloc(tvtLong, 1);
948 PLongWord(Data)[0] := AValue;
949 end;
950
951 procedure TTiffDirEntry.SetWord(AValue: Word);
952 begin
953 Realloc(tvtWord, 1);
954 PWord(Data)[0] := AValue;
955 end;
956
957 procedure TTiffDirEntry.SetByte(AValue: Byte);
958 begin
959 Realloc(tvtByte, 1);
960 PByte(Data)[0] := AValue;
961 end;
962
963 procedure TTiffDirEntry.SetLongArray(AValues: ArrayOfLongWord);
964 var i: Integer;
965 p : PLongWord;
966 wordSized: boolean;
967 words: ArrayOfWord;
968 begin
969 wordSized := true;
970 for i := 0 to high(AValues) do
971 if AValues[i] > high(Word) then
972 begin
973 wordSized := false;
974 break;
975 end;
976 if wordSized then
977 begin
978 setlength(words, length(AValues));
979 for i := 0 to high(AValues) do
980 words[i] := AValues[i];
981 SetWordArray(words);
982 exit;
983 end;
984
985 Realloc(tvtLong, length(AValues));
986 if length(AValues)>0 then
987 begin
988 p := PLongWord(Data);
989 for i := 0 to high(AValues) do
990 p[i] := AValues[i];
991 end;
992 end;
993
994 procedure TTiffDirEntry.SetWordArray(AValues: ArrayOfWord);
995 var i: Integer;
996 p : PWord;
997 begin
998 Realloc(tvtWord, length(AValues));
999 if length(AValues)>0 then
1000 begin
1001 p := PWord(Data);
1002 for i := 0 to high(AValues) do
1003 p[i] := AValues[i];
1004 end;
1005 end;
1006
1007 { TTiffDirectory }
1008
TTiffDirectory.GetEntrynull1009 function TTiffDirectory.GetEntry(AIndex: integer): PTiffDirEntry;
1010 begin
1011 result := @FDirEntries[AIndex];
1012 end;
1013
1014 constructor TTiffDirectory.Create;
1015 begin
1016 FDirEntryCount := 0;
1017 end;
1018
1019 destructor TTiffDirectory.Destroy;
1020 begin
1021 Clear;
1022 inherited Destroy;
1023 end;
1024
1025 procedure TTiffDirectory.Clear;
1026 var i: integer;
1027 begin
1028 for i := 0 to FDirEntryCount-1 do
1029 FDirEntries[i].Free;
1030 FDirEntries := nil;
1031 FDirEntryCount:= 0;
1032 end;
1033
CompareTagOfDirEntrynull1034 function CompareTagOfDirEntry(elem1, elem2: pointer): Integer;
1035 begin
1036 result := integer(PTiffDirEntry(elem1)^.Tag) - integer(PTiffDirEntry(elem2)^.Tag);
1037 end;
1038
1039 procedure TTiffDirectory.SortEntries;
1040 type
1041 TCompareFunc = function (elem1, elem2: pointer): Integer;
1042
1043 procedure AnyQuickSort(Arr: pointer; idxL, idxH: Integer;
1044 Stride: Integer; CompareFunc: TCompareFunc;
1045 SwapBuf : Pointer = nil);
1046 var
1047 ls,hs : Integer;
1048 li,hi : Integer;
1049 mi : Integer;
1050 ms : Integer;
1051 pb : PByte;
1052 OwnSwapBuf: boolean;
1053 begin
1054 if SwapBuf = nil then
1055 begin
1056 GetMem(SwapBuf, Stride);
1057 OwnSwapBuf := true;
1058 end else
1059 OwnSwapBuf := false;
1060 pb:=PByte(Arr);
1061 li:=idxL;
1062 hi:=idxH;
1063 mi:=(li+hi) div 2;
1064 ls:=li*Stride;
1065 hs:=hi*Stride;
1066 ms:=mi*Stride;
1067 repeat
1068 while CompareFunc( @pb[ls], @pb[ms] ) < 0 do begin
1069 inc(ls, Stride);
1070 inc(li);
1071 end;
1072 while CompareFunc( @pb[ms], @pb[hs] ) < 0 do begin
1073 dec(hs, Stride);
1074 dec(hi);
1075 end;
1076 if ls <= hs then begin
1077 Move(pb[ls], SwapBuf^, Stride);
1078 Move(pb[hs], pb[ls], Stride);
1079 Move(SwapBuf^, pb[hs], Stride);
1080 inc(ls, Stride); inc(li);
1081 dec(hs, Stride); dec(hi);
1082 end;
1083 until ls>hs;
1084 if hi>idxL then AnyQuickSort(Arr, idxL, hi, Stride, CompareFunc, SwapBuf);
1085 if li<idxH then AnyQuickSort(Arr, li, idxH, Stride, CompareFunc, SwapBuf);
1086 if OwnSwapBuf then FreeMem(SwapBuf);
1087 end;
1088
1089 begin
1090 if FDirEntryCount > 0 then
1091 AnyQuickSort(@FDirEntries[0], 0, FDirEntryCount-1, sizeof(TTiffDirEntry), @CompareTagOfDirEntry);
1092 end;
1093
AddEntrynull1094 function TTiffDirectory.AddEntry(const AEntry: TTiffDirEntry): TTiffError;
1095 var
1096 i: Integer;
1097 begin
1098 for i := 0 to FDirEntryCount-1 do
1099 if FDirEntries[i].Tag = AEntry.Tag then
1100 Exit(teDuplicateTag);
1101
1102 if length(FDirEntries) = FDirEntryCount then
1103 setlength(FDirEntries, length(FDirEntries)*2+8);
1104 FDirEntries[FDirEntryCount] := AEntry;
1105 Inc(FDirEntryCount);
1106 Exit(teNone);
1107 end;
1108
LoadChunkListnull1109 function TTiffDirectory.LoadChunkList(AInput: TTiffIO; ATagOffsets, ATagByteCounts: Word;
1110 var AList: TStreamList): TTiffError;
1111 var i, chunkCount: LongWord;
1112 idxOffsets, idxByteCounts: Integer;
1113 offsets, byteCounts: PTiffDirEntry;
1114 chunkOffset, chunkSize: LongWord;
1115 mem: TMemoryStream;
1116 subError: TTiffError;
1117 begin
1118 FreeAndNil(AList);
1119
1120 idxOffsets := IndexOfTag(ATagOffsets);
1121 idxByteCounts := IndexOfTag(ATagByteCounts);
1122
1123 if (idxOffsets = -1) or (idxByteCounts = -1) then Exit(teNone);
1124
1125 offsets := Entry[idxOffsets];
1126 byteCounts := Entry[idxByteCounts];
1127 chunkCount := min(offsets^.ValueCount, byteCounts^.ValueCount);
1128 if chunkCount > 0 then
1129 begin
1130 AList := TStreamList.Create;
1131 for i := 0 to chunkCount-1 do
1132 begin
1133 chunkOffset := offsets^.UnsignedValue[i];
1134 chunkSize := byteCounts^.UnsignedValue[i];
1135 if (chunkOffset < 8) or (chunkOffset > AInput.Size - chunkSize) then
1136 Exit(teInvalidStreamOffset);
1137
1138 AInput.Position := chunkOffset;
1139 mem := TMemoryStream.Create;
1140 subError := AInput.CopyTo(mem, chunkSize);
1141 if subError <> teNone then
1142 begin
1143 mem.Free;
1144 Exit(subError);
1145 end else
1146 AList.Add(mem);
1147 end;
1148 end;
1149 result := teNone;
1150 end;
1151
1152 procedure TTiffDirectory.SaveChunkList(AOutput: TTiffIO; ATagOffsets,
1153 ATagByteCounts: Word; AList: TStreamList);
1154 var
1155 offsets, byteCounts: array of LongWord;
1156 i: Integer;
1157 begin
1158 if not Assigned(AList) or (AList.Count = 0) then
1159 begin
1160 RemoveTag(ATagOffsets);
1161 RemoveTag(ATagByteCounts);
1162 exit;
1163 end;
1164
1165 setlength(offsets, AList.Count);
1166 setlength(byteCounts, AList.Count);
1167
1168 for i := 0 to AList.Count-1 do
1169 begin
1170 {$PUSH}{$RANGECHECKS ON}
1171 offsets[i] := AOutput.Position;
1172 byteCounts[i] := AList[i].Size;
1173 {$POP}
1174 AList[i].Position := 0;
1175 AOutput.CopyFrom(AList[i], AList[i].Size);
1176 end;
1177 GetOrCreateTag(ATagOffsets)^.SetLongArray(offsets);
1178 GetOrCreateTag(ATagByteCounts)^.SetLongArray(byteCounts);
1179 end;
1180
1181 procedure TTiffDirectory.ClearChunkList(var AList: TStreamList);
1182 begin
1183 if Assigned(AList) then
1184 begin
1185 AList.Clear;
1186 FreeAndNil(AList);
1187 end;
1188 end;
1189
TTiffDirectory.LoadFromInputnull1190 function TTiffDirectory.LoadFromInput(AInput: TTiffIO; ADirectoryPos: LongWord; out
1191 ANextDirectoryPos: LongWord): TTiffError;
1192 var
1193 rawEntries: packed array of TTiffRawDirEntry;
1194 subError: TTiffError;
1195 dirCount: Word;
1196 newEntry: TTiffDirEntry;
1197 i: Word;
1198 begin
1199 ANextDirectoryPos := 0;
1200
1201 if (ADirectoryPos < 8) or (ADirectoryPos > AInput.Size - 2) then
1202 exit(teInvalidStreamOffset);
1203
1204 AInput.Position := ADirectoryPos;
1205 subError := AInput.ReadWord(dirCount);
1206 if subError <> teNone then Exit(subError);
1207
1208 setlength(rawEntries, dirCount);
1209 subError := AInput.ReadBuffer(rawEntries[0], dirCount*sizeof(TTiffRawDirEntry));
1210 if subError <> teNone then Exit(subError);
1211
1212 subError := AInput.ReadLong(ANextDirectoryPos);
1213 if subError <> teNone then Exit(subError);
1214
1215 fillchar({%H-}newEntry, sizeof({%H-}newEntry), 0);
1216 if dirCount > 0 then
1217 for i := 0 to dirCount-1 do
1218 begin
1219 subError := newEntry.LoadFromInput(AInput, rawEntries[i]);
1220 if subError = teUnknownValueType then Continue; //skip unknown types
1221 if subError <> teNone then Exit(subError); //stop on other errors
1222
1223 subError := AddEntry(newEntry);
1224 if subError <> teNone then
1225 begin
1226 newEntry.Free;
1227 Exit(subError);
1228 end;
1229 end;
1230
1231 result := LoadChunks(AInput);
1232 end;
1233
1234 procedure TTiffDirectory.SaveToOutput(AOutput: TTiffIO; out
1235 ADirectoryPos: LongWord; out ANextDirectoryPosStreamPos: int64);
1236 var
1237 rawEntries: packed array of TTiffRawDirEntry;
1238 i: Integer;
1239 begin
1240 SaveChunks(AOutput);
1241
1242 SortEntries;
1243 setlength(rawEntries, EntryCount);
1244 for i := 0 to EntryCount-1 do
1245 Entry[i]^.SaveToOutput(AOutput, rawEntries[i]);
1246
1247 if odd(AOutput.Position) then AOutput.WriteByte(0); //word padding
1248
1249 {$PUSH}{$RANGECHECKS ON}
1250 ADirectoryPos:= AOutput.Position;
1251 {$POP}
1252 AOutput.WriteWord(EntryCount);
1253 if EntryCount > 0 then
1254 AOutput.WriteBuffer(rawEntries[0], EntryCount*sizeof(TTiffRawDirEntry));
1255
1256 ANextDirectoryPosStreamPos:= AOutput.Position;
1257 AOutput.WriteLong(0);
1258 end;
1259
ToStringnull1260 function TTiffDirectory.ToString: ansistring;
1261 var
1262 i: Integer;
1263 begin
1264 result := '';
1265 for i := 0 to EntryCount-1 do
1266 with Entry[i]^ do
1267 begin
1268 if i > 0 then result += ','+LineEnding;
1269 result += Name+': '+StringValue;
1270 end;
1271 end;
1272
GetOrCreateTagnull1273 function TTiffDirectory.GetOrCreateTag(ATag: Word): PTiffDirEntry;
1274 var newEntry: TTiffDirEntry;
1275 idx: Integer;
1276 begin
1277 idx := IndexOfTag(ATag);
1278 if idx = -1 then
1279 begin
1280 newEntry.InitNew(ATag);
1281 AddEntry(newEntry);
1282 idx := EntryCount-1;
1283 end;
1284 result := Entry[idx];
1285 end;
1286
TTiffDirectory.RemoveTagnull1287 function TTiffDirectory.RemoveTag(ATag: Word): boolean;
1288 var
1289 idx, i: Integer;
1290 begin
1291 idx := IndexOfTag(ATag);
1292 if idx <> -1 then
1293 begin
1294 FDirEntries[idx].Free;
1295 for i := idx to FDirEntryCount-2 do
1296 FDirEntries[i] := FDirEntries[i+1];
1297 FDirEntries[EntryCount-1].InitNew(0);
1298 dec(FDirEntryCount);
1299 result := true;
1300 end else
1301 result := false;
1302 end;
1303
IndexOfTagnull1304 function TTiffDirectory.IndexOfTag(ATag: Word): integer;
1305 var
1306 i: Integer;
1307 begin
1308 for i := 0 to EntryCount-1 do
1309 if Entry[i]^.Tag = ATag then
1310 begin
1311 result := i;
1312 exit;
1313 end;
1314 result := -1;
1315 end;
1316
1317 { TTiff }
1318
TTiff.GetCountnull1319 function TTiff.GetCount: integer;
1320 begin
1321 result := FImageEntries.Count;
1322 end;
1323
GetEntrynull1324 function TTiff.GetEntry(AIndex: integer): TTiffImageDirectory;
1325 begin
1326 if (AIndex < 0) or (AIndex >= Count) then
1327 raise ERangeError.Create('Index out of bounds');
1328 result := FImageEntries[AIndex];
1329 end;
1330
TTiff.ReadHeadernull1331 function TTiff.ReadHeader(var AInput: TTiffIO; out AFirstImagePos: LongWord): TTiffError;
1332 var ByteOrderMark: array[1..2] of char;
1333 MeaningUniverse: Word;
1334 SubError: TTiffError;
1335 begin
1336 AFirstImagePos:= 0;
1337
1338 SubError := AInput.ReadBuffer({%H-}ByteOrderMark, 2);
1339 if SubError <> teNone then Exit(SubError);
1340 if ByteOrderMark = 'II' then AInput.LittleEndian:= true
1341 else if ByteOrderMark = 'MM' then AInput.LittleEndian:= false
1342 else Exit(teInvalidHeader);
1343
1344 MeaningUniverse := 0;
1345 SubError := AInput.ReadWord(MeaningUniverse);
1346 if SubError <> teNone then exit(SubError);
1347 if MeaningUniverse <> 42 then exit(teInvalidHeader);
1348
1349 SubError := AInput.ReadLong(AFirstImagePos);
1350 if SubError <> teNone then exit(SubError);
1351 if AFirstImagePos < 8 then exit(teInvalidHeader);
1352
1353 Exit(teNone);
1354 end;
1355
1356 procedure TTiff.WriteHeader(var AOutput: TTiffIO; out
1357 AFirstImagePosStreamPos: int64);
1358 var ByteOrderMark: array[1..2] of char;
1359 begin
1360 if AOutput.LittleEndian then
1361 ByteOrderMark := 'II'
1362 else
1363 ByteOrderMark := 'MM';
1364 AOutput.WriteBuffer(ByteOrderMark, 2);
1365 AOutput.WriteWord(42);
1366 AFirstImagePosStreamPos:= AOutput.Position;
1367 AOutput.WriteLong(0);
1368 end;
1369
LoadImageEntriesnull1370 function TTiff.LoadImageEntries(var AInput: TTiffIO; AFirstImagePos: LongWord
1371 ): TTiffError;
1372 type TLongwordList = specialize TFPGList<Longword>;
1373 var
1374 curImagePos, nextImagePos: LongWord;
1375 previousPositions: TLongwordList;
1376 newEntry: TTiffImageDirectory;
1377 i: Integer;
1378 subError: TTiffError;
1379 begin
1380 previousPositions := TLongwordList.Create;
1381 try
1382 curImagePos := AFirstImagePos;
1383 repeat
1384 previousPositions.Add(curImagePos);
1385
1386 newEntry := TTiffImageDirectory.Create;
1387 try
1388 nextImagePos := 0;
1389 subError := newEntry.LoadFromInput(AInput, curImagePos, nextImagePos);
1390 except on ex:exception do
1391 subError := teUnhandledException;
1392 end;
1393 if subError <> teNone then
1394 begin
1395 newEntry.Free;
1396 exit(subError);
1397 end;
1398
1399 FImageEntries.Add(newEntry);
1400
1401 for i := 0 to previousPositions.Count-1 do
1402 if nextImagePos = previousPositions[i] then
1403 exit(teCircularOffset);
1404
1405 curImagePos := nextImagePos;
1406 until nextImagePos = 0;
1407 finally
1408 previousPositions.Free;
1409 end;
1410 result := teNone;
1411 end;
1412
1413 constructor TTiff.Create;
1414 begin
1415 FImageEntries := TTiffImageDirectoryList.Create;
1416 FLittleEndian := false;
1417 end;
1418
1419 procedure TTiff.Clear;
1420 begin
1421 FImageEntries.Clear;
1422 end;
1423
TTiff.LoadFromStreamnull1424 function TTiff.LoadFromStream(AStream: TStream): TTiffError;
1425 var
1426 firstImagePos: LongWord;
1427 subError: TTiffError;
1428 input: TTiffIO;
1429 begin
1430 Clear;
1431
1432 input.Init(AStream, AStream.Position);
1433 subError := ReadHeader(input, firstImagePos);
1434 if subError <> teNone then Exit(subError);
1435 FLittleEndian:= input.LittleEndian;
1436
1437 result := LoadImageEntries(input, firstImagePos);
1438 end;
1439
1440 procedure TTiff.SaveToStream(AStream: TStream);
1441 var indices: array of integer;
1442 i: Integer;
1443 begin
1444 setlength(indices, Count);
1445 for i := 0 to high(indices) do
1446 indices[i] := i;
1447 SaveToStream(AStream, indices);
1448 end;
1449
1450 procedure TTiff.SaveToStream(AStream: TStream; AEntryIndices: array of integer);
1451 var output: TTiffIO;
1452 curImagePosStreamPos, nextImagePosStreamPos, nextStreamPos: int64;
1453 curImagePos: LongWord;
1454 i: Integer;
1455 begin
1456 if length(AEntryIndices) = 0 then
1457 raise exception.Create('File cannot be empty');
1458
1459 output.Init(AStream, AStream.Position);
1460 output.LittleEndian := LittleEndian;
1461
1462 WriteHeader(output, curImagePosStreamPos);
1463 for i := 0 to high(AEntryIndices) do
1464 begin
1465 Entry[AEntryIndices[i]].SaveToOutput(output, curImagePos, nextImagePosStreamPos);
1466
1467 nextStreamPos := output.Position;
1468 output.Position:= curImagePosStreamPos;
1469 output.WriteLong(curImagePos);
1470 output.Position := nextStreamPos;
1471
1472 curImagePosStreamPos := nextImagePosStreamPos;
1473 end;
1474 end;
1475
1476 procedure TTiff.Delete(AIndex: integer);
1477 begin
1478 if (AIndex < 0) or (AIndex >= Count) then
1479 raise ERangeError.Create('Index out of bounds');
1480 FImageEntries.Delete(AIndex);
1481 end;
1482
1483 procedure TTiff.Move(AFromTiff: TTiff; AFromIndex: integer; AToIndex: integer);
1484 var idx: integer;
1485 begin
1486 if (AToIndex < 0) or (AToIndex > Count) then
1487 raise ERangeError.Create('Index out of bounds');
1488
1489 idx := Move(AFromTiff, AFromIndex);
1490 Move(idx, AToIndex);
1491 end;
1492
Movenull1493 function TTiff.Move(AFromTiff: TTiff; AFromIndex: integer): integer;
1494 var
1495 otherEntry: TTiffImageDirectory;
1496 begin
1497 otherEntry := AFromTiff.Entry[AFromIndex];
1498 AFromTiff.FImageEntries.Extract(otherEntry);
1499 result := FImageEntries.Add(otherEntry);
1500 end;
1501
1502 procedure TTiff.Move(AFromIndex, AToIndex: integer);
1503 var fromEntry: TTiffImageDirectory;
1504 begin
1505 if (AFromIndex < 0) or (AFromIndex >= Count) then
1506 raise ERangeError.Create('Index out of bounds');
1507 if (AToIndex < 0) or (AToIndex >= Count) then
1508 raise ERangeError.Create('Index out of bounds');
1509 if AToIndex = AFromIndex then exit;
1510 fromEntry := Entry[AFromIndex];
1511 FImageEntries.Extract(fromEntry);
1512 if AToIndex > AFromIndex then Inc(AToIndex);
1513 FImageEntries.Insert(AToIndex, fromEntry);
1514 end;
1515
1516 destructor TTiff.Destroy;
1517 begin
1518 Clear;
1519 FImageEntries.Free;
1520 inherited Destroy;
1521 end;
1522
TTiff.ToStringnull1523 function TTiff.ToString: ansistring;
1524 var
1525 i: Integer;
1526 begin
1527 Result:='Count: '+IntToStr(Count);
1528 for i := 0 to Count-1 do
1529 result += ','+LineEnding+'Image'+inttostr(i+1)+': {'+Entry[i].ToString+'}';
1530 end;
1531
GetBiggestImagenull1532 function TTiff.GetBiggestImage: TTiffImageDirectory;
1533 var
1534 i: Integer;
1535 begin
1536 if Count = 0 then
1537 begin
1538 result := nil;
1539 exit;
1540 end;
1541 result := Entry[0];
1542 for i := 1 to Count-1 do
1543 if (Entry[i].Width+Entry[i].Height > result.Width+result.Height) or
1544 ((Entry[i].Width+Entry[i].Height = result.Width+result.Height) and
1545 (Entry[i].BitDepth > result.BitDepth)) then
1546 result := Entry[i];
1547 end;
1548
TTiff.IndexOfImagenull1549 function TTiff.IndexOfImage(AImage: TTiffImageDirectory): integer;
1550 var
1551 i: Integer;
1552 begin
1553 for i := 0 to Count-1 do
1554 if Entry[i] = AImage then
1555 begin
1556 result := i;
1557 exit;
1558 end;
1559 result := -1;
1560 end;
1561
1562 end.
1563
1564