source: trunk/Packages/bgrabitmap/bgrareadtiff.pas

Last change on this file was 2, checked in by chronos, 6 years ago
File size: 72.2 KB
Line 
1{
2 This file is part of the Free Pascal run time library.
3 Copyright (c) 2012-2013 by the Free Pascal development team
4
5 Tiff reader for fpImage.
6
7 See the file COPYING.FPC, included in this distribution,
8 for details about the copyright.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************
15
16 Working:
17 Sample bitdepth: 1, 4, 8, 12, 16
18 Color format: black and white, grayscale, RGB, colormap
19 Alpha channel: none, premultiplied, separated
20 Compression: packbits, LZW, deflate
21 Endian-ness: little endian and big endian
22 Orientation: any corner can be (0,0) and x/y can be flipped
23 Planar configuration: 1 (channels together)
24 Fill order: any (for 1 bit per sample images)
25 Skipping thumbnail by reading biggest image
26 Multiple images
27 Strips and tiles
28
29 ToDo:
30 Compression: FAX, Jpeg...
31 Color format: YCbCr, Lab...
32 PlanarConfiguration: 2 (one chunk for each channel)
33 bigtiff 64bit offsets
34 XMP tag 700
35 ICC profile tag 34675
36
37 Not to do:
38 Separate mask (deprecated)
39
40}
41unit BGRAReadTiff;
42
43{$mode objfpc}{$H+}
44
45{$inline on}
46
47interface
48
49uses
50 Math, Classes, SysUtils, ctypes, zinflate, zbase, FPimage, FPTiffCmn,
51 BGRABitmapTypes;
52
53type
54 TBGRAReaderTiff = class;
55
56 TTiffCreateCompatibleImgEvent = procedure(Sender: TBGRAReaderTiff;
57 ImgFileDir: TTiffIFD) of object;
58
59 TTiffCheckIFDOrder = (
60 tcioSmart,
61 tcioAlways,
62 tcioNever
63 );
64
65 { TBGRAReaderTiff }
66
67 TBGRAReaderTiff = class(TFPCustomImageReader)
68 private
69 FCheckIFDOrder: TTiffCheckIFDOrder;
70 FFirstIFDStart: DWord;
71 FOnCreateImage: TTiffCreateCompatibleImgEvent;
72 FReverserEndian: boolean;
73 {$ifdef FPC_Debug_Image}
74 FDebug: boolean;
75 {$endif}
76 FIFDList: TFPList;
77 FReverseEndian: Boolean;
78 fStartPos: int64;
79 s: TStream;
80 function GetImages(Index: integer): TTiffIFD;
81 procedure TiffError(Msg: string);
82 procedure SetStreamPos(p: DWord);
83 function ReadTiffHeader(QuickTest: boolean; out IFDStart: DWord): boolean; // returns IFD: offset to first IFD
84 function ReadIFD(Start: DWord; IFD: TTiffIFD): DWord;// Image File Directory
85 procedure ReadDirectoryEntry(var EntryTag: Word; IFD: TTiffIFD);
86 function ReadEntryUnsigned: DWord;
87 function ReadEntrySigned: Cint32;
88 function ReadEntryRational: TTiffRational;
89 function ReadEntryString: string;
90 function ReadByte: Byte;
91 function ReadWord: Word;
92 function ReadDWord: DWord;
93 procedure ReadValues(StreamPos: DWord;
94 out EntryType: word; out EntryCount: DWord;
95 out Buffer: Pointer; out ByteCount: PtrUInt);
96 procedure ReadShortOrLongValues(StreamPos: DWord;
97 out Buffer: PDWord; out Count: DWord);
98 procedure ReadShortValues(StreamPos: DWord;
99 out Buffer: PWord; out Count: DWord);
100 procedure ReadImageSampleProperties(IFD: TTiffIFD; out AlphaChannel: integer; out PremultipliedAlpha: boolean;
101 out SampleCnt: DWord; out SampleBits: PWord; out SampleBitsPerPixel: DWord;
102 out PaletteCnt: DWord; out PaletteValues: PWord);
103 procedure ReadImgValue(BitCount: Word;
104 var Run: Pointer; var BitPos: Byte; FillOrder: DWord;
105 Predictor: word; var LastValue: word; out Value: Word);
106 function FixEndian(w: Word): Word; inline;
107 function FixEndian(d: DWord): DWord; inline;
108 procedure SetFPImgExtras(CurImg: TFPCustomImage; IFD: TTiffIFD);
109 procedure DecodePackBits(var Buffer: Pointer; var Count: PtrInt);
110 procedure DecodeLZW(var Buffer: Pointer; var Count: PtrInt);
111 procedure DecodeDeflate(var Buffer: Pointer; var Count: PtrInt; ExpectedCount: PtrInt);
112 protected
113 procedure InternalRead(Str: TStream; AnImage: TFPCustomImage); override;
114 function InternalCheck(Str: TStream): boolean; override;
115 procedure DoCreateImage(ImgFileDir: TTiffIFD); virtual;
116 public
117 constructor Create; override;
118 destructor Destroy; override;
119 procedure Clear;
120
121 procedure LoadFromStream(aStream: TStream; AutoClear: boolean = true); //load all images (you need to handle OnCreateImage event and assign ImgFileDir.Img)
122 {$ifdef FPC_Debug_Image}
123 property Debug: boolean read FDebug write FDebug;
124 {$endif}
125 property OnCreateImage: TTiffCreateCompatibleImgEvent read FOnCreateImage
126 write FOnCreateImage;
127 property CheckIFDOrder: TTiffCheckIFDOrder read FCheckIFDOrder write FCheckIFDOrder; //check order of IFD entries or not
128 function FirstImg: TTiffIFD;
129 function GetBiggestImage: TTiffIFD;
130 function ImageCount: integer;
131 property Images[Index: integer]: TTiffIFD read GetImages; default;
132
133 public //advanced
134 ImageList: TFPList; // list of TTiffIFD
135 procedure LoadHeaderFromStream(aStream: TStream);
136 procedure LoadIFDsFromStream; // call LoadHeaderFromStream before
137 procedure LoadImageFromStream(Index: integer); // call LoadIFDsFromStream before
138 procedure LoadImageFromStream(IFD: TTiffIFD); // call LoadIFDsFromStream before
139 procedure ReleaseStream;
140 property StartPos: int64 read fStartPos;
141 property ReverserEndian: boolean read FReverserEndian;
142 property TheStream: TStream read s;
143 property FirstIFDStart: DWord read FFirstIFDStart;
144 end;
145
146procedure DecompressPackBits(Buffer: Pointer; Count: PtrInt;
147 out NewBuffer: Pointer; out NewCount: PtrInt);
148procedure DecompressLZW(Buffer: Pointer; Count: PtrInt;
149 out NewBuffer: PByte; out NewCount: PtrInt);
150function DecompressDeflate(Compressed: PByte; CompressedCount: cardinal;
151 out Decompressed: PByte; var DecompressedCount: cardinal;
152 ErrorMsg: PAnsiString = nil): boolean;
153
154implementation
155
156function CMYKToFPColor(C,M,Y,K: Word): TFPColor;
157var R, G, B : LongWord;
158begin
159 R := $ffff - ((LongWord(C)*($ffff-LongWord(K))) shr 16) - LongWord(K) ;
160 G := $ffff - ((LongWord(M)*($ffff-LongWord(K))) shr 16) - LongWord(K) ;
161 B := $ffff - ((LongWord(Y)*($ffff-LongWord(K))) shr 16) - LongWord(K) ;
162 Result := FPColor(R and $ffff,G and $ffff,B and $ffff);
163end ;
164
165procedure TBGRAReaderTiff.TiffError(Msg: string);
166begin
167 Msg:=Msg+' at position '+IntToStr(s.Position);
168 if fStartPos>0 then
169 Msg:=Msg+' (TiffPosition='+IntToStr(fStartPos)+')';
170 raise Exception.Create(Msg);
171end;
172
173function TBGRAReaderTiff.GetImages(Index: integer): TTiffIFD;
174begin
175 Result:=TTiffIFD(ImageList[Index]);
176end;
177
178procedure TBGRAReaderTiff.ReadImageSampleProperties(IFD: TTiffIFD;
179 out AlphaChannel: integer; out PremultipliedAlpha: boolean;
180 out SampleCnt: DWord; out SampleBits: PWord; out SampleBitsPerPixel: DWord;
181 out PaletteCnt: DWord; out PaletteValues: PWord);
182var
183 BytesPerPixel: Word;
184 i: Integer;
185 ExtraSampleCnt, RegularSampleCnt: DWord;
186 ExtraSamples: PWord;
187begin
188 ReadShortValues(IFD.BitsPerSample, SampleBits, SampleCnt);
189 if SampleCnt<>IFD.SamplesPerPixel then
190 begin
191 ReAllocMem(SampleBits, 0);
192 TiffError('Samples='+IntToStr(SampleCnt)+' <> SamplesPerPixel='+IntToStr(IFD
193 .SamplesPerPixel));
194 end;
195
196 BytesPerPixel:=0;
197 SampleBitsPerPixel:=0;
198 PaletteCnt:= 0;
199 PaletteValues:= nil;
200
201 AlphaChannel:= -1;
202 PremultipliedAlpha:= false;
203 IFD.AlphaBits:= 0;
204
205 //looking for alpha channel in extra samples
206 if IFD.ExtraSamples>0 then
207 ReadShortValues(IFD.ExtraSamples, ExtraSamples, ExtraSampleCnt)
208 else begin
209 ExtraSamples := nil;
210 ExtraSampleCnt:= 0;
211 end;
212
213 if ExtraSampleCnt>=SampleCnt then
214 begin
215 ReAllocMem(SampleBits, 0);
216 ReAllocMem(ExtraSamples, 0);
217 TiffError('Samples='+IntToStr(SampleCnt)+' ExtraSampleCnt='+IntToStr(
218 ExtraSampleCnt));
219 end;
220
221 RegularSampleCnt := SampleCnt - ExtraSampleCnt;
222
223 for i:=0 to ExtraSampleCnt-1 do begin
224 if ExtraSamples[i] in [1, 2] then begin
225 AlphaChannel := RegularSampleCnt+i;
226 PremultipliedAlpha:= ExtraSamples[i]=1;
227 IFD.AlphaBits:=SampleBits[AlphaChannel];
228 end;
229 end;
230
231 ReAllocMem(ExtraSamples, 0); //end of extra samples
232
233 for i:=0 to SampleCnt-1 do begin
234 if SampleBits[i]>16 then
235 TiffError('Samples bigger than 16 bit not supported');
236 if not (SampleBits[i] in [1, 4, 8, 12, 16]) then
237 TiffError('Only samples of 1, 4, 8, 12 and 16 bit are supported');
238 if (i <> 0) and ((SampleBits[i] = 1) xor (SampleBits[0] = 1)) then
239 TiffError('Cannot mix 1 bit samples with other sample sizes');
240 inc(SampleBitsPerPixel, SampleBits[i]);
241 end;
242
243 BytesPerPixel:= SampleBitsPerPixel div 8;
244 IFD.BytesPerPixel:=BytesPerPixel;
245 {$ifdef FPC_Debug_Image}
246 if Debug then
247 writeln('BytesPerPixel=', BytesPerPixel);
248 {$endif}
249
250 case IFD.PhotoMetricInterpretation of
251 0, 1:
252 begin
253 if RegularSampleCnt<>1 then
254 TiffError('gray images expect one sample per pixel, but found '+
255 IntToStr(SampleCnt));
256
257 IFD.GrayBits:=SampleBits[0];
258 end;
259 2:
260 begin
261 if (RegularSampleCnt<>3) and (RegularSampleCnt<>4) then
262 TiffError('rgb(a) images expect three or four samples per pixel, but found '+
263 IntToStr(SampleCnt));
264
265 IFD.RedBits:=SampleBits[0];
266 IFD.GreenBits:=SampleBits[1];
267 IFD.BlueBits:=SampleBits[2];
268 if RegularSampleCnt=4 then begin
269 if (AlphaChannel <> -1) then
270 TiffError('Alpha channel specified twice');
271 AlphaChannel:= 3;
272 PremultipliedAlpha:= false;
273 IFD.AlphaBits:=SampleBits[AlphaChannel];
274 end;
275 end;
276 3:
277 begin
278 if RegularSampleCnt<>1 then
279 TiffError('palette images expect one sample per pixel, but found '+
280 IntToStr(SampleCnt));
281
282 if IFD.ColorMap > 0 then
283 begin
284 ReadShortValues(IFD.ColorMap, PaletteValues, PaletteCnt);
285 if PaletteCnt <> (1 shl SampleBits[0])*3 then
286 begin
287 ReAllocMem(PaletteValues, 0);
288 TiffError('Palette size mismatch');
289 end;
290 end else
291 TiffError('Palette not supplied')
292 end;
293 4:
294 begin
295 if RegularSampleCnt<>1 then
296 TiffError('mask images expect one sample per pixel, but found '+
297 IntToStr(SampleCnt));
298 TiffError('Mask images not handled');
299 end;
300 5:
301 begin
302 if RegularSampleCnt<>4 then
303 TiffError('cmyk images expect four samples per pixel, but found '+
304 IntToStr(SampleCnt));
305
306 IFD.RedBits:=SampleBits[0]; //cyan
307 IFD.GreenBits:=SampleBits[1]; //magenta
308 IFD.BlueBits:=SampleBits[2]; //yellow
309 IFD.GrayBits:=SampleBits[3]; //black
310 end;
311 else
312 TiffError('Photometric interpretation not handled (' + inttostr(IFD.PhotoMetricInterpretation)+')');
313 end;
314end;
315
316procedure TBGRAReaderTiff.SetFPImgExtras(CurImg: TFPCustomImage; IFD: TTiffIFD);
317begin
318 ClearTiffExtras(CurImg);
319 // set Tiff extra attributes
320 CurImg.Extra[TiffPhotoMetric]:=IntToStr(IFD.PhotoMetricInterpretation);
321 //writeln('TBGRAReaderTiff.SetFPImgExtras PhotoMetric=',CurImg.Extra[TiffPhotoMetric]);
322 if IFD.Artist<>'' then
323 CurImg.Extra[TiffArtist]:=IFD.Artist;
324 if IFD.Copyright<>'' then
325 CurImg.Extra[TiffCopyright]:=IFD.Copyright;
326 if IFD.DocumentName<>'' then
327 CurImg.Extra[TiffDocumentName]:=IFD.DocumentName;
328 if IFD.DateAndTime<>'' then
329 CurImg.Extra[TiffDateTime]:=IFD.DateAndTime;
330 if IFD.HostComputer<>'' then
331 CurImg.Extra[TiffHostComputer]:=IFD.HostComputer;
332 if IFD.ImageDescription<>'' then
333 CurImg.Extra[TiffImageDescription]:=IFD.ImageDescription;
334 if IFD.Make_ScannerManufacturer<>'' then
335 CurImg.Extra[TiffMake_ScannerManufacturer]:=IFD.Make_ScannerManufacturer;
336 if IFD.Model_Scanner<>'' then
337 CurImg.Extra[TiffModel_Scanner]:=IFD.Model_Scanner;
338 if IFD.Software<>'' then
339 CurImg.Extra[TiffSoftware]:=IFD.Software;
340 if not (IFD.Orientation in [1..8]) then
341 IFD.Orientation:=1;
342 CurImg.Extra[TiffOrientation]:=IntToStr(IFD.Orientation);
343 if IFD.ResolutionUnit<>0 then
344 CurImg.Extra[TiffResolutionUnit]:=IntToStr(IFD.ResolutionUnit);
345 if (IFD.XResolution.Numerator<>0) or (IFD.XResolution.Denominator<>0) then
346 CurImg.Extra[TiffXResolution]:=TiffRationalToStr(IFD.XResolution);
347 if (IFD.YResolution.Numerator<>0) or (IFD.YResolution.Denominator<>0) then
348 CurImg.Extra[TiffYResolution]:=TiffRationalToStr(IFD.YResolution);
349 CurImg.Extra[TiffRedBits]:=IntToStr(IFD.RedBits);
350 CurImg.Extra[TiffGreenBits]:=IntToStr(IFD.GreenBits);
351 CurImg.Extra[TiffBlueBits]:=IntToStr(IFD.BlueBits);
352 CurImg.Extra[TiffGrayBits]:=IntToStr(IFD.GrayBits);
353 CurImg.Extra[TiffAlphaBits]:=IntToStr(IFD.AlphaBits);
354 if IFD.PageCount>0 then begin
355 CurImg.Extra[TiffPageNumber]:=IntToStr(IFD.PageNumber);
356 CurImg.Extra[TiffPageCount]:=IntToStr(IFD.PageCount);
357 end;
358 if IFD.PageName<>'' then
359 CurImg.Extra[TiffPageName]:=IFD.PageName;
360 if IFD.ImageIsThumbNail then
361 CurImg.Extra[TiffIsThumbnail]:='1';
362 if IFD.ImageIsMask then
363 CurImg.Extra[TiffIsMask]:='1';
364 if IFD.Compression<>TiffCompressionNone then
365 CurImg.Extra[TiffCompression]:=IntToStr(IFD.Compression);
366
367 {$ifdef FPC_Debug_Image}
368 if Debug then
369 WriteTiffExtras('SetFPImgExtras', CurImg);
370 {$endif}
371end;
372
373procedure TBGRAReaderTiff.ReadImgValue(BitCount: Word;
374 var Run: Pointer; var BitPos: Byte; FillOrder: DWord;
375 Predictor: word; var LastValue: word; out Value: Word);
376var
377 BitNumber: byte;
378 Byte1, Byte2: byte;
379begin
380 case BitCount of
381 1:
382 begin
383 if FillOrder = 2 then
384 BitNumber:=BitPos //Leftmost pixel starts with bit 0
385 else
386 BitNumber:=7-BitPos; //Leftmost pixel starts with bit 7
387 Value:=((PCUInt8(Run)^) and (1 shl BitNumber) shr BitNumber);
388 inc(BitPos);
389 if BitPos = 8 then
390 begin
391 BitPos := 0;
392 inc(Run); //next byte when all bits read
393 end;
394 if Predictor = 2 then Value := (LastValue+Value) and 1;
395 LastValue:=Value;
396 if Value > 0 then Value := $ffff;
397 end;
398 4:
399 begin
400 if BitPos = 0 then
401 begin
402 Value := PCUInt8(Run)^ shr 4;
403 BitPos := 4;
404 end
405 else
406 begin
407 Value := PCUInt8(Run)^ and 15;
408 BitPos := 0;
409 Inc(Run);
410 end;
411 if Predictor = 2 then Value := (LastValue+Value) and $f;
412 LastValue:=Value;
413 Value := Value + (value shl 4) + (value shl 8) + (value shl 12);
414 end;
415 8:
416 begin
417 Value:=PCUInt8(Run)^;
418 inc(Run);
419 if Predictor = 2 then Value := (LastValue+Value) and $ff;
420 LastValue:=Value;
421 Value:=Value shl 8+Value;
422 end;
423 12:
424 begin
425 Byte1 := PCUInt8(Run)^;
426 Byte2 := PCUInt8(Run+1)^;
427 if BitPos = 0 then begin
428 Value := (Byte1 shl 4) or (Byte2 shr 4);
429 inc(Run);
430 BitPos := 4;
431 end else begin
432 Value := ((Byte1 and $0F) shl 8) or Byte2;
433 inc(Run, 2);
434 BitPos := 0;
435 end;
436 if Predictor = 2 then Value := (LastValue+Value) and $fff;
437 LastValue:=Value;
438 Value := (Value shl 4) + (Value shr 8);
439 end;
440 16:
441 begin
442 Value:=FixEndian(PCUInt16(Run)^);
443 inc(Run,2);
444 if Predictor = 2 then Value := (LastValue+Value) and $ffff;
445 LastValue:=Value;
446 end;
447 end;
448end;
449
450procedure TBGRAReaderTiff.SetStreamPos(p: DWord);
451var
452 NewPosition: int64;
453begin
454 NewPosition:=Int64(p)+fStartPos;
455 if NewPosition>s.Size then
456 TiffError('Offset outside of stream');
457 s.Position:=NewPosition;
458end;
459
460procedure TBGRAReaderTiff.LoadFromStream(aStream: TStream; AutoClear: boolean);
461var
462 i: Integer;
463 aContinue: Boolean;
464begin
465 if AutoClear then
466 Clear;
467 aContinue:=true;
468 Progress(psStarting, 0, False, Rect(0,0,0,0), '', aContinue);
469 if not aContinue then exit;
470 LoadHeaderFromStream(aStream);
471 LoadIFDsFromStream;
472 for i := 0 to ImageCount-1 do
473 begin
474 Progress(psRunning, (i+1)*100 div (ImageCount+1), False, Rect(0,0,0,0),
475 IntToStr(i+1)+'/'+IntToStr(ImageCount), aContinue);
476 LoadImageFromStream(i);
477 end;
478 Progress(psEnding, 100, False, Rect(0,0,0,0), '', aContinue);
479 ReleaseStream;
480end;
481
482procedure TBGRAReaderTiff.LoadHeaderFromStream(aStream: TStream);
483begin
484 FFirstIFDStart:=0;
485 s:=aStream;
486 fStartPos:=s.Position;
487 ReadTiffHeader(false,FFirstIFDStart);
488end;
489
490procedure TBGRAReaderTiff.LoadIFDsFromStream;
491var
492 i,j: Integer;
493 IFDStart: DWord;
494 IFD: TTiffIFD;
495begin
496 IFDStart:=FirstIFDStart;
497 i:=0;
498 while IFDStart>0 do begin
499 for j := 0 to i-1 do
500 if Images[j].IFDStart = IFDStart then exit; //IFD cycle detected
501
502 if ImageCount=i then
503 begin
504 IFD := TTiffIFD.Create;
505 ImageList.Add(IFD);
506 end else
507 IFD:=Images[i];
508 IFDStart:=ReadIFD(IFDStart, IFD);
509 inc(i);
510 end;
511end;
512
513function TBGRAReaderTiff.FirstImg: TTiffIFD;
514begin
515 Result:=nil;
516 if (ImageList=nil) or (ImageList.Count=0) then exit;
517 Result:=TTiffIFD(ImageList[0]);
518end;
519
520function TBGRAReaderTiff.GetBiggestImage: TTiffIFD;
521var
522 Size: Int64;
523 IFD: TTiffIFD;
524 CurSize: int64;
525 i: Integer;
526begin
527 Result:=nil;
528 Size:=0;
529 for i:=0 to ImageCount-1 do begin
530 IFD:=Images[i];
531 CurSize:=Int64(IFD.ImageWidth)*IFD.ImageHeight;
532 if CurSize<Size then continue;
533 Size:=CurSize;
534 Result:=IFD;
535 end;
536end;
537
538function TBGRAReaderTiff.ImageCount: integer;
539begin
540 Result:=ImageList.Count;
541end;
542
543function TBGRAReaderTiff.ReadTiffHeader(QuickTest: boolean; out IFDStart: DWord): boolean;
544var
545 ByteOrder: String;
546 BigEndian: Boolean;
547 FortyTwo: Word;
548begin
549 Result:=false;
550 // read byte order II low endian, MM big endian
551 ByteOrder:=' ';
552 s.Read(ByteOrder[1],2);
553 //debugln(['TForm1.ReadTiffHeader ',dbgstr(ByteOrder)]);
554 if ByteOrder='II' then
555 BigEndian:=false
556 else if ByteOrder='MM' then
557 BigEndian:=true
558 else if QuickTest then
559 exit
560 else
561 TiffError('expected II or MM');
562 FReverseEndian:={$ifdef FPC_BIG_ENDIAN}not{$endif} BigEndian;
563 {$ifdef FPC_Debug_Image}
564 if Debug then
565 writeln('TBGRAReaderTiff.ReadTiffHeader Endian Big=',BigEndian,' ReverseEndian=',FReverseEndian);
566 {$endif}
567 // read magic number 42
568 FortyTwo:=ReadWord;
569 if FortyTwo<>42 then begin
570 if QuickTest then
571 exit
572 else
573 TiffError('expected 42, because of its deep philosophical impact, but found '+IntToStr(FortyTwo));
574 end;
575 // read offset to first IFD
576 IFDStart:=ReadDWord;
577 //debugln(['TForm1.ReadTiffHeader IFD=',IFD]);
578 Result:=true;
579end;
580
581function TBGRAReaderTiff.ReadIFD(Start: DWord; IFD: TTiffIFD): DWord;
582var
583 Count: Word;
584 i: Integer;
585 EntryTag: Word;
586 p: Int64;
587begin
588 {$ifdef FPC_Debug_Image}
589 if Debug then
590 writeln('ReadIFD Start=',Start);
591 {$endif}
592
593 Result:=0;
594 SetStreamPos(Start);
595 IFD.IFDStart:=Start;
596 Count:=ReadWord;
597 EntryTag:=0;
598 p:=s.Position;
599 for i:=1 to Count do begin
600 ReadDirectoryEntry(EntryTag, IFD);
601 inc(p,12);
602 s.Position:=p;
603 end;
604
605 //fix IFD if it is supposed to use tiles but provide chunks as strips
606 if IFD.TileWidth > 0 then
607 begin
608 if (IFD.TileOffsets=0) and (IFD.StripOffsets <> 0) then
609 begin
610 IFD.TileOffsets := IFD.StripOffsets;
611 IFD.StripOffsets := 0;
612 end;
613 if (IFD.TileByteCounts=0) and (IFD.StripByteCounts <> 0) then
614 begin
615 IFD.TileByteCounts := IFD.StripByteCounts;
616 IFD.StripByteCounts:= 0;
617 end;
618 end else
619 begin
620 //if not specified, the strip is the whole image
621 if IFD.RowsPerStrip = 0 then IFD.RowsPerStrip:= IFD.ImageHeight;
622 end;
623
624 // read start of next IFD
625 IFD.IFDNext:= ReadDWord;
626 Result:= IFD.IFDNext;
627end;
628
629procedure TBGRAReaderTiff.ReadDirectoryEntry(var EntryTag: Word; IFD: TTiffIFD);
630var
631 EntryType: Word;
632 EntryCount: DWord;
633 EntryStart: DWord;
634 NewEntryTag: Word;
635 UValue: DWord;
636 SValue: integer;
637 WordBuffer: PWord;
638 Count: DWord;
639 i: Integer;
640
641 function GetPos: DWord;
642 begin
643 Result:=DWord(s.Position-fStartPos-2)
644 end;
645
646begin
647 NewEntryTag:=ReadWord;
648 if (NewEntryTag<EntryTag) then begin
649 // the TIFF specification insists on ordered entry tags in each IFD
650 // This allows to spot damaged files.
651 // But some programs like 'GraphicConverter' do not order the extension tags
652 // properly.
653 {$ifdef FPC_Debug_Image}
654 if Debug then
655 writeln('WARNING: Tags must be in ascending order: Last='+IntToStr(EntryTag)+' Next='+IntToStr(NewEntryTag));
656 {$endif}
657 case CheckIFDOrder of
658 tcioAlways: TiffError('Tags must be in ascending order: Last='+IntToStr(EntryTag)+' Next='+IntToStr(NewEntryTag));
659 tcioSmart:
660 if NewEntryTag<30000 then
661 TiffError('Tags must be in ascending order: Last='+IntToStr(EntryTag)+' Next='+IntToStr(NewEntryTag));
662 end;
663 end;
664 EntryTag:=NewEntryTag;
665 case EntryTag of
666 254:
667 begin
668 // NewSubFileType
669 UValue:=ReadEntryUnsigned;
670 IFD.ImageIsThumbNail:=UValue and 1<>0;
671 IFD.ImageIsPage:=UValue and 2<>0;
672 IFD.ImageIsMask:=UValue and 4<>0;
673 {$ifdef FPC_Debug_Image}
674 if Debug then
675 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 254: NewSubFileType ThumbNail=',IFD.ImageIsThumbNail,' Page=',IFD.ImageIsPage,' Mask=',IFD.ImageIsMask);
676 {$endif}
677 end;
678 255:
679 begin
680 // SubFileType (deprecated)
681 UValue:=ReadEntryUnsigned;
682 IFD.ImageIsThumbNail:=false;
683 IFD.ImageIsPage:=false;
684 IFD.ImageIsMask:=false;
685 case UValue of
686 1: ;
687 2: IFD.ImageIsThumbNail:=true;
688 3: IFD.ImageIsPage:=true;
689 else
690 TiffError('SubFileType expected, but found '+IntToStr(UValue));
691 end;
692 {$ifdef FPC_Debug_Image}
693 if Debug then
694 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 255: SubFileType ThumbNail=',IFD.ImageIsThumbNail,' Page=',IFD.ImageIsPage,' Mask=',IFD.ImageIsMask);
695 {$endif}
696 end;
697 256:
698 begin
699 // fImageWidth
700 IFD.ImageWidth:=ReadEntryUnsigned;
701 {$ifdef FPC_Debug_Image}
702 if Debug then
703 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 256: ImageWidth=',IFD.ImageWidth);
704 {$endif}
705 end;
706 257:
707 begin
708 // ImageLength according to TIFF spec, here used as imageheight
709 IFD.ImageHeight:=ReadEntryUnsigned;
710 {$ifdef FPC_Debug_Image}
711 if Debug then
712 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 257: ImageHeight=',IFD.ImageHeight);
713 {$endif}
714 end;
715 258:
716 begin
717 // BitsPerSample
718 IFD.BitsPerSample:=GetPos;
719 ReadShortValues(IFD.BitsPerSample,WordBuffer,Count);
720 {$ifdef FPC_Debug_Image}
721 if Debug then begin
722 write('TBGRAReaderTiff.ReadDirectoryEntry Tag 258: BitsPerSample: ');
723 for i:=0 to Count-1 do
724 write(IntToStr(WordBuffer[i]),' ');
725 writeln;
726 end;
727 {$endif}
728 try
729 SetLength(IFD.BitsPerSampleArray,Count);
730 for i:=0 to Count-1 do
731 IFD.BitsPerSampleArray[i]:=WordBuffer[i];
732 finally
733 ReAllocMem(WordBuffer,0);
734 end;
735 end;
736 259:
737 begin
738 // Compression
739 UValue:=ReadEntryUnsigned;
740 case UValue of
741 TiffCompressionNone,
742 TiffCompressionCCITTRLE,
743 TiffCompressionCCITTFAX3,
744 TiffCompressionCCITTFAX4,
745 TiffCompressionLZW,
746 TiffCompressionOldJPEG,
747 TiffCompressionJPEG,
748 TiffCompressionDeflateAdobe,
749 TiffCompressionJBIGBW,
750 TiffCompressionJBIGCol,
751 TiffCompressionNeXT,
752 TiffCompressionCCITTRLEW,
753 TiffCompressionPackBits,
754 TiffCompressionThunderScan,
755 TiffCompressionIT8CTPAD,
756 TiffCompressionIT8LW,
757 TiffCompressionIT8MP,
758 TiffCompressionIT8BL,
759 TiffCompressionPixarFilm,
760 TiffCompressionPixarLog,
761 TiffCompressionDeflateZLib,
762 TiffCompressionDCS,
763 TiffCompressionJBIG,
764 TiffCompressionSGILog,
765 TiffCompressionSGILog24,
766 TiffCompressionJPEG2000: ;
767 else
768 TiffError('expected Compression, but found '+IntToStr(UValue));
769 end;
770 IFD.Compression:=UValue;
771 {$ifdef FPC_Debug_Image}
772 if Debug then
773 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 259: Compression=',IntToStr(IFD.Compression),'=',TiffCompressionName(IFD.Compression));
774 {$endif}
775 end;
776 262:
777 begin
778 // PhotometricInterpretation
779 UValue:=ReadEntryUnsigned;
780 if UValue > 65535 then
781 TiffError('expected PhotometricInterpretation, but found '+IntToStr(UValue));
782 IFD.PhotoMetricInterpretation:=UValue;
783 {$ifdef FPC_Debug_Image}
784 if Debug then begin
785 write('TBGRAReaderTiff.ReadDirectoryEntry Tag 262: PhotometricInterpretation=');
786 case IFD.PhotoMetricInterpretation of
787 0: write('0=bilevel grayscale 0 is white');
788 1: write('1=bilevel grayscale 0 is black');
789 2: write('2=RGB 0,0,0 is black');
790 3: write('3=Palette color');
791 4: write('4=Transparency Mask');
792 5: write('5=CMYK 8bit');
793 end;
794 writeln;
795 end;
796 {$endif}
797 end;
798 263:
799 begin
800 // Tresholding
801 UValue:=ReadEntryUnsigned;
802 case UValue of
803 1: ; // no dithering or halftoning was applied
804 2: ; // an ordered dithering or halftoning was applied
805 3: ; // a randomized dithering or halftoning was applied
806 else
807 TiffError('expected Tresholding, but found '+IntToStr(UValue));
808 end;
809 IFD.Tresholding:=UValue;
810 {$ifdef FPC_Debug_Image}
811 if Debug then
812 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 263: Tresholding=',IFD.Tresholding);
813 {$endif}
814 end;
815 264:
816 begin
817 // CellWidth
818 IFD.CellWidth:=ReadEntryUnsigned;
819 {$ifdef FPC_Debug_Image}
820 if Debug then
821 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 264: CellWidth=',IFD.CellWidth);
822 {$endif}
823 end;
824 265:
825 begin
826 // CellLength
827 IFD.CellLength:=ReadEntryUnsigned;
828 {$ifdef FPC_Debug_Image}
829 if Debug then
830 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 265: CellLength=',IFD.CellLength);
831 {$endif}
832 end;
833 266:
834 begin
835 // FillOrder
836 UValue:=ReadEntryUnsigned;
837 case UValue of
838 1: IFD.FillOrder:=1; // left to right = high to low
839 2: IFD.FillOrder:=2; // left to right = low to high
840 else
841 TiffError('expected FillOrder, but found '+IntToStr(UValue));
842 end;
843 {$ifdef FPC_Debug_Image}
844 if Debug then begin
845 write('TBGRAReaderTiff.ReadDirectoryEntry Tag 266: FillOrder=',IntToStr(IFD.FillOrder),'=');
846 case IFD.FillOrder of
847 1: write('left to right = high to low');
848 2: write('left to right = low to high');
849 end;
850 writeln;
851 end;
852 {$endif}
853 end;
854 269:
855 begin
856 // DocumentName
857 IFD.DocumentName:=ReadEntryString;
858 {$ifdef FPC_Debug_Image}
859 if Debug then
860 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 269: DocumentName=',IFD.DocumentName);
861 {$endif}
862 end;
863 270:
864 begin
865 // ImageDescription
866 IFD.ImageDescription:=ReadEntryString;
867 {$ifdef FPC_Debug_Image}
868 if Debug then
869 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 270: ImageDescription=',IFD.ImageDescription);
870 {$endif}
871 end;
872 271:
873 begin
874 // Make - scanner manufacturer
875 IFD.Make_ScannerManufacturer:=ReadEntryString;
876 {$ifdef FPC_Debug_Image}
877 if Debug then
878 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 271: Make_ScannerManufacturer=',IFD.Make_ScannerManufacturer);
879 {$endif}
880 end;
881 272:
882 begin
883 // Model - scanner model
884 IFD.Model_Scanner:=ReadEntryString;
885 {$ifdef FPC_Debug_Image}
886 if Debug then
887 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 272: Model_Scanner=',IFD.Model_Scanner);
888 {$endif}
889 end;
890 273:
891 begin
892 // StripOffsets (store offset to entity, not the actual contents of the offsets)
893 IFD.StripOffsets:=GetPos; //Store position of entity so we can look up multiple offsets later
894 {$ifdef FPC_Debug_Image}
895 if Debug then
896 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 273: StripOffsets, offset for entry=',IFD.StripOffsets);
897 {$endif}
898 end;
899 274:
900 begin
901 // Orientation
902 UValue:=ReadEntryUnsigned;
903 case UValue of
904 1: ;// 0,0 is left, top
905 2: ;// 0,0 is right, top
906 3: ;// 0,0 is right, bottom
907 4: ;// 0,0 is left, bottom
908 5: ;// 0,0 is top, left (rotated)
909 6: ;// 0,0 is top, right (rotated)
910 7: ;// 0,0 is bottom, right (rotated)
911 8: ;// 0,0 is bottom, left (rotated)
912 else
913 TiffError('expected Orientation, but found '+IntToStr(UValue));
914 end;
915 IFD.Orientation:=UValue;
916 {$ifdef FPC_Debug_Image}
917 if Debug then begin
918 write('TBGRAReaderTiff.ReadDirectoryEntry Tag 274: Orientation=',IntToStr(IFD.Orientation),'=');
919 case IFD.Orientation of
920 1: write('0,0 is left, top');
921 2: write('0,0 is right, top');
922 3: write('0,0 is right, bottom');
923 4: write('0,0 is left, bottom');
924 5: write('0,0 is top, left (rotated)');
925 6: write('0,0 is top, right (rotated)');
926 7: write('0,0 is bottom, right (rotated)');
927 8: write('0,0 is bottom, left (rotated)');
928 end;
929 writeln;
930 end;
931 {$endif}
932 end;
933 277:
934 begin
935 // SamplesPerPixel
936 IFD.SamplesPerPixel:=ReadEntryUnsigned;
937 {$ifdef FPC_Debug_Image}
938 if Debug then
939 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 277: SamplesPerPixel=',IFD.SamplesPerPixel);
940 {$endif}
941 end;
942 278:
943 begin
944 // RowsPerStrip
945 UValue:=ReadEntryUnsigned;
946 if UValue=0 then
947 TiffError('expected RowsPerStrip, but found '+IntToStr(UValue));
948 IFD.RowsPerStrip:=UValue;
949 {$ifdef FPC_Debug_Image}
950 if Debug then
951 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 278: RowsPerStrip=',IFD.RowsPerStrip);
952 {$endif}
953 end;
954 279:
955 begin
956 // StripByteCounts (the number of bytes in each strip).
957 // We're storing the position of the tag, not the various bytecounts themselves
958 IFD.StripByteCounts:=GetPos;
959 {$ifdef FPC_Debug_Image}
960 if Debug then
961 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 279: StripByteCounts, offset for entry=',IFD.StripByteCounts);
962 {$endif}
963 end;
964 280:
965 begin
966 // MinSampleValue
967 {$ifdef FPC_Debug_Image}
968 if Debug then
969 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 280: skipping MinSampleValue');
970 {$endif}
971 end;
972 281:
973 begin
974 // MaxSampleValue
975 {$ifdef FPC_Debug_Image}
976 if Debug then
977 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 281: skipping MaxSampleValue');
978 {$endif}
979 end;
980 282:
981 begin
982 // XResolution
983 IFD.XResolution:=ReadEntryRational;
984 {$ifdef FPC_Debug_Image}
985 try
986 if Debug then
987 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 282: XResolution=',IFD.XResolution.Numerator,'/',IFD.XResolution.Denominator,'=',IFD.XResolution.Numerator/IFD.XResolution.Denominator);
988 except
989 //ignore division by 0
990 end;
991 {$endif}
992 end;
993 283:
994 begin
995 // YResolution
996 IFD.YResolution:=ReadEntryRational;
997 {$ifdef FPC_Debug_Image}
998 try
999 if Debug then
1000 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 283: YResolution=',IFD.YResolution.Numerator,'/',IFD.YResolution.Denominator,'=',IFD.YResolution.Numerator/IFD.YResolution.Denominator);
1001 except
1002 //ignore division by 0
1003 end; {$endif}
1004 end;
1005 284:
1006 begin
1007 // PlanarConfiguration
1008 SValue:=ReadEntrySigned;
1009 case SValue of
1010 TiffPlanarConfigurationChunky: ; // 1
1011 TiffPlanarConfigurationPlanar: ; // 2
1012 else
1013 TiffError('expected PlanarConfiguration, but found '+IntToStr(SValue));
1014 end;
1015 IFD.PlanarConfiguration:=SValue;
1016 {$ifdef FPC_Debug_Image}
1017 if Debug then begin
1018 write('TBGRAReaderTiff.ReadDirectoryEntry Tag 284: PlanarConfiguration=');
1019 case SValue of
1020 TiffPlanarConfigurationChunky: write('chunky format');
1021 TiffPlanarConfigurationPlanar: write('planar format');
1022 end;
1023 writeln;
1024 end;
1025 {$endif}
1026 end;
1027 285:
1028 begin
1029 // PageName
1030 IFD.PageName:=ReadEntryString;
1031 {$ifdef FPC_Debug_Image}
1032 if Debug then
1033 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 285: PageName="'+IFD.PageName+'"');
1034 {$endif}
1035 end;
1036 288:
1037 begin
1038 // FreeOffsets
1039 // The free bytes in a tiff file are described with FreeByteCount and FreeOffsets
1040 {$ifdef FPC_Debug_Image}
1041 if Debug then
1042 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 288: skipping FreeOffsets');
1043 {$endif}
1044 end;
1045 289:
1046 begin
1047 // FreeByteCount
1048 // The free bytes in a tiff file are described with FreeByteCount and FreeOffsets
1049 {$ifdef FPC_Debug_Image}
1050 if Debug then
1051 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 289: skipping FreeByteCount');
1052 {$endif}
1053 end;
1054 290:
1055 begin
1056 // GrayResponseUnit
1057 // precision of GrayResponseCurve
1058 {$ifdef FPC_Debug_Image}
1059 if Debug then
1060 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 290: skipping GrayResponseUnit');
1061 {$endif}
1062 end;
1063 291:
1064 begin
1065 // GrayResponseCurve
1066 // the optical density for each possible pixel value
1067 {$ifdef FPC_Debug_Image}
1068 if Debug then
1069 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 291: skipping GrayResponseCurve');
1070 {$endif}
1071 end;
1072 296:
1073 begin
1074 // fResolutionUnit
1075 UValue:=ReadEntryUnsigned;
1076 case UValue of
1077 1: IFD.ResolutionUnit:=1; // none
1078 2: IFD.ResolutionUnit:=2; // inch
1079 3: IFD.ResolutionUnit:=3; // centimeter
1080 else
1081 TiffError('expected ResolutionUnit, but found '+IntToStr(UValue));
1082 end;
1083 {$ifdef FPC_Debug_Image}
1084 if Debug then begin
1085 write('TBGRAReaderTiff.ReadDirectoryEntry Tag 296: ResolutionUnit=');
1086 case IFD.ResolutionUnit of
1087 1: write('none');
1088 2: write('inch');
1089 3: write('centimeter');
1090 end;
1091 writeln;
1092 end;
1093 {$endif}
1094 end;
1095 297:
1096 begin
1097 // page number (starting at 0) and total number of pages
1098 UValue:=GetPos;
1099 ReadShortValues(UValue,WordBuffer,Count);
1100 try
1101 if Count<>2 then begin
1102 {$ifdef FPC_Debug_Image}
1103 if Debug then begin
1104 write('TBGRAReaderTiff.ReadDirectoryEntry Tag 297: PageNumber/Count: ');
1105 for i:=0 to Count-1 do
1106 write(IntToStr(WordBuffer[i]),' ');
1107 writeln;
1108 end;
1109 {$endif}
1110 TiffError('PageNumber Count=2 expected, but found '+IntToStr(Count));
1111 end;
1112 IFD.PageNumber:=WordBuffer[0];
1113 IFD.PageCount:=WordBuffer[1];
1114 if IFD.PageNumber>=IFD.PageCount then begin
1115 // broken order => repair
1116 UValue:=IFD.PageNumber;
1117 IFD.PageNumber:=IFD.PageCount;
1118 IFD.PageCount:=UValue;
1119 end;
1120 finally
1121 ReAllocMem(WordBuffer,0);
1122 end;
1123 {$ifdef FPC_Debug_Image}
1124 if Debug then begin
1125 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 297: PageNumber=',IFD.PageNumber,'/',IFD.PageCount);
1126 end;
1127 {$endif}
1128 end;
1129 305:
1130 begin
1131 // Software
1132 IFD.Software:=ReadEntryString;
1133 {$ifdef FPC_Debug_Image}
1134 if Debug then
1135 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 305: Software="',IFD.Software,'"');
1136 {$endif}
1137 end;
1138 306:
1139 begin
1140 // DateAndTime
1141 IFD.DateAndTime:=ReadEntryString;
1142 {$ifdef FPC_Debug_Image}
1143 if Debug then
1144 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 306: DateAndTime="',IFD.DateAndTime,'"');
1145 {$endif}
1146 end;
1147 315:
1148 begin
1149 // Artist
1150 IFD.Artist:=ReadEntryString;
1151 {$ifdef FPC_Debug_Image}
1152 if Debug then
1153 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 315: Artist="',IFD.Artist,'"');
1154 {$endif}
1155 end;
1156 316:
1157 begin
1158 // HostComputer
1159 IFD.HostComputer:=ReadEntryString;
1160 {$ifdef FPC_Debug_Image}
1161 if Debug then
1162 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 316: HostComputer="',IFD.HostComputer,'"');
1163 {$endif}
1164 end;
1165 317:
1166 begin
1167 // Predictor
1168 UValue:=word(ReadEntryUnsigned);
1169 case UValue of
1170 1: ;
1171 2: ;
1172 else TiffError('expected Predictor, but found '+IntToStr(UValue));
1173 end;
1174 IFD.Predictor:=UValue;
1175 {$ifdef FPC_Debug_Image}
1176 if Debug then
1177 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 317: Predictor="',IFD.Predictor,'"');
1178 {$endif}
1179 end;
1180 320:
1181 begin
1182 // ColorMap: N = 3*2^BitsPerSample
1183 IFD.ColorMap:=GetPos;
1184 {$ifdef FPC_Debug_Image}
1185 if Debug then
1186 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 320: skipping ColorMap');
1187 {$endif}
1188 end;
1189 322:
1190 begin
1191 // TileWidth
1192 IFD.TileWidth:=ReadEntryUnsigned;
1193 {$ifdef FPC_Debug_Image}
1194 if Debug then
1195 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 322: TileWidth=',IFD.TileWidth);
1196 {$endif}
1197 if IFD.TileWidth=0 then
1198 TiffError('TileWidth=0');
1199 end;
1200 323:
1201 begin
1202 // TileLength = TileHeight
1203 IFD.TileLength:=ReadEntryUnsigned;
1204 {$ifdef FPC_Debug_Image}
1205 if Debug then
1206 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 323: TileLength=',IFD.TileLength);
1207 {$endif}
1208 if IFD.TileLength=0 then
1209 TiffError('TileLength=0');
1210 end;
1211 324:
1212 begin
1213 // TileOffsets
1214 IFD.TileOffsets:=GetPos;
1215 {$ifdef FPC_Debug_Image}
1216 if Debug then
1217 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 324: TileOffsets=',IFD.TileOffsets);
1218 {$endif}
1219 if IFD.TileOffsets=0 then
1220 TiffError('TileOffsets=0');
1221 end;
1222 325:
1223 begin
1224 // TileByteCounts
1225 IFD.TileByteCounts:=GetPos;
1226 {$ifdef FPC_Debug_Image}
1227 if Debug then
1228 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 325: TileByteCounts=',IFD.TileByteCounts);
1229 {$endif}
1230 if IFD.TileByteCounts=0 then
1231 TiffError('TileByteCounts=0');
1232 end;
1233 338:
1234 begin
1235 // ExtraSamples: if SamplesPerPixel is bigger than PhotometricInterpretation
1236 // then ExtraSamples is an array defining the extra samples
1237 // 0=unspecified
1238 // 1=alpha (premultiplied)
1239 // 2=alpha (unassociated)
1240 IFD.ExtraSamples:=GetPos;
1241 {$ifdef FPC_Debug_Image}
1242 if Debug then begin
1243 ReadShortValues(IFD.ExtraSamples,WordBuffer,Count);
1244 write('TBGRAReaderTiff.ReadDirectoryEntry Tag 338: ExtraSamples: ');
1245 for i:=0 to Count-1 do
1246 write(IntToStr(WordBuffer[i]),' ');
1247 writeln;
1248 ReAllocMem(WordBuffer,0);
1249 end;
1250 {$endif}
1251 end;
1252 347:
1253 begin
1254 // ToDo: JPEGTables
1255 {$ifdef FPC_Debug_Image}
1256 if Debug then
1257 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 347: skipping JPEG Tables');
1258 {$endif}
1259 end;
1260 512:
1261 begin
1262 // ToDo: JPEGProc
1263 // short
1264 // 1 = baseline sequential
1265 // 14 = lossless process with Huffman encoding
1266 {$ifdef FPC_Debug_Image}
1267 if Debug then
1268 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 512: skipping JPEGProc');
1269 {$endif}
1270 end;
1271 513:
1272 begin
1273 // ToDo: JPEGInterchangeFormat
1274 // long
1275 // non zero: start of start of image SOI marker
1276 {$ifdef FPC_Debug_Image}
1277 if Debug then
1278 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 513: skipping JPEGInterchangeFormat');
1279 {$endif}
1280 end;
1281 514:
1282 begin
1283 // ToDo: JPEGInterchangeFormatLength
1284 // long
1285 // length in bytes of 513
1286 {$ifdef FPC_Debug_Image}
1287 if Debug then
1288 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 514: skipping JPEGInterchangeFormatLength');
1289 {$endif}
1290 end;
1291 515:
1292 begin
1293 // ToDo: JPEGRestartInterval
1294 // short
1295 {$ifdef FPC_Debug_Image}
1296 if Debug then
1297 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 515: skipping JPEGRestartInterval');
1298 {$endif}
1299 end;
1300 517:
1301 begin
1302 // ToDo: JPEGLosslessPredictor
1303 // short
1304 // Count: SamplesPerPixels
1305 {$ifdef FPC_Debug_Image}
1306 if Debug then
1307 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 517: skipping JPEGLosslessPredictor');
1308 {$endif}
1309 end;
1310 518:
1311 begin
1312 // ToDo: JPEGPointTransforms
1313 // short
1314 // Count: SamplesPerPixels
1315 {$ifdef FPC_Debug_Image}
1316 if Debug then
1317 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 518: skipping JPEGPointTransforms');
1318 {$endif}
1319 end;
1320 519:
1321 begin
1322 // ToDo: JPEGQTables
1323 // long
1324 // Count: SamplesPerPixels
1325 {$ifdef FPC_Debug_Image}
1326 if Debug then
1327 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 519: skipping JPEGQTables');
1328 {$endif}
1329 end;
1330 520:
1331 begin
1332 // ToDo: JPEGDCTables
1333 // long
1334 // Count: SamplesPerPixels
1335 {$ifdef FPC_Debug_Image}
1336 if Debug then
1337 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 520: skipping JPEGDCTables');
1338 {$endif}
1339 end;
1340 521:
1341 begin
1342 // ToDo: JPEGACTables
1343 // long
1344 // Count: SamplesPerPixels
1345 {$ifdef FPC_Debug_Image}
1346 if Debug then
1347 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 521: skipping JPEGACTables');
1348 {$endif}
1349 end;
1350 530:
1351 begin
1352 // ToDo: YCbCrSubSampling alias ChromaSubSampling
1353 {$ifdef FPC_Debug_Image}
1354 if Debug then
1355 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 530: skipping YCbCrSubSampling alias ChromaSubSampling');
1356 {$endif}
1357 end;
1358 700:
1359 begin
1360 // ToDo: XMP
1361 {$ifdef FPC_Debug_Image}
1362 if Debug then
1363 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 700: skipping XMP');
1364 {$endif}
1365 end;
1366 33432:
1367 begin
1368 // Copyright
1369 IFD.Copyright:=ReadEntryString;
1370 {$ifdef FPC_Debug_Image}
1371 if Debug then
1372 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 33432: Copyright="',IFD.Copyright,'"');
1373 {$endif}
1374 end;
1375 34675:
1376 begin
1377 // ToDo: ICC Profile
1378 {$ifdef FPC_Debug_Image}
1379 if Debug then
1380 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag 34675: skipping ICC profile');
1381 {$endif}
1382 end;
1383 else
1384 begin
1385 EntryType:=ReadWord;
1386 EntryCount:=ReadDWord;
1387 EntryStart:=ReadDWord;
1388 if (EntryType=0) and (EntryCount=0) and (EntryStart=0) then ;
1389 {$ifdef FPC_Debug_Image}
1390 if Debug then
1391 writeln('TBGRAReaderTiff.ReadDirectoryEntry Tag=',EntryTag,' Type=',EntryType,' Count=',EntryCount,' ValuesStart=',EntryStart);
1392 {$endif}
1393 end;
1394 end;
1395end;
1396
1397function TBGRAReaderTiff.ReadEntryUnsigned: DWord;
1398var
1399 EntryCount: LongWord;
1400 EntryType: Word;
1401begin
1402 Result:=0;
1403 EntryType:=ReadWord;
1404 EntryCount:=ReadDWord;
1405 if EntryCount<>1 then
1406 TiffError('EntryCount=1 expected, but found '+IntToStr(EntryCount));
1407 //writeln('TBGRAReaderTiff.ReadEntryUnsigned Tag=',EntryTag,' Type=',EntryType,' Count=',EntryCount,' ValuesStart=',EntryStart]);
1408 case EntryType of
1409 1: begin
1410 // byte: 8bit unsigned
1411 Result:=ReadByte;
1412 end;
1413 3: begin
1414 // short: 16bit unsigned
1415 Result:=ReadWord;
1416 end;
1417 4: begin
1418 // long: 32bit unsigned long
1419 Result:=ReadDWord;
1420 end;
1421 else
1422 TiffError('expected single unsigned value, but found type='+IntToStr(EntryType));
1423 end;
1424end;
1425
1426function TBGRAReaderTiff.ReadEntrySigned: Cint32;
1427var
1428 EntryCount: LongWord;
1429 EntryType: Word;
1430begin
1431 Result:=0;
1432 EntryType:=ReadWord;
1433 EntryCount:=ReadDWord;
1434 if EntryCount<>1 then
1435 TiffError('EntryCount+1 expected, but found '+IntToStr(EntryCount));
1436 //writeln('TBGRAReaderTiff.ReadEntrySigned Tag=',EntryTag,' Type=',EntryType,' Count=',EntryCount,' ValuesStart=',EntryStart]);
1437 case EntryType of
1438 1: begin
1439 // byte: 8bit unsigned
1440 Result:=cint8(ReadByte);
1441 end;
1442 3: begin
1443 // short: 16bit unsigned
1444 Result:=cint16(ReadWord);
1445 end;
1446 4: begin
1447 // long: 32bit unsigned long
1448 Result:=cint32(ReadDWord);
1449 end;
1450 6: begin
1451 // sbyte: 8bit signed
1452 Result:=cint8(ReadByte);
1453 end;
1454 8: begin
1455 // sshort: 16bit signed
1456 Result:=cint16(ReadWord);
1457 end;
1458 9: begin
1459 // slong: 32bit signed long
1460 Result:=cint32(ReadDWord);
1461 end;
1462 else
1463 TiffError('expected single signed value, but found type='+IntToStr(EntryType));
1464 end;
1465end;
1466
1467function TBGRAReaderTiff.ReadEntryRational: TTiffRational;
1468var
1469 EntryCount: LongWord;
1470 EntryStart: LongWord;
1471 EntryType: Word;
1472begin
1473 Result:=TiffRational0;
1474 EntryType:=ReadWord;
1475 EntryCount:=ReadDWord;
1476 if EntryCount<>1 then
1477 TiffError('EntryCount+1 expected, but found '+IntToStr(EntryCount));
1478 //writeln('TBGRAReaderTiff.ReadEntryUnsigned Tag=',EntryTag,' Type=',EntryType,' Count=',EntryCount,' ValuesStart=',EntryStart]);
1479 case EntryType of
1480 1: begin
1481 // byte: 8bit unsigned
1482 Result.Numerator:=ReadByte;
1483 end;
1484 3: begin
1485 // short: 16bit unsigned
1486 Result.Numerator:=ReadWord;
1487 end;
1488 4: begin
1489 // long: 32bit unsigned long
1490 Result.Numerator:=ReadDWord;
1491 end;
1492 5: begin
1493 // rational: Two longs: numerator + denominator
1494 // this does not fit into 4 bytes
1495 EntryStart:=ReadDWord;
1496 SetStreamPos(EntryStart);
1497 Result.Numerator:=ReadDWord;
1498 Result.Denominator:=ReadDWord;
1499 end;
1500 else
1501 TiffError('expected rational unsigned value, but found type='+IntToStr(EntryType));
1502 end;
1503end;
1504
1505function TBGRAReaderTiff.ReadEntryString: string;
1506var
1507 EntryType: Word;
1508 EntryCount: LongWord;
1509 EntryStart: LongWord;
1510begin
1511 Result:='';
1512 EntryType:=ReadWord;
1513 if EntryType<>2 then
1514 TiffError('asciiz expected, but found '+IntToStr(EntryType));
1515 EntryCount:=ReadDWord;
1516 SetLength(Result,EntryCount-1);
1517 if EntryCount>4 then begin
1518 // long string -> next 4 DWord is the offset
1519 EntryStart:=ReadDWord;
1520 SetStreamPos(EntryStart);
1521 s.Read(Result[1],EntryCount-1);
1522 end else begin
1523 // short string -> stored directly in the next 4 bytes
1524 if Result<>'' then
1525 s.Read(Result[1],length(Result));
1526 // skip rest of 4 bytes
1527 if length(Result)<4 then
1528 s.Read(EntryStart,4-length(Result));
1529 end;
1530end;
1531
1532function TBGRAReaderTiff.ReadByte: Byte;
1533begin
1534 Result:=s.ReadByte;
1535end;
1536
1537function TBGRAReaderTiff.ReadWord: Word;
1538begin
1539 Result:=FixEndian(s.ReadWord);
1540end;
1541
1542function TBGRAReaderTiff.ReadDWord: DWord;
1543begin
1544 Result:=FixEndian(s.ReadDWord);
1545end;
1546
1547procedure TBGRAReaderTiff.ReadValues(StreamPos: DWord; out EntryType: word; out
1548 EntryCount: DWord; out Buffer: Pointer; out ByteCount: PtrUInt);
1549var
1550 EntryStart: DWord;
1551begin
1552 Buffer:=nil;
1553 ByteCount:=0;
1554 EntryType:=0;
1555 EntryCount:=0;
1556 SetStreamPos(StreamPos);
1557 ReadWord; // skip tag
1558 EntryType:=ReadWord;
1559 EntryCount:=ReadDWord;
1560 if EntryCount=0 then exit;
1561 case EntryType of
1562 1,6,7: ByteCount:=EntryCount; // byte
1563 2: ByteCount:=EntryCount; // asciiz
1564 3,8: ByteCount:=2*EntryCount; // short
1565 4,9: ByteCount:=4*EntryCount; // long
1566 5,10: ByteCount:=8*EntryCount; // rational
1567 11: ByteCount:=4*EntryCount; // single
1568 12: ByteCount:=8*EntryCount; // double
1569 else
1570 TiffError('invalid EntryType '+IntToStr(EntryType));
1571 end;
1572 if ByteCount>4 then begin
1573 EntryStart:=ReadDWord;
1574 SetStreamPos(EntryStart);
1575 end;
1576 GetMem(Buffer,ByteCount);
1577 s.Read(Buffer^,ByteCount);
1578end;
1579
1580procedure TBGRAReaderTiff.ReadShortOrLongValues(StreamPos: DWord; out
1581 Buffer: PDWord; out Count: DWord);
1582var
1583 p: Pointer;
1584 ByteCount: PtrUInt;
1585 EntryType: word;
1586 i: DWord;
1587begin
1588 Buffer:=nil;
1589 Count:=0;
1590 p:=nil;
1591 try
1592 ReadValues(StreamPos,EntryType,Count,p,ByteCount);
1593 if Count=0 then exit;
1594 if EntryType=3 then begin
1595 // short
1596 GetMem(Buffer,SizeOf(DWord)*Count);
1597 for i:=0 to Count-1 do
1598 Buffer[i]:=FixEndian(PWord(p)[i]);
1599 end else if EntryType=4 then begin
1600 // long
1601 Buffer:=p;
1602 p:=nil;
1603 if FReverseEndian then
1604 for i:=0 to Count-1 do
1605 Buffer[i]:=FixEndian(PDWord(Buffer)[i]);
1606 end else
1607 TiffError('only short or long allowed');
1608 finally
1609 if p<>nil then FreeMem(p);
1610 end;
1611end;
1612
1613procedure TBGRAReaderTiff.ReadShortValues(StreamPos: DWord; out Buffer: PWord;
1614 out Count: DWord);
1615var
1616 p: Pointer;
1617 ByteCount: PtrUInt;
1618 EntryType: word;
1619 i: DWord;
1620begin
1621 Buffer:=nil;
1622 Count:=0;
1623 p:=nil;
1624 try
1625 ReadValues(StreamPos,EntryType,Count,p,ByteCount);
1626 //writeln('ReadShortValues ',FReverseEndian,' ',EntryType,' Count=',Count,' ByteCount=',ByteCount);
1627 if Count=0 then exit;
1628 if EntryType=3 then begin
1629 // short
1630 Buffer:=p;
1631 p:=nil;
1632 if FReverseEndian then
1633 for i:=0 to Count-1 do
1634 Buffer[i]:=FixEndian(Buffer[i]);
1635 //for i:=0 to Count-1 do writeln(i,' ',Buffer[i]);
1636 end else
1637 TiffError('only short allowed, but found '+IntToStr(EntryType));
1638 finally
1639 if p<>nil then FreeMem(p);
1640 end;
1641end;
1642
1643procedure TBGRAReaderTiff.LoadImageFromStream(Index: integer);
1644var
1645 IFD: TTiffIFD;
1646begin
1647 {$ifdef FPC_Debug_Image}
1648 if Debug then
1649 writeln('TBGRAReaderTiff.LoadImageFromStream Index=',Index);
1650 {$endif}
1651 IFD:=Images[Index];
1652 LoadImageFromStream(IFD);
1653end;
1654
1655procedure TBGRAReaderTiff.LoadImageFromStream(IFD: TTiffIFD);
1656var
1657 SampleCnt: DWord;
1658 SampleBits: PWord;
1659 ChannelValues, LastChannelValues: array of word;
1660
1661 PaletteCnt,PaletteStride: DWord;
1662 PaletteValues: PWord;
1663
1664 AlphaChannel: integer;
1665 PremultipliedAlpha: boolean;
1666
1667 procedure InitColor;
1668 var Channel: DWord;
1669 begin
1670 SetLength(ChannelValues, SampleCnt);
1671 SetLength(LastChannelValues, SampleCnt);
1672 for Channel := 0 to SampleCnt-1 do
1673 LastChannelValues[Channel] := 0;
1674 end;
1675
1676 function ReadNextColor(var Run: Pointer; var BitPos: byte): TFPColor;
1677 var Channel, PaletteIndex: DWord;
1678 GrayValue: Word;
1679 begin
1680 for Channel := 0 to SampleCnt-1 do
1681 ReadImgValue(SampleBits[Channel], Run,BitPos,IFD.FillOrder,
1682 IFD.Predictor,LastChannelValues[Channel],
1683 ChannelValues[Channel]);
1684
1685 case IFD.PhotoMetricInterpretation of
1686 0,1: // 0:bilevel grayscale 0 is white; 1:0 is black
1687 begin
1688 GrayValue := ChannelValues[0];
1689 if IFD.PhotoMetricInterpretation=0 then
1690 GrayValue:=$ffff-GrayValue;
1691 result:=FPColor(GrayValue,GrayValue,GrayValue);
1692 end;
1693
1694 2: // RGB(A)
1695 result:=FPColor(ChannelValues[0],ChannelValues[1],ChannelValues[2]);
1696
1697 3: //3 Palette/color map indexed
1698 begin
1699 PaletteIndex := ChannelValues[0] shr (16 - SampleBits[0]);
1700 result:= FPColor(PaletteValues[PaletteIndex],PaletteValues[PaletteIndex+PaletteStride],PaletteValues[PaletteIndex+2*PaletteStride]);
1701 end;
1702
1703 //4 Mask/holdout mask (obsolete by TIFF 6.0 specification)
1704
1705 5: // CMYK plus optional alpha
1706 result:=CMYKToFPColor(ChannelValues[0],ChannelValues[1],ChannelValues[2],ChannelValues[3]);
1707
1708 //6: YCBCR: CCIR 601
1709 //8: CIELAB: 1976 CIE L*a*b*
1710 //9: ICCLAB: ICC L*a*b*. Introduced post TIFF rev 6.0 by Adobe TIFF Technote 4
1711 //10: ITULAB: ITU L*a*b*
1712 //32844: LOGL: CIE Log2(L)
1713 //32845: LOGLUV: CIE Log2(L) (u',v')
1714 else
1715 TiffError('PhotometricInterpretation='+IntToStr(IFD.PhotoMetricInterpretation)+' not supported');
1716 end;
1717
1718 if AlphaChannel >= 0 then
1719 begin
1720 result.alpha:= ChannelValues[AlphaChannel];
1721 if PremultipliedAlpha and (result.alpha <> alphaOpaque) and (result.alpha <> 0) then
1722 begin
1723 result.red := (result.red * alphaOpaque + result.alpha div 2) div result.alpha;
1724 result.green := (result.green * alphaOpaque + result.alpha div 2) div result.alpha;
1725 result.blue := (result.blue * alphaOpaque + result.alpha div 2) div result.alpha;
1726 end;
1727 end;
1728 end;
1729
1730var
1731 ChunkOffsets: PDWord;
1732 ChunkByteCounts: PDWord;
1733 Chunk: PByte;
1734 ChunkCount: DWord;
1735 ChunkIndex: Dword;
1736 CurCount: DWord;
1737 CurOffset: DWord;
1738 CurByteCnt: PtrInt;
1739 Run: PByte;
1740 BitPos: Byte;
1741 x, y, cx, cy, dx1,dy1, dx2,dy2, sx: integer;
1742 SampleBitsPerPixel: DWord;
1743 CurFPImg: TFPCustomImage;
1744 aContinue: Boolean;
1745 ExpectedChunkLength: PtrInt;
1746 ChunkType: TTiffChunkType;
1747 TilesAcross, TilesDown: DWord;
1748 ChunkLeft, ChunkTop, ChunkWidth, ChunkHeight: DWord;
1749 ChunkBytesPerLine: DWord;
1750begin
1751 if (IFD.ImageWidth=0) or (IFD.ImageHeight=0) then
1752 exit;
1753
1754 if IFD.PhotoMetricInterpretation=High(IFD.PhotoMetricInterpretation) then
1755 TiffError('missing PhotometricInterpretation');
1756 if IFD.BitsPerSample=0 then
1757 TiffError('missing BitsPerSample');
1758 if IFD.TileWidth>0 then begin
1759 ChunkType:=tctTile;
1760 if IFD.TileLength=0 then
1761 TiffError('missing TileLength');
1762 if IFD.TileOffsets=0 then
1763 TiffError('missing TileOffsets');
1764 if IFD.TileByteCounts=0 then
1765 TiffError('missing TileByteCounts');
1766 end else begin
1767 ChunkType:=tctStrip;
1768 if IFD.RowsPerStrip=0 then
1769 TiffError('missing RowsPerStrip');
1770 if IFD.StripOffsets=0 then
1771 TiffError('missing StripOffsets');
1772 if IFD.StripByteCounts=0 then
1773 TiffError('missing StripByteCounts');
1774 end;
1775
1776 if IFD.PlanarConfiguration > 1 then
1777 TiffError('Planar configuration not handled');
1778
1779 {$ifdef FPC_Debug_Image}
1780 if Debug then
1781 writeln('TBGRAReaderTiff.LoadImageFromStream reading ...');
1782 {$endif}
1783
1784 ChunkOffsets:=nil;
1785 ChunkByteCounts:=nil;
1786 Chunk:=nil;
1787 SampleBits:=nil;
1788 try
1789 // read chunk starts and sizes
1790 if ChunkType=tctTile then begin
1791 TilesAcross:=(IFD.ImageWidth+IFD.TileWidth-1) div IFD.TileWidth;
1792 TilesDown:=(IFD.ImageHeight+IFD.TileLength-1) div IFD.TileLength;
1793 {$ifdef FPC_Debug_Image}
1794 if Debug then
1795 writeln('TBGRAReaderTiff.LoadImageFromStream TilesAcross=',TilesAcross,' TilesDown=',TilesDown);
1796 {$endif}
1797 ChunkCount := TilesAcross * TilesDown;
1798 ReadShortOrLongValues(IFD.TileOffsets,ChunkOffsets,CurCount);
1799 if CurCount<ChunkCount then
1800 TiffError('number of TileCounts is wrong');
1801 ReadShortOrLongValues(IFD.TileByteCounts,ChunkByteCounts,CurCount);
1802 if CurCount<ChunkCount then
1803 TiffError('number of TileByteCounts is wrong');
1804 end else begin //strip
1805 ChunkCount:=((IFD.ImageHeight-1) div IFD.RowsPerStrip)+1;
1806 ReadShortOrLongValues(IFD.StripOffsets,ChunkOffsets,CurCount);
1807 if CurCount<ChunkCount then
1808 TiffError('number of StripCounts is wrong');
1809 ReadShortOrLongValues(IFD.StripByteCounts,ChunkByteCounts,CurCount);
1810 if CurCount<ChunkCount then
1811 TiffError('number of StripByteCounts is wrong');
1812 end;
1813
1814 // read image sample structure
1815 ReadImageSampleProperties(IFD, AlphaChannel, PremultipliedAlpha,
1816 SampleCnt, SampleBits, SampleBitsPerPixel,
1817 PaletteCnt, PaletteValues);
1818
1819 PaletteStride := PaletteCnt div 3;
1820
1821 // create FPimage
1822 DoCreateImage(IFD);
1823 if IFD.Img=nil then
1824 begin
1825 IFD.Img := BGRABitmapFactory.Create;
1826 IFD.FreeImg := true;
1827 end;
1828 CurFPImg:=IFD.Img;
1829 if CurFPImg=nil then exit;
1830
1831 SetFPImgExtras(CurFPImg, IFD);
1832
1833 case IFD.Orientation of
1834 0,1..4: CurFPImg.SetSize(IFD.ImageWidth,IFD.ImageHeight);
1835 5..8: CurFPImg.SetSize(IFD.ImageHeight,IFD.ImageWidth);
1836 end;
1837
1838 {$ifdef FPC_Debug_Image}
1839 if Debug then
1840 writeln('TBGRAReaderTiff.LoadImageFromStream SampleBitsPerPixel=',SampleBitsPerPixel);
1841 {$endif}
1842
1843 // read chunks
1844 for ChunkIndex:=0 to ChunkCount-1 do begin
1845 CurOffset:=ChunkOffsets[ChunkIndex];
1846 CurByteCnt:=ChunkByteCounts[ChunkIndex];
1847 //writeln('TBGRAReaderTiff.LoadImageFromStream CurOffset=',CurOffset,' CurByteCnt=',CurByteCnt);
1848 if CurByteCnt<=0 then continue;
1849 ReAllocMem(Chunk,CurByteCnt);
1850 SetStreamPos(CurOffset);
1851 s.Read(Chunk^,CurByteCnt);
1852
1853 // decompress
1854 if ChunkType=tctTile then
1855 ExpectedChunkLength:=(SampleBitsPerPixel*IFD.TileWidth+7) div 8*IFD.TileLength
1856 else
1857 ExpectedChunkLength:=((SampleBitsPerPixel*IFD.ImageWidth+7) div 8)*IFD.RowsPerStrip;
1858 case IFD.Compression of
1859 TiffCompressionNone: ;
1860 TiffCompressionPackBits: DecodePackBits(Chunk,CurByteCnt);
1861 TiffCompressionLZW: DecodeLZW(Chunk,CurByteCnt);
1862 TiffCompressionDeflateAdobe,
1863 TiffCompressionDeflateZLib: DecodeDeflate(Chunk,CurByteCnt,ExpectedChunkLength);
1864 else
1865 TiffError('compression '+TiffCompressionName(IFD.Compression)+' not supported yet');
1866 end;
1867 if CurByteCnt<=0 then continue;
1868
1869 // compute current chunk area
1870 if ChunkType=tctTile then begin
1871 ChunkLeft:=(ChunkIndex mod TilesAcross)*IFD.TileWidth;
1872 ChunkTop:=(ChunkIndex div TilesAcross)*IFD.TileLength;
1873 ChunkWidth:=Min(IFD.TileWidth,IFD.ImageWidth-ChunkLeft);
1874 ChunkHeight:=Min(IFD.TileLength,IFD.ImageHeight-ChunkTop);
1875 ChunkBytesPerLine:=(SampleBitsPerPixel*ChunkWidth+7) div 8;
1876 ExpectedChunkLength:=ChunkBytesPerLine*ChunkHeight;
1877 if CurByteCnt<ExpectedChunkLength then begin
1878 //writeln('TBGRAReaderTiff.LoadImageFromStream SampleBitsPerPixel=',SampleBitsPerPixel,' IFD.ImageWidth=',IFD.ImageWidth,' IFD.ImageHeight=',IFD.ImageHeight,' y=',y,' IFD.TileWidth=',IFD.TileWidth,' IFD.TileLength=',IFD.TileLength,' ExpectedChunkLength=',ExpectedChunkLength,' CurByteCnt=',CurByteCnt);
1879 TiffError('TBGRAReaderTiff.LoadImageFromStream Tile too short ByteCnt='+IntToStr(CurByteCnt)+' ChunkWidth='+IntToStr(ChunkWidth)+' ChunkHeight='+IntToStr(ChunkHeight)+' expected='+IntToStr(ExpectedChunkLength));
1880 end else if CurByteCnt>ExpectedChunkLength then begin
1881 // boundary tiles have padding
1882 ChunkBytesPerLine:=(SampleBitsPerPixel*IFD.TileWidth+7) div 8;
1883 end;
1884 end else begin //tctStrip
1885 ChunkLeft:=0;
1886 ChunkTop:=IFD.RowsPerStrip*ChunkIndex;
1887 ChunkWidth:=IFD.ImageWidth;
1888 ChunkHeight:=Min(IFD.RowsPerStrip,IFD.ImageHeight-ChunkTop);
1889 ChunkBytesPerLine:=(SampleBitsPerPixel*ChunkWidth+7) div 8;
1890 ExpectedChunkLength:=ChunkBytesPerLine*ChunkHeight;
1891 //writeln('TBGRAReaderTiff.LoadImageFromStream SampleBitsPerPixel=',SampleBitsPerPixel,' IFD.ImageWidth=',IFD.ImageWidth,' IFD.ImageHeight=',IFD.ImageHeight,' y=',y,' IFD.RowsPerStrip=',IFD.RowsPerStrip,' ExpectedChunkLength=',ExpectedChunkLength,' CurByteCnt=',CurByteCnt);
1892 if CurByteCnt<ExpectedChunkLength then
1893 TiffError('TBGRAReaderTiff.LoadImageFromStream Strip too short ByteCnt='+IntToStr(CurByteCnt)+' ChunkWidth='+IntToStr(ChunkWidth)+' ChunkHeight='+IntToStr(ChunkHeight)+' expected='+IntToStr(ExpectedChunkLength));
1894 end;
1895
1896 // progress
1897 aContinue:=true;
1898 Progress(psRunning, 0, false, Rect(0,0,IFD.ImageWidth,ChunkTop), '', aContinue);
1899 if not aContinue then break;
1900
1901 // Orientation
1902 if IFD.Orientation in [1..4] then begin
1903 x:=ChunkLeft; y:=ChunkTop;
1904 dy1 := 0; dx2 := 0;
1905 case IFD.Orientation of
1906 1: begin dx1:=1; dy2:=1; end;// 0,0 is left, top
1907 2: begin x:=IFD.ImageWidth-x-1; dx1:=-1; dy2:=1; end;// 0,0 is right, top
1908 3: begin x:=IFD.ImageWidth-x-1; dx1:=-1; y:=IFD.ImageHeight-y-1; dy2:=-1; end;// 0,0 is right, bottom
1909 4: begin dx1:=1; y:=IFD.ImageHeight-y-1; dy2:=-1; end;// 0,0 is left, bottom
1910 end;
1911 end else begin
1912 // rotated
1913 x:=ChunkTop; y:=ChunkLeft;
1914 dx1 := 0; dy2 := 0;
1915 case IFD.Orientation of
1916 5: begin dy1:=1; dx2:=1; end;// 0,0 is top, left (rotated)
1917 6: begin dy1:=1; x:=IFD.ImageWidth-x-1; dx2:=-1; end;// 0,0 is top, right (rotated)
1918 7: begin y:=IFD.ImageHeight-y-1; dy1:=-1; x:=IFD.ImageHeight-x-1; dx2:=-1; end;// 0,0 is bottom, right (rotated)
1919 8: begin y:=IFD.ImageHeight-y-1; dy1:=-1; dx2:=1; end;// 0,0 is bottom, left (rotated)
1920 end;
1921 end;
1922
1923 //writeln('TBGRAReaderTiff.LoadImageFromStream Chunk ',ChunkIndex,' ChunkLeft=',ChunkLeft,' ChunkTop=',ChunkTop,' IFD.ImageWidth=',IFD.ImageWidth,' IFD.ImageHeight=',IFD.ImageHeight,' ChunkWidth=',ChunkWidth,' ChunkHeight=',ChunkHeight,' PaddingRight=',PaddingRight);
1924 sx:=x;
1925 for cy:=0 to ChunkHeight-1 do begin
1926 //writeln('TBGRAReaderTiff.LoadImageFromStream y=',y);
1927 Run:=Chunk+ChunkBytesPerLine*cy;
1928 BitPos := 0;
1929 InitColor;
1930 x:=sx;
1931
1932 for cx:=0 to ChunkWidth-1 do begin
1933 CurFPImg.Colors[x,y]:= ReadNextColor(Run,BitPos);
1934 // next column
1935 inc(x,dx1);
1936 inc(y,dy1);
1937 end;
1938
1939 // next line
1940 inc(x,dx2);
1941 inc(y,dy2);
1942 end;
1943 // next chunk
1944 end;
1945 finally
1946 ReAllocMem(SampleBits,0);
1947 ReAllocMem(ChunkOffsets,0);
1948 ReAllocMem(ChunkByteCounts,0);
1949 ReAllocMem(Chunk,0);
1950 ReAllocMem(PaletteValues,0);
1951 end;
1952end;
1953
1954procedure TBGRAReaderTiff.ReleaseStream;
1955begin
1956 s := nil;
1957end;
1958
1959function TBGRAReaderTiff.FixEndian(w: Word): Word; inline;
1960begin
1961 Result:=w;
1962 if FReverseEndian then
1963 Result:=((Result and $ff) shl 8) or (Result shr 8);
1964end;
1965
1966function TBGRAReaderTiff.FixEndian(d: DWord): DWord; inline;
1967begin
1968 Result:=d;
1969 if FReverseEndian then
1970 Result:=((Result and $ff) shl 24)
1971 or ((Result and $ff00) shl 8)
1972 or ((Result and $ff0000) shr 8)
1973 or (Result shr 24);
1974end;
1975
1976procedure TBGRAReaderTiff.DecodePackBits(var Buffer: Pointer; var Count: PtrInt);
1977var
1978 NewBuffer: Pointer;
1979 NewCount: PtrInt;
1980begin
1981 DecompressPackBits(Buffer,Count,NewBuffer,NewCount);
1982 FreeMem(Buffer);
1983 Buffer:=NewBuffer;
1984 Count:=NewCount;
1985end;
1986
1987procedure TBGRAReaderTiff.DecodeLZW(var Buffer: Pointer; var Count: PtrInt);
1988var
1989 NewBuffer: Pointer;
1990 NewCount: PtrInt;
1991begin
1992 DecompressLZW(Buffer,Count,NewBuffer,NewCount);
1993 FreeMem(Buffer);
1994 Buffer:=NewBuffer;
1995 Count:=NewCount;
1996end;
1997
1998procedure TBGRAReaderTiff.DecodeDeflate(var Buffer: Pointer; var Count: PtrInt;
1999 ExpectedCount: PtrInt);
2000var
2001 NewBuffer: PByte;
2002 NewCount: cardinal;
2003 ErrorMsg: String;
2004begin
2005 ErrorMsg:='';
2006 NewBuffer:=nil;
2007 try
2008 NewCount:=ExpectedCount;
2009 if not DecompressDeflate(Buffer,Count,NewBuffer,NewCount,@ErrorMsg) then
2010 TiffError(ErrorMsg);
2011 FreeMem(Buffer);
2012 Buffer:=NewBuffer;
2013 Count:=NewCount;
2014 NewBuffer:=nil;
2015 finally
2016 ReAllocMem(NewBuffer,0);
2017 end;
2018end;
2019
2020procedure TBGRAReaderTiff.InternalRead(Str: TStream; AnImage: TFPCustomImage);
2021// read the biggest image
2022var
2023 aContinue: Boolean;
2024 BestIFD: TTiffIFD;
2025begin
2026 Clear;
2027
2028 // read header
2029 aContinue:=true;
2030 Progress(psStarting, 0, False, Rect(0,0,0,0), '', aContinue);
2031 if not aContinue then exit;
2032 LoadHeaderFromStream(Str);
2033 LoadIFDsFromStream;
2034
2035 // find the biggest image
2036 BestIFD := GetBiggestImage;
2037 Progress(psRunning, 25, False, Rect(0,0,0,0), '', aContinue);
2038 if not aContinue then exit;
2039
2040 // read image
2041 if Assigned(BestIFD) then begin
2042 BestIFD.Img := AnImage;
2043 LoadImageFromStream(BestIFD);
2044 end;
2045
2046 // end
2047 Progress(psEnding, 100, False, Rect(0,0,0,0), '', aContinue);
2048end;
2049
2050function TBGRAReaderTiff.InternalCheck(Str: TStream): boolean;
2051var
2052 IFDStart: DWord;
2053begin
2054 try
2055 s:=Str;
2056 fStartPos:=s.Position;
2057 Result:=ReadTiffHeader(true,IFDStart) and (IFDStart<>0);
2058 s.Position:=fStartPos;
2059 except
2060 Result:=false;
2061 end;
2062end;
2063
2064procedure TBGRAReaderTiff.DoCreateImage(ImgFileDir: TTiffIFD);
2065begin
2066 if Assigned(OnCreateImage) then
2067 OnCreateImage(Self,ImgFileDir);
2068end;
2069
2070constructor TBGRAReaderTiff.Create;
2071begin
2072 ImageList:=TFPList.Create;
2073end;
2074
2075destructor TBGRAReaderTiff.Destroy;
2076begin
2077 Clear;
2078 FreeAndNil(ImageList);
2079 inherited Destroy;
2080end;
2081
2082procedure TBGRAReaderTiff.Clear;
2083var
2084 i: Integer;
2085 Img: TTiffIFD;
2086begin
2087 for i:=ImageCount-1 downto 0 do begin
2088 Img:=Images[i];
2089 ImageList.Delete(i);
2090 Img.Free;
2091 end;
2092 FReverseEndian:=false;
2093 FreeAndNil(FIFDList);
2094end;
2095
2096procedure DecompressPackBits(Buffer: Pointer; Count: PtrInt; out
2097 NewBuffer: Pointer; out NewCount: PtrInt);
2098{ Algorithm:
2099 while not got the expected number of bytes
2100 read one byte n
2101 if n in 0..127 copy the next n+1 bytes
2102 else if n in -127..-1 then copy the next byte 1-n times
2103 else continue
2104 end
2105}
2106var
2107 p: Pcint8;
2108 n: cint8;
2109 d: pcint8;
2110 i,j: integer;
2111 EndP: Pcint8;
2112begin
2113 // compute NewCount
2114 NewCount:=0;
2115 NewBuffer:=nil;
2116 if Count=0 then exit;
2117 p:=Pcint8(Buffer);
2118 EndP:=p+Count;
2119 while p<EndP do begin
2120 n:=p^;
2121 case n of
2122 0..127: begin inc(NewCount,n+1); inc(p,n+2); end; // copy the next n+1 bytes
2123 -127..-1: begin inc(NewCount,1-n); inc(p,2); end; // copy the next byte 1-n times
2124 else inc(p); // noop
2125 end;
2126 end;
2127
2128 // decompress
2129 if NewCount=0 then exit;
2130 GetMem(NewBuffer,NewCount);
2131 p:=Pcint8(Buffer);
2132 d:=Pcint8(NewBuffer);
2133 while p<EndP do begin
2134 n:=p^;
2135 case n of
2136 0..127:
2137 begin
2138 // copy the next n+1 bytes
2139 i:=n+1;
2140 inc(NewCount,i);
2141 inc(p);
2142 System.Move(p^,d^,i);
2143 inc(p,i);
2144 inc(d,i);
2145 end;
2146 -127..-1:
2147 begin
2148 // copy the next byte 1-n times
2149 i:=1-n;
2150 inc(NewCount,i);
2151 inc(p);
2152 n:=p^;
2153 for j:=0 to i-1 do
2154 d[j]:=n;
2155 inc(d,i);
2156 inc(p);
2157 end;
2158 else inc(p); // noop
2159 end;
2160 end;
2161end;
2162
2163procedure DecompressLZW(Buffer: Pointer; Count: PtrInt; out NewBuffer: PByte;
2164 out NewCount: PtrInt);
2165type
2166 TLZWString = packed record
2167 Count: integer;
2168 Data: PByte;
2169 ShortData: array[0..3] of byte;
2170 end;
2171const
2172 ClearCode = 256; // clear table, start with 9bit codes
2173 EoiCode = 257; // end of input
2174 NoCode = $7fff;
2175var
2176 NewCapacity: PtrInt;
2177 SrcPos: PtrInt;
2178 CodeBuffer: DWord;
2179 CodeBufferLength: byte;
2180 CurBitLength: byte;
2181 Code: Word;
2182 Table: array[0..4096-258-1] of TLZWString;
2183 TableCount: integer;
2184 OldCode: Word;
2185 BigEndian: boolean;
2186 TableMargin: byte;
2187
2188 procedure Error(const Msg: string);
2189 begin
2190 raise Exception.Create(Msg);
2191 end;
2192
2193 function GetNextCode: Word;
2194 begin
2195 while CurBitLength > CodeBufferLength do
2196 begin
2197 if SrcPos >= Count then
2198 begin
2199 result := EoiCode;
2200 exit;
2201 end;
2202 If BigEndian then
2203 CodeBuffer := (CodeBuffer shl 8) or PByte(Buffer)[SrcPos]
2204 else
2205 CodeBuffer := CodeBuffer or (DWord(PByte(Buffer)[SrcPos]) shl CodeBufferLength);
2206 Inc(SrcPos);
2207 Inc(CodeBufferLength, 8);
2208 end;
2209
2210 if BigEndian then
2211 begin
2212 result := CodeBuffer shr (CodeBufferLength-CurBitLength);
2213 Dec(CodeBufferLength, CurBitLength);
2214 CodeBuffer := CodeBuffer and ((1 shl CodeBufferLength) - 1);
2215 end else
2216 begin
2217 result := CodeBuffer and ((1 shl CurBitLength)-1);
2218 Dec(CodeBufferLength, CurBitLength);
2219 CodeBuffer := CodeBuffer shr CurBitLength;
2220 end;
2221 end;
2222
2223 procedure ClearTable;
2224 var
2225 i: Integer;
2226 begin
2227 for i:=0 to TableCount-1 do
2228 if Table[i].Data <> @Table[i].ShortData then
2229 ReAllocMem(Table[i].Data,0);
2230 TableCount:=0;
2231 end;
2232
2233 procedure InitializeTable;
2234 begin
2235 CurBitLength:=9;
2236 ClearTable;
2237 end;
2238
2239 function IsInTable(Code: word): boolean;
2240 begin
2241 Result:=Code<258+TableCount;
2242 end;
2243
2244 procedure WriteStringFromCode(Code: integer; AddFirstChar: boolean = false);
2245 var
2246 s: TLZWString;
2247 begin
2248 //WriteLn('WriteStringFromCode Code=',Code,' AddFirstChar=',AddFirstChar,' x=',(NewCount div 4) mod IFD.ImageWidth,' y=',(NewCount div 4) div IFD.ImageWidth,' PixelByte=',NewCount mod 4);
2249 if Code<256 then begin
2250 // write byte
2251 s.ShortData[0] := code;
2252 s.Data:=@s.ShortData;
2253 s.Count:=1;
2254 end else if Code>=258 then begin
2255 // write string
2256 if Code-258>=TableCount then
2257 Error('LZW code out of bounds');
2258 s:=Table[Code-258];
2259 end else
2260 Error('LZW code out of bounds');
2261 if NewCount+s.Count+1>NewCapacity then begin
2262 NewCapacity:=NewCapacity*2+8;
2263 ReAllocMem(NewBuffer,NewCapacity);
2264 end;
2265 System.Move(s.Data^,NewBuffer[NewCount],s.Count);
2266 //for i:=0 to s.Count-1 do write(HexStr(NewBuffer[NewCount+i],2)); // debug
2267 inc(NewCount,s.Count);
2268 if AddFirstChar then begin
2269 NewBuffer[NewCount]:=s.Data^;
2270 //write(HexStr(NewBuffer[NewCount],2)); // debug
2271 inc(NewCount);
2272 end;
2273 //writeln(',WriteStringFromCode'); // debug
2274 end;
2275
2276 procedure AddStringToTable(Code, AddFirstCharFromCode: integer);
2277 // add string from code plus first character of string from code as new string
2278 var
2279 s1, s2: TLZWString;
2280 p: PByte;
2281 NewCount: integer;
2282 begin
2283 //WriteLn('AddStringToTable Code=',Code,' FCFCode=',AddFirstCharFromCode,' TableCount=',TableCount);
2284 //check whether can store more codes or not
2285 if TableCount=high(Table)+1 then exit;
2286 // find string 1
2287 if Code<256 then begin
2288 // string is byte
2289 s1.ShortData[0] := code;
2290 s1.Data:=@s1.ShortData;
2291 s1.Count:=1;
2292 end else if Code>=258 then begin
2293 // normal string
2294 if Code-258>=TableCount then
2295 Error('LZW code out of bounds');
2296 s1:=Table[Code-258];
2297 end else
2298 Error('LZW code out of bounds');
2299 // find string 2
2300 if AddFirstCharFromCode<256 then begin
2301 // string is byte
2302 s2.ShortData[0] := AddFirstCharFromCode;
2303 s2.Data:=@s2.ShortData;
2304 s2.Count:=1;
2305 end else begin
2306 // normal string
2307 if AddFirstCharFromCode-258>=TableCount then
2308 Error('LZW code out of bounds');
2309 s2:=Table[AddFirstCharFromCode-258];
2310 end;
2311 // set new table entry
2312 NewCount := s1.Count+1;
2313 Table[TableCount].Count:= NewCount;
2314 if NewCount > 4 then
2315 begin
2316 p:=nil;
2317 GetMem(p,NewCount);
2318 end else
2319 p := @Table[TableCount].ShortData;
2320 Table[TableCount].Data:=p;
2321 System.Move(s1.Data^,p^,s1.Count);
2322 // add first character from string 2
2323 p[s1.Count]:=s2.Data^;
2324 // increase TableCount
2325 inc(TableCount);
2326 case TableCount+258+TableMargin of
2327 512,1024,2048: begin
2328 //check if there is room for a greater code
2329 if (Count-SrcPos) shl 3 + integer(CodeBufferLength) > integer(CurBitLength) then
2330 inc(CurBitLength);
2331 end;
2332 end;
2333 end;
2334
2335begin
2336 NewBuffer:=nil;
2337 NewCount:=0;
2338 if Count=0 then exit;
2339 //WriteLn('DecompressLZW START Count=',Count);
2340 //for SrcPos:=0 to 19 do
2341 // write(HexStr(PByte(Buffer)[SrcPos],2));
2342 //writeln();
2343
2344 NewCapacity:=Count*2;
2345 ReAllocMem(NewBuffer,NewCapacity);
2346
2347 if PByte(Buffer)[0] = $80 then
2348 begin
2349 BigEndian := true; //endian-ness of LZW is not necessarily consistent with the rest of the file
2350 TableMargin := 1; //keep one free code to be able to write EOI code
2351 end else
2352 begin
2353 BigEndian := false;
2354 TableMargin := 0;
2355 end;
2356 SrcPos:=0;
2357 CurBitLength:=9;
2358 CodeBufferLength := 0;
2359 CodeBuffer := 0;
2360 TableCount:=0;
2361 OldCode := NoCode;
2362 try
2363 repeat
2364 Code:=GetNextCode;
2365 //WriteLn('DecompressLZW Code=',Code);
2366 if Code=EoiCode then break;
2367 if Code=ClearCode then begin
2368 InitializeTable;
2369 Code:=GetNextCode;
2370 //WriteLn('DecompressLZW after clear Code=',Code);
2371 if Code=EoiCode then break;
2372 if Code=ClearCode then
2373 Error('LZW code out of bounds');
2374 WriteStringFromCode(Code);
2375 OldCode:=Code;
2376 end else begin
2377 if Code<TableCount+258 then begin
2378 WriteStringFromCode(Code);
2379 if OldCode <> NoCode then
2380 AddStringToTable(OldCode,Code);
2381 OldCode:=Code;
2382 end else if (Code=TableCount+258) and (OldCode <> NoCode) then begin
2383 WriteStringFromCode(OldCode,true);
2384 AddStringToTable(OldCode,OldCode);
2385 OldCode:=Code;
2386 end else
2387 Error('LZW code out of bounds');
2388 end;
2389 until false;
2390 finally
2391 ClearTable;
2392 end;
2393
2394 ReAllocMem(NewBuffer,NewCount);
2395end;
2396
2397function DecompressDeflate(Compressed: PByte; CompressedCount: cardinal;
2398 out Decompressed: PByte; var DecompressedCount: cardinal;
2399 ErrorMsg: PAnsiString = nil): boolean;
2400var
2401 stream : z_stream;
2402 err : integer;
2403begin
2404 Result:=false;
2405
2406 //writeln('DecompressDeflate START');
2407 Decompressed:=nil;
2408 if CompressedCount=0 then begin
2409 DecompressedCount:=0;
2410 exit;
2411 end;
2412
2413 err := inflateInit(stream{%H-});
2414 if err <> Z_OK then begin
2415 if ErrorMsg<>nil then
2416 ErrorMsg^:='inflateInit failed';
2417 exit;
2418 end;
2419
2420 // set input = compressed data
2421 stream.avail_in := CompressedCount;
2422 stream.next_in := Compressed;
2423
2424 // set output = decompressed data
2425 if DecompressedCount=0 then
2426 DecompressedCount:=CompressedCount;
2427 Getmem(Decompressed,DecompressedCount);
2428 stream.avail_out := DecompressedCount;
2429 stream.next_out := Decompressed;
2430
2431 // Finish the stream
2432 while TRUE do begin
2433 //writeln('run: total_in=',stream.total_in,' avail_in=',stream.avail_in,' total_out=',stream.total_out,' avail_out=',stream.avail_out);
2434 if (stream.avail_out=0) then begin
2435 // need more space
2436 if DecompressedCount<128 then
2437 DecompressedCount:=DecompressedCount+128
2438 else if DecompressedCount>High(DecompressedCount)-1024 then begin
2439 if ErrorMsg<>nil then
2440 ErrorMsg^:='inflate decompression failed, because not enough space';
2441 exit;
2442 end else
2443 DecompressedCount:=DecompressedCount*2;
2444 ReAllocMem(Decompressed,DecompressedCount);
2445 stream.next_out:=Decompressed+stream.total_out;
2446 stream.avail_out:=DecompressedCount-stream.total_out;
2447 end;
2448 err := inflate(stream, Z_NO_FLUSH);
2449 if err = Z_STREAM_END then
2450 break;
2451 if err<>Z_OK then begin
2452 if ErrorMsg<>nil then
2453 ErrorMsg^:='inflate finish failed';
2454 exit;
2455 end;
2456 end;
2457
2458 //writeln('decompressed: total_in=',stream.total_in,' total_out=',stream.total_out);
2459 DecompressedCount:=stream.total_out;
2460 ReAllocMem(Decompressed,DecompressedCount);
2461
2462 err := inflateEnd(stream);
2463 if err<>Z_OK then begin
2464 if ErrorMsg<>nil then
2465 ErrorMsg^:='inflateEnd failed';
2466 exit;
2467 end;
2468 Result:=true;
2469end;
2470
2471initialization
2472 DefaultBGRAImageReader[ifTiff] := TBGRAReaderTiff;
2473
2474end.
2475
Note: See TracBrowser for help on using the repository browser.