fcl-image : Resolution support on Reader/Writer

(cherry picked from commit bc155009996c7660aaaeece78faefb00ec6e06d9)

packages/fcl-image/src/fpimage.inc

@@ -398,6 +398,48 @@ begin
   result := GetInternalColor(x,y);
 end;
 
+procedure TFPCustomImage.SetResolutionUnit(AResolutionUnit: TResolutionUnit);
+begin
+  if (AResolutionUnit<>FResolutionUnit) then
+  begin
+    Case AResolutionUnit of
+    ruPixelsPerInch : if (FResolutionUnit=ruPixelsPerCentimeter) then //Old Resolution is in Cm
+             begin
+               FResolutionX :=FResolutionX*2.54;
+               FResolutionY :=FResolutionY*2.54;
+             end;
+    ruPixelsPerCentimeter: if (FResolutionUnit=ruPixelsPerInch) then //Old Resolution is in Inch
+                  begin
+                    FResolutionX :=FResolutionX/2.54;
+                    FResolutionY :=FResolutionY/2.54;
+                  end;
+    end;
+    FResolutionUnit :=AResolutionUnit;
+  end;
+end;
+
+function TFPCustomImage.GetResolutionWidth: Single;
+begin
+  if (FResolutionUnit=ruNone)
+  then Result :=FWidth
+  else begin
+         Result :=0;
+         if (FResolutionX<>0)
+         then Result :=FWidth/FResolutionX;
+       end;
+end;
+
+function TFPCustomImage.GetResolutionHeight: Single;
+begin
+  if (FResolutionUnit=ruNone)
+  then Result :=FHeight
+  else begin
+         Result :=0;
+         if (FResolutionY<>0)
+         then Result :=FHeight/FResolutionY;
+       end;
+end;
+
 procedure TFPCustomImage.SetInternalColor (x,y:integer; const Value:TFPColor);
 var i : integer;
 begin
@@ -469,6 +511,11 @@ begin
   If Source is TFPCustomImage then
     begin
     Src:=TFPCustomImage(Source);
+
+    // Copy Resolution info
+    ResolutionUnit :=Src.ResolutionUnit;
+    ResolutionX :=Src.ResolutionX;
+    ResolutionY :=Src.ResolutionY;
     // Copy extra info
     FExtra.Assign(Src.Fextra);
     // Copy palette if needed.

packages/fcl-image/src/fpimage.pp

@@ -93,6 +93,8 @@ type
       property Capacity : integer read FCapacity write SetCapacity;
   end;
 
+  TResolutionUnit = (ruNone, ruPixelsPerInch, ruPixelsPerCentimeter);
+
   TFPCustomImage = class(TPersistent)
     private
       FOnProgress : TFPImgProgressEvent;
@@ -115,6 +117,15 @@ type
       function GetPixel (x,y:integer) : integer;
       function GetUsePalette : boolean;
     protected
+      //Resolution
+      FResolutionUnit: TResolutionUnit;
+      FResolutionX,
+      FResolutionY: Single;
+
+      procedure SetResolutionUnit(AResolutionUnit: TResolutionUnit);
+      function GetResolutionWidth: Single; virtual;
+      function GetResolutionHeight: Single; virtual;
+
       // Procedures to store the data. Implemented in descendants
       procedure SetInternalColor (x,y:integer; const Value:TFPColor); virtual;
       function GetInternalColor (x,y:integer) : TFPColor; virtual;
@@ -149,6 +160,12 @@ type
       property  Height : integer read FHeight write SetHeight;
       property  Width : integer read FWidth write SetWidth;
       property  Colors [x,y:integer] : TFPColor read GetColor write SetColor; default;
+      //Resolution
+      property ResolutionUnit: TResolutionUnit read FResolutionUnit write SetResolutionUnit;
+      property ResolutionX: Single read FResolutionX write FResolutionX;
+      property ResolutionY: Single read FResolutionY write FResolutionY;
+      property ResolutionWidth: Single read GetResolutionWidth;
+      property ResolutionHeight: Single read GetResolutionHeight;
       // Use of palette for colors
       property  UsePalette : boolean read GetUsePalette write SetUsePalette;
       property  Palette : TFPPalette read FPalette;

packages/fcl-image/src/fpreadbmp.pp

@@ -18,6 +18,9 @@
    - If we have bpp <= 8 make an indexed image instead of converting it to RGB
    - Support for RLE4 and RLE8 decoding
    - Support for top-down bitmaps
+
+  2023-07  - Massimo Magnano
+           - added Resolution support
 }
 
 {$mode objfpc}
@@ -289,6 +292,10 @@ begin
     end;
     Img.SetSize(BFI.Width,BFI.Height);
 
+    Img.ResolutionUnit:=ruPixelsPerCentimeter;
+    Img.ResolutionX :=BFI.XPelsPerMeter/100;
+    Img.ResolutionY :=BFI.YPelsPerMeter/100;
+
     percent:=0;
     percentinterval:=(Img.Height*4) div 100;
     if percentinterval=0 then percentinterval:=$FFFFFFFF;

packages/fcl-image/src/fpreadjpeg.pas

@@ -19,6 +19,7 @@
 
     2023-07  - Massimo Magnano
              - procedure inside InternalRead moved to protected methods (virtual)
+             - added Resolution support
 }
 unit FPReadJPEG;
 
@@ -92,6 +93,10 @@ type
     property MinHeight:integer read FMinHeight write FMinHeight;
   end;
 
+
+function density_unitToResolutionUnit(Adensity_unit: UINT8): TResolutionUnit;
+function ResolutionUnitTodensity_unit(AResolutionUnit: TResolutionUnit): UINT8;
+
 implementation
 
 procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
@@ -164,6 +169,24 @@ begin
   // ToDo
 end;
 
+function density_unitToResolutionUnit(Adensity_unit: UINT8): TResolutionUnit;
+begin
+  Case Adensity_unit of
+  1: Result :=ruPixelsPerInch;
+  2: Result :=ruPixelsPerCentimeter;
+  else Result :=ruNone;
+  end;
+end;
+
+function ResolutionUnitTodensity_unit(AResolutionUnit: TResolutionUnit): UINT8;
+begin
+  Case AResolutionUnit of
+  ruPixelsPerInch: Result :=1;
+  ruPixelsPerCentimeter: Result :=2;
+  else Result :=0;
+  end;
+end;
+
 { TFPReaderJPEG }
 
 procedure TFPReaderJPEG.SetSmoothing(const AValue: boolean);
@@ -207,6 +230,10 @@ begin
 
   FGrayscale := FInfo.jpeg_color_space = JCS_GRAYSCALE;
   FProgressiveEncoding := jpeg_has_multiple_scans(@FInfo);
+
+  Img.ResolutionUnit:=density_unitToResolutionUnit(CompressInfo.density_unit);
+  Img.ResolutionX :=CompressInfo.X_density;
+  Img.ResolutionY :=CompressInfo.Y_density;
 end;
 
 procedure TFPReaderJPEG.ReadPixels(Str: TStream; Img: TFPCustomImage);

packages/fcl-image/src/fpreadpcx.pas

@@ -15,6 +15,9 @@
   Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 
   Load all format compressed or not
+
+  2023-07  - Massimo Magnano
+           - added Resolution support
 }
 
 unit FPReadPCX;
@@ -42,7 +45,7 @@ type
     procedure CreateBWPalette(Img: TFPCustomImage);
     procedure CreatePalette16(Img: TFPCustomImage);
     procedure ReadPalette(Stream: TStream; Img: TFPCustomImage);
-    procedure AnalyzeHeader(Img: TFPCustomImage);
+    procedure AnalyzeHeader(Img: TFPCustomImage); virtual;
     function InternalCheck(Stream: TStream): boolean; override;
     procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
     procedure ReadScanLine(Row: integer; Stream: TStream); virtual;
@@ -140,6 +143,11 @@ begin
     FCompressed   := Encoding = 1;
     Img.Width     := XMax - XMin + 1;
     Img.Height    := YMax - YMin + 1;
+
+    Img.ResolutionUnit:=ruPixelsPerInch;
+    Img.ResolutionX :=HRes;
+    Img.ResolutionY :=VRes;
+
     FLineSize     := (BytesPerLine * ColorPlanes);
     GetMem(FScanLine, FLineSize);
   end;

packages/fcl-image/src/fpreadpng.pp

@@ -25,6 +25,12 @@ Type
   TSetPixelProc = procedure (x,y:integer; CD : TColordata) of object;
   TConvertColorProc = function (CD:TColorData) : TFPColor of object;
 
+  TPNGPhysicalDimensions = packed record
+    X_Pixels, Y_Pixels :DWord;
+    Unit_Specifier :Byte;
+  end;
+  PPNGPhysicalDimensions=^TPNGPhysicalDimensions;
+
   { TFPReaderPNG }
 
   TFPReaderPNG = class (TFPCustomImageReader)
@@ -80,6 +86,8 @@ Type
       procedure HandleChunk; virtual;
       procedure HandlePalette; virtual;
       procedure HandleAlpha; virtual;
+      procedure PredefinedResolutionValues; virtual;
+      procedure ReadResolutionValues; virtual;
       function CalcX (relX:integer) : integer;
       function CalcY (relY:integer) : integer;
       function CalcColor: TColorData;
@@ -294,6 +302,25 @@ begin
   end;
 end;
 
+procedure TFPReaderPNG.PredefinedResolutionValues;
+begin
+  //According with Standard: If the pHYs chunk is not present, pixels are assumed to be square
+  TheImage.ResolutionUnit :=ruNone;
+  TheImage.ResolutionX :=1;
+  TheImage.ResolutionY :=1;
+end;
+
+procedure TFPReaderPNG.ReadResolutionValues;
+begin
+  if (chunk.alength<>sizeof(TPNGPhysicalDimensions))
+  then raise Exception.Create('ctpHYs Chunk Size not Valid for TPNGPhysicalDimensions');
+  if (PPNGPhysicalDimensions(chunk.data)^.Unit_Specifier = 1)
+  then TheImage.ResolutionUnit :=ruPixelsPerCentimeter
+  else TheImage.ResolutionUnit :=ruNone;
+  TheImage.ResolutionX :=BEtoN(PPNGPhysicalDimensions(chunk.data)^.X_Pixels)/100;
+  TheImage.ResolutionY :=BEtoN(PPNGPhysicalDimensions(chunk.data)^.Y_Pixels)/100;
+end;
+
 procedure TFPReaderPNG.HandlePalette;
 var r : longword;
     c : TFPColor;
@@ -506,7 +533,7 @@ begin
     end
 end;
 
-function TFPReaderPNG.ColorGray1 (CD:TColorDAta) : TFPColor;
+function TFPReaderPNG.ColorGray1(CD: TColorData): TFPColor;
 begin
   if CD = 0 then
     result := colBlack
@@ -514,7 +541,7 @@ begin
     result := colWhite;
 end;
 
-function TFPReaderPNG.ColorGray2 (CD:TColorDAta) : TFPColor;
+function TFPReaderPNG.ColorGray2(CD: TColorData): TFPColor;
 var c : word;
 begin
   c := CD and 3;
@@ -530,7 +557,7 @@ begin
     end;
 end;
 
-function TFPReaderPNG.ColorGray4 (CD:TColorDAta) : TFPColor;
+function TFPReaderPNG.ColorGray4(CD: TColorData): TFPColor;
 var c : word;
 begin
   c := CD and $F;
@@ -545,7 +572,7 @@ begin
     end;
 end;
 
-function TFPReaderPNG.ColorGray8 (CD:TColorDAta) : TFPColor;
+function TFPReaderPNG.ColorGray8(CD: TColorData): TFPColor;
 var c : word;
 begin
   c := CD and $FF;
@@ -559,7 +586,7 @@ begin
     end;
 end;
 
-function TFPReaderPNG.ColorGray16 (CD:TColorDAta) : TFPColor;
+function TFPReaderPNG.ColorGray16(CD: TColorData): TFPColor;
 var c : word;
 begin
   c := CD and $FFFF;
@@ -846,6 +873,7 @@ begin
     ctIDAT : HandleData;
     ctIEND : EndOfFile := True;
     cttRNS : HandleAlpha;
+    ctpHYs : ReadResolutionValues;
     else HandleUnknown;
   end;
 end;
@@ -867,6 +895,9 @@ begin
     Img.SetSize (Width, Height);
   ZData := TMemoryStream.Create;
   try
+    //Resolution: If the pHYs chunk is not present, pixels are assumed to be square
+    PredefinedResolutionValues;
+
     EndOfFile := false;
     while not EndOfFile do
       begin

packages/fcl-image/src/fpreadpsd.pas

@@ -18,6 +18,7 @@
   2023-07  - Massimo Magnano
            - code fixes for reading palettes
            - added Read of Image Resources Section
+           - added Resolution support
 
 }
 unit FPReadPSD;
@@ -257,6 +258,9 @@ type
     property OnCreateImage: TPSDCreateCompatibleImgEvent read FOnCreateImage write FOnCreateImage;
   end;
 
+function PSDResolutionUnitToResolutionUnit(APSDResolutionUnit: Word): TResolutionUnit;
+function ResolutionUnitToPSdResolutionUnit(AResolutionUnit: TResolutionUnit): Word;
+
 implementation
 
 function CorrectCMYK(const C : TFPColor): TFPColor;
@@ -297,6 +301,24 @@ begin
   Result:=colBlack;
 end;
 
+function PSDResolutionUnitToResolutionUnit(APSDResolutionUnit: Word): TResolutionUnit;
+begin
+  Case APSDResolutionUnit of
+  PSD_RES_INCH: Result :=ruPixelsPerInch;
+  PSD_RES_CM: Result :=ruPixelsPerCentimeter;
+  else Result :=ruNone;
+  end;
+end;
+
+function ResolutionUnitToPSdResolutionUnit(AResolutionUnit: TResolutionUnit): Word;
+begin
+  Case AResolutionUnit of
+  ruPixelsPerInch: Result :=PSD_RES_INCH;
+  ruPixelsPerCentimeter: Result :=PSD_RES_CM;
+  else Result :=0;
+  end;
+end;
+
 { TFPReaderPSD }
 
 procedure TFPReaderPSD.CreateGrayPalette;
@@ -404,7 +426,32 @@ end;
 
 procedure TFPReaderPSD.ReadResourceBlockData(Img: TFPCustomImage; blockID: Word;
                                              blockName: ShortString; Size: LongWord; Data: Pointer);
+var
+  ResolutionInfo:TResolutionInfo;
+  ResDWord: DWord;
+
 begin
+  case blockID of
+  PSD_RESN_INFO:begin
+            ResolutionInfo :=TResolutionInfo(Data^);
+            //MaxM: Do NOT Remove the Casts after BEToN
+            Img.ResolutionUnit :=PSDResolutionUnitToResolutionUnit(BEToN(Word(ResolutionInfo.hResUnit)));
+
+            //MaxM: Resolution always recorded in a fixed point implied decimal int32
+            //      with 16 bits before point and 16 after (cast as DWord and divide resolution by 2^16)
+            ResDWord :=BEToN(DWord(ResolutionInfo.hRes));
+            Img.ResolutionX :=ResDWord/65536;
+            ResDWord :=BEToN(DWord(ResolutionInfo.vRes));
+            Img.ResolutionY :=ResDWord/65536;
+
+            if (Img.ResolutionUnit<>ruNone) and
+               (ResolutionInfo.vResUnit<>ResolutionInfo.hResUnit)
+            then Case BEToN(Word(ResolutionInfo.vResUnit)) of
+                 PSD_RES_INCH: Img.ResolutionY :=Img.ResolutionY/2.54; //Vertical Resolution is in Inch convert to Cm
+                 PSD_RES_CM: Img.ResolutionY :=Img.ResolutionY*2.54; //Vertical Resolution is in Cm convert to Inch
+                 end;
+          end;
+  end;
 end;
 
 procedure TFPReaderPSD.InternalRead(Stream: TStream; Img: TFPCustomImage);

packages/fcl-image/src/fpreadtiff.pas

@@ -37,6 +37,9 @@
  Not to do:
    Separate mask (deprecated)
 
+ 2023-07  - Massimo Magnano
+          - added Resolution support
+
 }
 unit FPReadTiff;
 
@@ -150,6 +153,9 @@ function DecompressDeflate(Compressed: PByte; CompressedCount: cardinal;
   out Decompressed: PByte; var DecompressedCount: cardinal;
   ErrorMsg: PAnsiString = nil): boolean;
 
+function TifResolutionUnitToResolutionUnit(ATifResolutionUnit: DWord): TResolutionUnit;
+function ResolutionUnitToTifResolutionUnit(AResolutionUnit: TResolutionUnit): DWord;
+
 implementation
 
 function CMYKToFPColor(C,M,Y,K: Word): TFPColor;
@@ -1763,6 +1769,14 @@ var
   TilesAcross, TilesDown: DWord;
   ChunkLeft, ChunkTop, ChunkWidth, ChunkHeight: DWord;
   ChunkBytesPerLine: DWord;
+
+  procedure ReadResolutionValues;
+  begin
+       CurFPImg.ResolutionUnit :=TifResolutionUnitToResolutionUnit(IFD.ResolutionUnit);
+       CurFPImg.ResolutionX :=IFD.XResolution.Numerator/IFD.XResolution.Denominator;
+       CurFPImg.ResolutionY :=IFD.YResolution.Numerator/IFD.YResolution.Denominator;
+  end;
+
 begin
   if (IFD.ImageWidth=0) or (IFD.ImageHeight=0) then
     exit;
@@ -1839,6 +1853,9 @@ begin
     CurFPImg:=IFD.Img;
     if CurFPImg=nil then exit;
 
+    //Resolution
+    ReadResolutionValues;
+
     SetFPImgExtras(CurFPImg, IFD);
 
     case IFD.Orientation of
@@ -2462,6 +2479,25 @@ begin
   Result:=true;
 end;
 
+function TifResolutionUnitToResolutionUnit(ATifResolutionUnit: DWord): TResolutionUnit;
+begin
+  Case ATifResolutionUnit of
+  2: Result :=ruPixelsPerInch;
+  3: Result :=ruPixelsPerCentimeter;
+  else Result :=ruNone;
+  end;
+end;
+
+function ResolutionUnitToTifResolutionUnit(AResolutionUnit: TResolutionUnit): DWord;
+begin
+  Case AResolutionUnit of
+  ruPixelsPerInch: Result :=2;
+  ruPixelsPerCentimeter: Result :=3;
+  else Result :=1;
+  end;
+end;
+
+
 initialization
   if ImageHandlers.ImageReader[TiffHandlerName]=nil then
     ImageHandlers.RegisterImageReader (TiffHandlerName, 'tif;tiff', TFPReaderTiff);

packages/fcl-image/src/fpwritebmp.pp

@@ -18,6 +18,9 @@
    - Rewritten a large part of the file, so we can handle all bmp color depths
    - Support for RLE4 and RLE8 encoding
   03/2015 MvdV finally removed bytesperpixel. 10 years should be enough.
+
+  2023-07  - Massimo Magnano
+           - added Resolution support
 }
 
 {$mode objfpc}{$h+}
@@ -253,6 +256,11 @@ begin
     Planes:=1;
     if FBpp=15 then BitCount:=16
     else BitCount:=FBpp;
+
+    Img.ResolutionUnit :=ruPixelsPerCentimeter;
+    fXPelsPerMeter :=Trunc(Img.ResolutionX*100);
+    fYPelsPerMeter :=Trunc(Img.ResolutionY*100);
+
     XPelsPerMeter:=fXPelsPerMeter;
     YPelsPerMeter:=fYPelsPerMeter;
     ClrImportant:=0;

packages/fcl-image/src/fpwritejpeg.pas

@@ -16,6 +16,7 @@
 
   2023-07  - Massimo Magnano
            - procedure inside InternalWrite moved to protected methods (virtual)
+           - added Resolution support
 
 }
 unit FPWriteJPEG;
@@ -133,6 +134,10 @@ begin
   jpeg_set_defaults(@FInfo);
   jpeg_set_quality(@FInfo, FQuality, True);
 
+  FInfo.density_unit :=ResolutionUnitTodensity_unit(Img.ResolutionUnit);
+  FInfo.X_density :=Round(Img.ResolutionX);
+  FInfo.Y_density :=Round(Img.ResolutionY);
+
   if ProgressiveEncoding then
     jpeg_simple_progression(@FInfo);
 end;

packages/fcl-image/src/fpwritepcx.pas

@@ -15,6 +15,9 @@
   Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 
   Save in format 24 bits compressed or not
+
+  2023-07  - Massimo Magnano
+           - added Resolution support
 }
 
 unit FPWritePCX;
@@ -61,8 +64,11 @@ begin
     YMin := 0;
     XMax := Img.Width - 1;
     YMax := Img.Height - 1;
-    HRes := 300;
-    VRes := 300;
+
+    Img.ResolutionUnit :=ruPixelsPerInch;
+    HRes :=Trunc(Img.ResolutionX);
+    VRes :=Trunc(Img.ResolutionY);
+
     ColorPlanes := 3;
     BytesPerLine := Img.Width;
     PaletteType := 1;

packages/fcl-image/src/fpwritepng.pp

@@ -25,6 +25,8 @@ type
 
   TColorFormatFunction = function (color:TFPColor) : TColorData of object;
 
+  { TFPWriterPNG }
+
   TFPWriterPNG = class (TFPCustomImageWriter)
     private
       FUsetRNS, FCompressedText, FWordSized, FIndexed,
@@ -57,6 +59,7 @@ type
       procedure InternalWrite (Str:TStream; Img:TFPCustomImage); override;
       procedure WriteIHDR; virtual;
       procedure WritePLTE; virtual;
+      procedure WriteResolutionValues; virtual;
       procedure WritetRNS; virtual;
       procedure WriteIDAT; virtual;
       procedure WriteTexts; virtual;
@@ -103,6 +106,8 @@ type
 
 implementation
 
+uses FPReadPNG;
+
 constructor TFPWriterPNG.create;
 begin
   inherited;
@@ -667,6 +672,36 @@ begin
   WriteChunk;
 end;
 
+procedure TFPWriterPNG.WriteResolutionValues;
+begin
+  SetChunkLength(sizeof(TPNGPhysicalDimensions));
+  SetChunkType(ctpHYs);
+
+  with PPNGPhysicalDimensions(ChunkDataBuffer)^ do
+  begin
+    if (TheImage.ResolutionUnit=ruPixelsPerInch)
+    then TheImage.ResolutionUnit :=ruPixelsPerCentimeter;
+    if (TheImage.ResolutionUnit=ruPixelsPerCentimeter)
+    then begin
+           Unit_Specifier:=1;
+           X_Pixels :=Trunc(TheImage.ResolutionX*100);
+           Y_Pixels :=Trunc(TheImage.ResolutionY*100);
+         end
+    else begin //ruNone
+           Unit_Specifier:=0;
+           X_Pixels :=Trunc(TheImage.ResolutionX);
+           Y_Pixels :=Trunc(TheImage.ResolutionY);
+       end;
+
+    {$IFDEF ENDIAN_LITTLE}
+    X_Pixels :=swap(X_Pixels);
+    Y_Pixels :=swap(Y_Pixels);
+    {$ENDIF}
+  end;
+
+  WriteChunk;
+end;
+
 procedure TFPWriterPNG.InitWriteIDAT;
 begin
   FDatalineLength := TheImage.Width*ByteWidth;
@@ -719,7 +754,7 @@ begin
     end;
 end;
 
-procedure TFPWriterPNG.GatherData;
+procedure TFPWriterPNG.Gatherdata;
 var x,y : integer;
     lf : byte;
 begin
@@ -846,6 +881,9 @@ begin
   WriteIHDR;
   if Fheader.colorType = 3 then
     WritePLTE;
+
+  WriteResolutionValues;
+
   if FUsetRNS then
     WritetRNS;
   WriteIDAT;

packages/fcl-image/src/fpwritetiff.pas

@@ -30,6 +30,9 @@
    bigtiff 64bit offsets
    endian - currently using system endianess
    orientation with rotation
+
+   2023-07  - Massimo Magnano
+            - added Resolution support
 }
 unit FPWriteTiff;
 
@@ -122,6 +125,8 @@ function CompressDeflate(InputData: PByte; InputCount: cardinal;
 
 implementation
 
+uses FPReadTiff;
+
 function CompareTiffWriteEntries(Entry1, Entry2: Pointer): integer;
 begin
   Result:=integer(TTiffWriterEntry(Entry1).Tag)-integer(TTiffWriterEntry(Entry2).Tag);
@@ -415,6 +420,20 @@ var
   cx,cy,x,y,sx: DWord;
   dx,dy: integer;
   ChunkBytesPerLine: DWord;
+
+  procedure WriteResolutionValues;
+  begin
+       IFD.ResolutionUnit :=ResolutionUnitToTifResolutionUnit(Img.ResolutionUnit);
+       IFD.XResolution.Numerator :=Trunc(Img.ResolutionX*1000);
+       IFD.XResolution.Denominator :=1000;
+       IFD.YResolution.Numerator :=Trunc(Img.ResolutionY*1000);
+       IFD.YResolution.Denominator :=1000;
+
+       Img.Extra[TiffResolutionUnit]:=IntToStr(IFD.ResolutionUnit);
+       Img.Extra[TiffXResolution]:=TiffRationalToStr(IFD.XResolution);
+       Img.Extra[TiffYResolution]:=TiffRationalToStr(IFD.YResolution);
+  end;
+
 begin
   ChunkOffsets:=nil;
   Chunk:=nil;
@@ -430,6 +449,9 @@ begin
     if not (IFD.PhotoMetricInterpretation in [0,1,2]) then
       TiffError('PhotoMetricInterpretation="'+Img.Extra[TiffPhotoMetric]+'" not supported');
 
+    //Resolution
+    WriteResolutionValues;
+
     GrayBits:=0;
     RedBits:=0;
     GreenBits:=0;

packages/fcl-web/examples/httpserver/simplehttpserver.compiled

@@ -0,0 +1,5 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <Compiler Value="/usr/lib/fpc/3.3.1/ppcx64" Date="1680458816"/>
+  <Params Value=" -MObjFPC -Scghi -Cg -O1 -g -gl -l -vewnhibq -Fu/home/mattias/pascal/fpc_sources/3.3.1/packages/fcl-web/examples/echo/webmodule -Fu/home/mattias/pascal/fpc_sources/3.3.1/packages/fcl-web/examples/httpserver/ -o/home/mattias/pascal/fpc_sources/3.3.1/packages/fcl-web/examples/httpserver/simplehttpserver simplehttpserver.pas"/>
+</CONFIG>