View Issue Details

IDProjectCategoryView StatusLast Update
0035586FPCFCLpublic2019-05-15 16:34
ReporterKnutAssigned ToMichael Van Canneyt 
PrioritynormalSeverityminorReproducibilityalways
Status assignedResolutionopen 
Product Version3.0.4Product BuildWinX64 
Target VersionFixed in Version 
Summary0035586: FPC can't read it's own TIFF-Files generated with fpWriteTIFF
DescriptionWhen writing a TIFF with FPWriteTIFF and re-reading the TIFF with FPReadTIFF it raises an exception that the Tags are not in Order.
FPWriteTIFF needs to sort the FPEntry-Lists by Tag-Value first before Writing the TIFF to Disk.

I attached my solution to this bug.
Steps To ReproduceLoad an image, assign it to a fpWriteTIFF-Object then write it to Disk. Try to reread this file with a fpReadObject.
TagsNo tags attached.
Fixed in Revision
FPCOldBugId
FPCTarget-
Attached Files
  • fpwritetiff.pas (27,283 bytes)
  • fpwritetiff.patch (2,463 bytes)
    --- release_3_0_4_rc1\fpcsrc\packages\fcl-image\src\fpwritetiff.pas	Sat Jul 16 12:05:26 2016
    +++ fpwritetiff.pas	Wed May 15 15:37:14 2019
    @@ -82,6 +82,7 @@
         fStream: TStream;
         fPosition: DWord;
         procedure ClearEntries;
    +    procedure SortEntries;
         procedure WriteTiff;
         procedure WriteHeader;
         procedure WriteIFDs;
    @@ -257,6 +258,29 @@
       WriteDWord(8);
     end;
     
    +procedure TFPWriterTiff.SortEntries;
    +var
    +  i, j: Integer;
    +  Entry: TTiffWriterEntry;
    +  List: TFPList;
    +begin
    +  // Sort Entries by Tag Value Ascending
    +  for i:= 0 to FEntries.Count-1 do begin
    +    List := TFPList(FEntries[i]);
    +    j := 0;
    +    repeat
    +        if TTiffWriterEntry(List[j]).Tag > TTiffWriterEntry(List[j+1]).Tag then begin
    +          Entry := TTiffWriterEntry(List[j+1]);
    +          List[j] := List[j+1];
    +          List[j+1] := Entry;
    +          j := 0;
    +        end
    +        else
    +            j := j+1;
    +    until j >= List.Count-2;
    +  end;
    +end;
    +
     procedure TFPWriterTiff.WriteIFDs;
     var
       i: Integer;
    @@ -265,6 +289,8 @@
       Entry: TTiffWriterEntry;
       NextIFDPos: DWord;
     begin
    +  // Sort the Entries before writing!
    +  SortEntries;
       for i:=0 to FEntries.Count-1 do begin
         List:=TFPList(FEntries[i]);
         // write count
    @@ -427,7 +453,7 @@
             SamplesPerPixel:=3;
           end;
         end;
    -    AlphaBits:=StrToIntDef(Img.Extra[TiffAlphaBits],8);
    +    AlphaBits:=StrToIntDef(Img.Extra[TiffAlphaBits],0); // Not 8!
         if AlphaBits>0 then begin
           BitsPerSample[SamplesPerPixel]:=AlphaBits;
           inc(SamplesPerPixel);
    @@ -553,7 +579,8 @@
             TilesDown:=(OrientedHeight+IFD.TileLength{%H-}-1) div IFD.TileLength;
             ChunkCount:=TilesAcross*TilesDown;
             {$IFDEF FPC_Debug_Image}
    -        writeln('TFPWriterTiff.AddImage BitsPerPixel=',BitsPerPixel,' OrientedWidth=',OrientedWidth,' OrientedHeight=',OrientedHeight,' TileWidth=',IFD.TileWidth,' TileLength=',IFD.TileLength,' TilesAcross=',TilesAcross,' TilesDown=',TilesDown,' ChunkCount=',ChunkCount);
    +        writeln('TFPWriterTiff.AddImage BitsPerPixel=',BitsPerPixel,' OrientedWidth=',OrientedWidth,' OrientedHeight=',OrientedHeight,' TileWidth=',IFD.TileWidth,' TileLength=',IFD.TileLength,' TilesAcross=',TilesAcross,' TilesDown=',TilesDown,' ChunkCoun
    +t=',ChunkCount);
             {$ENDIF}
           end else begin
             ChunkCount:=(OrientedHeight+IFD.RowsPerStrip{%H-}-1) div IFD.RowsPerStrip;
    
    fpwritetiff.patch (2,463 bytes)

Activities

Knut

2019-05-15 15:19

reporter  

fpwritetiff.pas (27,283 bytes)

J. Gareth Moreton

2019-05-15 15:22

developer   ~0116207

(Fixed typo in title - it said "can" instead of "can't")

Marco van de Voort

2019-05-15 15:55

manager   ~0116208

Changed file to patch.

fpwritetiff.patch (2,463 bytes)
--- release_3_0_4_rc1\fpcsrc\packages\fcl-image\src\fpwritetiff.pas	Sat Jul 16 12:05:26 2016
+++ fpwritetiff.pas	Wed May 15 15:37:14 2019
@@ -82,6 +82,7 @@
     fStream: TStream;
     fPosition: DWord;
     procedure ClearEntries;
+    procedure SortEntries;
     procedure WriteTiff;
     procedure WriteHeader;
     procedure WriteIFDs;
@@ -257,6 +258,29 @@
   WriteDWord(8);
 end;
 
+procedure TFPWriterTiff.SortEntries;
+var
+  i, j: Integer;
+  Entry: TTiffWriterEntry;
+  List: TFPList;
+begin
+  // Sort Entries by Tag Value Ascending
+  for i:= 0 to FEntries.Count-1 do begin
+    List := TFPList(FEntries[i]);
+    j := 0;
+    repeat
+        if TTiffWriterEntry(List[j]).Tag > TTiffWriterEntry(List[j+1]).Tag then begin
+          Entry := TTiffWriterEntry(List[j+1]);
+          List[j] := List[j+1];
+          List[j+1] := Entry;
+          j := 0;
+        end
+        else
+            j := j+1;
+    until j >= List.Count-2;
+  end;
+end;
+
 procedure TFPWriterTiff.WriteIFDs;
 var
   i: Integer;
@@ -265,6 +289,8 @@
   Entry: TTiffWriterEntry;
   NextIFDPos: DWord;
 begin
+  // Sort the Entries before writing!
+  SortEntries;
   for i:=0 to FEntries.Count-1 do begin
     List:=TFPList(FEntries[i]);
     // write count
@@ -427,7 +453,7 @@
         SamplesPerPixel:=3;
       end;
     end;
-    AlphaBits:=StrToIntDef(Img.Extra[TiffAlphaBits],8);
+    AlphaBits:=StrToIntDef(Img.Extra[TiffAlphaBits],0); // Not 8!
     if AlphaBits>0 then begin
       BitsPerSample[SamplesPerPixel]:=AlphaBits;
       inc(SamplesPerPixel);
@@ -553,7 +579,8 @@
         TilesDown:=(OrientedHeight+IFD.TileLength{%H-}-1) div IFD.TileLength;
         ChunkCount:=TilesAcross*TilesDown;
         {$IFDEF FPC_Debug_Image}
-        writeln('TFPWriterTiff.AddImage BitsPerPixel=',BitsPerPixel,' OrientedWidth=',OrientedWidth,' OrientedHeight=',OrientedHeight,' TileWidth=',IFD.TileWidth,' TileLength=',IFD.TileLength,' TilesAcross=',TilesAcross,' TilesDown=',TilesDown,' ChunkCount=',ChunkCount);
+        writeln('TFPWriterTiff.AddImage BitsPerPixel=',BitsPerPixel,' OrientedWidth=',OrientedWidth,' OrientedHeight=',OrientedHeight,' TileWidth=',IFD.TileWidth,' TileLength=',IFD.TileLength,' TilesAcross=',TilesAcross,' TilesDown=',TilesDown,' ChunkCoun
+t=',ChunkCount);
         {$ENDIF}
       end else begin
         ChunkCount:=(OrientedHeight+IFD.RowsPerStrip{%H-}-1) div IFD.RowsPerStrip;
fpwritetiff.patch (2,463 bytes)

Issue History

Date Modified Username Field Change
2019-05-15 15:19 Knut New Issue
2019-05-15 15:19 Knut File Added: fpwritetiff.pas
2019-05-15 15:22 J. Gareth Moreton Summary FPC can read it's own TIFF-Files generated with fpWriteTIFF => FPC can't read it's own TIFF-Files generated with fpWriteTIFF
2019-05-15 15:22 J. Gareth Moreton FPCTarget => -
2019-05-15 15:22 J. Gareth Moreton Note Added: 0116207
2019-05-15 15:55 Marco van de Voort File Added: fpwritetiff.patch
2019-05-15 15:55 Marco van de Voort Note Added: 0116208
2019-05-15 16:34 Michael Van Canneyt Assigned To => Michael Van Canneyt
2019-05-15 16:34 Michael Van Canneyt Status new => assigned