fcl-image JPEG reader/writer, PSD reader

fcl-image JPEG reader - procedure inside InternalRead moved to protected virtual methods
fcl-image JPEG writer - procedure inside InternalWrite moved to protected virtual methods
fcl-image PSD reader - code fixes for reading palettes, added Read of Image Resources Section

packages/fcl-image/src/fpreadjpeg.pas

@@ -16,6 +16,9 @@
 
   ToDo:
     - palette
+
+    2023-07  - Massimo Magnano
+             - procedure inside InternalRead moved to protected methods (virtual)
 }
 unit FPReadJPEG;
 
@@ -45,9 +48,15 @@ type
   TJPEGScale = (jsFullSize, jsHalf, jsQuarter, jsEighth);
   TJPEGReadPerformance = (jpBestQuality, jpBestSpeed);
 
+  TExifOrientation = ( // all angles are clockwise
+    eoUnknown, eoNormal, eoMirrorHor, eoRotate180, eoMirrorVert,
+    eoMirrorHorRot270, eoRotate90, eoMirrorHorRot90, eoRotate270
+  );
+
   TFPReaderJPEG = class(TFPCustomImageReader)
   private
-    FSmoothing: boolean;
+    FSmoothing,
+    Continue: boolean;
     FMinHeight:integer;
     FMinWidth:integer;
     FWidth: Integer;
@@ -59,13 +68,18 @@ type
     FInfo: jpeg_decompress_struct;
     FScale: TJPEGScale;
     FPerformance: TJPEGReadPerformance;
+    FOrientation: TExifOrientation;
+
     procedure SetPerformance(const AValue: TJPEGReadPerformance);
     procedure SetSmoothing(const AValue: boolean);
   protected
+    procedure ReadHeader(Str: TStream; Img: TFPCustomImage); virtual;
+    procedure ReadPixels(Str: TStream; Img: TFPCustomImage); virtual;
     procedure InternalRead(Str: TStream; Img: TFPCustomImage); override;
     function  InternalCheck(Str: TStream): boolean; override;
     class function InternalSize(Str:TStream): TPoint; override;
     property CompressInfo : jpeg_decompress_struct Read Finfo Write FInfo;
+    property Orientation: TExifOrientation Read FOrientation Write FOrientation;
   public
     constructor Create; override;
     destructor Destroy; override;
@@ -80,12 +94,6 @@ type
 
 implementation
 
-type
-  TExifOrientation = ( // all angles are clockwise
-    eoUnknown, eoNormal, eoMirrorHor, eoRotate180, eoMirrorVert,
-    eoMirrorHorRot270, eoRotate90, eoMirrorHorRot90, eoRotate270
-  );
-
 procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
                                      StartSize: integer);
 var
@@ -170,56 +178,13 @@ begin
   FPerformance:=AValue;
 end;
 
-procedure TFPReaderJPEG.InternalRead(Str: TStream; Img: TFPCustomImage);
+procedure TFPReaderJPEG.ReadHeader(Str: TStream; Img: TFPCustomImage);
 var
-  MemStream: TMemoryStream;
+   S: TSize;
-  Orientation: TExifOrientation;
-
-  function TranslatePixel(const Px: TPoint): TPoint;
-  begin
-    case Orientation of
-      eoUnknown, eoNormal: Result := Px;
-      eoMirrorHor:
-      begin
-        Result.X := FInfo.output_width-1-Px.X;
-        Result.Y := Px.Y;
-      end;
-      eoRotate180:
-      begin
-        Result.X := FInfo.output_width-1-Px.X;
-        Result.Y := FInfo.output_height-1-Px.Y;
-      end;
-      eoMirrorVert:
-      begin
-        Result.X := Px.X;
-        Result.Y := FInfo.output_height-1-Px.Y;
-      end;
-      eoMirrorHorRot270:
-      begin
-        Result.X := Px.Y;
-        Result.Y := Px.X;
-      end;
-      eoRotate90:
-      begin
-        Result.X := FInfo.output_height-1-Px.Y;
-        Result.Y := Px.X;
-      end;
-      eoMirrorHorRot90:
-      begin
-        Result.X := FInfo.output_height-1-Px.Y;
-        Result.Y := FInfo.output_width-1-Px.X;
-      end;
-      eoRotate270:
-      begin
-        Result.X := Px.Y;
-        Result.Y := FInfo.output_width-1-Px.X;
-      end;
-    end;
-  end;
 
   function TranslateSize(const Sz: TSize): TSize;
   begin
-    case Orientation of
+    case FOrientation of
       eoUnknown, eoNormal, eoMirrorHor, eoMirrorVert, eoRotate180: Result := Sz;
       eoMirrorHorRot270, eoRotate90, eoMirrorHorRot90, eoRotate270:
       begin
@@ -229,29 +194,32 @@ var
     end;
   end;
 
-  procedure SetSource;
+begin
-  begin
+  jpeg_read_header(@FInfo, TRUE);
-    MemStream.Position:=0;
-    jpeg_stdio_src(@FInfo, @MemStream);
-  end;
 
-  procedure ReadHeader;
+  if FInfo.saw_EXIF_marker and (FInfo.orientation >= Ord(Low(TExifOrientation))) and (FInfo.orientation <= Ord(High(TExifOrientation))) then
-  var
+    FOrientation := TExifOrientation(FInfo.orientation)
-    S: TSize;
+  else
-  begin
+    FOrientation := Low(TExifOrientation);
-    jpeg_read_header(@FInfo, TRUE);
+  S := TranslateSize(TSize.Create(FInfo.image_width, FInfo.image_height));
+  FWidth := S.Width;
+  FHeight := S.Height;
 
-    if FInfo.saw_EXIF_marker and (FInfo.orientation >= Ord(Low(TExifOrientation))) and (FInfo.orientation <= Ord(High(TExifOrientation))) then
+  FGrayscale := FInfo.jpeg_color_space = JCS_GRAYSCALE;
-      Orientation := TExifOrientation(FInfo.orientation)
+  FProgressiveEncoding := jpeg_has_multiple_scans(@FInfo);
-    else
+end;
-      Orientation := Low(TExifOrientation);
-    S := TranslateSize(TSize.Create(FInfo.image_width, FInfo.image_height));
-    FWidth := S.Width;
-    FHeight := S.Height;
 
-    FGrayscale := FInfo.jpeg_color_space = JCS_GRAYSCALE;
+procedure TFPReaderJPEG.ReadPixels(Str: TStream; Img: TFPCustomImage);
-    FProgressiveEncoding := jpeg_has_multiple_scans(@FInfo);
+var
-  end;
+  SampArray: JSAMPARRAY;
+  SampRow: JSAMPROW;
+  Color: TFPColor;
+  LinesRead: Cardinal;
+  x: Integer;
+  y: Integer;
+  c: word;
+  Status,Scan: integer;
+  ReturnValue,RestartLoop: Boolean;
 
   procedure InitReadingPixels;
   var d1,d2:integer;
@@ -300,6 +268,57 @@ var
       end;
   end;
 
+  function TranslatePixel(const Px: TPoint): TPoint;
+  begin
+    case FOrientation of
+      eoUnknown, eoNormal: Result := Px;
+      eoMirrorHor:
+      begin
+        Result.X := FInfo.output_width-1-Px.X;
+        Result.Y := Px.Y;
+      end;
+      eoRotate180:
+      begin
+        Result.X := FInfo.output_width-1-Px.X;
+        Result.Y := FInfo.output_height-1-Px.Y;
+      end;
+      eoMirrorVert:
+      begin
+        Result.X := Px.X;
+        Result.Y := FInfo.output_height-1-Px.Y;
+      end;
+      eoMirrorHorRot270:
+      begin
+        Result.X := Px.Y;
+        Result.Y := Px.X;
+      end;
+      eoRotate90:
+      begin
+        Result.X := FInfo.output_height-1-Px.Y;
+        Result.Y := Px.X;
+      end;
+      eoMirrorHorRot90:
+      begin
+        Result.X := FInfo.output_height-1-Px.Y;
+        Result.Y := FInfo.output_width-1-Px.X;
+      end;
+      eoRotate270:
+      begin
+        Result.X := Px.Y;
+        Result.Y := FInfo.output_width-1-Px.X;
+      end;
+    end;
+  end;
+
+  procedure SetPixel(x, y: integer; const C: TFPColor);
+  var
+    P: TPoint;
+  begin
+    P := TPoint.Create(x,y);
+    P := TranslatePixel(P);
+    Img.Colors[P.x, P.y] := C;
+  end;
+
   function CorrectCMYK(const C: TFPColor): TFPColor;
   var
     MinColor: word;
@@ -314,6 +333,7 @@ var
     Result.blue:=(C.blue-MinColor) shl 8;
     Result.alpha:=alphaOpaque;
   end;
+
   function CorrectYCCK(const C: TFPColor): TFPColor;
   var
     MinColor: word;
@@ -327,175 +347,163 @@ var
     Result.blue:=(C.blue-MinColor) shl 8;
     Result.alpha:=alphaOpaque;
   end;
-  procedure ReadPixels;
+
-    procedure SetPixel(x, y: integer; const C: TFPColor);
+
-    var
+  procedure OutputScanLines();
-      P: TPoint;
-    begin
-      P := TPoint.Create(x,y);
-      P := TranslatePixel(P);
-      Img.Colors[P.x, P.y] := C;
-    end;
   var
-    Continue: Boolean;
+    x: integer;
-    SampArray: JSAMPARRAY;
-    SampRow: JSAMPROW;
-    Color: TFPColor;
-    LinesRead: Cardinal;
-    x: Integer;
-    y: Integer;
-    c: word;
-    Status,Scan: integer;
-    ReturnValue,RestartLoop: Boolean;
-    procedure OutputScanLines();
-    var
-      x: integer;
-    begin
-      Color.Alpha:=alphaOpaque;
-      y:=0;
-      while (FInfo.output_scanline < FInfo.output_height) do begin
-        // read one line per call
-        LinesRead := jpeg_read_scanlines(@FInfo, SampArray, 1);
-        if LinesRead<1 then begin
-          ReturnValue:=false;
-          break;
-        end;
-        if (FInfo.jpeg_color_space = JCS_CMYK) then
-        for x:=0 to FInfo.output_width-1 do begin
-          Color.Red:=SampRow^[x*4+0];
-          Color.Green:=SampRow^[x*4+1];
-          Color.Blue:=SampRow^[x*4+2];
-          Color.alpha:=SampRow^[x*4+3];
-          SetPixel(x, y, CorrectCMYK(Color));
-        end
-        else
-        if (FInfo.jpeg_color_space = JCS_YCCK) then
-        for x:=0 to FInfo.output_width-1 do begin
-          Color.Red:=SampRow^[x*4+0];
-          Color.Green:=SampRow^[x*4+1];
-          Color.Blue:=SampRow^[x*4+2];
-          Color.alpha:=SampRow^[x*4+3];
-          SetPixel(x, y, CorrectYCCK(Color));
-        end
-        else
-        if fgrayscale then begin
-         for x:=0 to FInfo.output_width-1 do begin
-           c:= SampRow^[x] shl 8;
-           Color.Red:=c;
-           Color.Green:=c;
-           Color.Blue:=c;
-           SetPixel(x, y, Color);
-         end;
-        end
-        else begin
-         for x:=0 to FInfo.output_width-1 do begin
-           Color.Red:=SampRow^[x*3+0] shl 8;
-           Color.Green:=SampRow^[x*3+1] shl 8;
-           Color.Blue:=SampRow^[x*3+2] shl 8;
-           SetPixel(x, y, Color);
-         end;
-        end;
-        inc(y);
-      end;
-    end;
   begin
-    InitReadingPixels;
+    Color.Alpha:=alphaOpaque;
+    y:=0;
+    while (FInfo.output_scanline < FInfo.output_height) do begin
+      // read one line per call
+      LinesRead := jpeg_read_scanlines(@FInfo, SampArray, 1);
+      if LinesRead<1 then begin
+        ReturnValue:=false;
+        break;
+      end;
+      if (FInfo.jpeg_color_space = JCS_CMYK) then
+      for x:=0 to FInfo.output_width-1 do begin
+        Color.Red:=SampRow^[x*4+0];
+        Color.Green:=SampRow^[x*4+1];
+        Color.Blue:=SampRow^[x*4+2];
+        Color.alpha:=SampRow^[x*4+3];
+        SetPixel(x, y, CorrectCMYK(Color));
+      end
+      else
+      if (FInfo.jpeg_color_space = JCS_YCCK) then
+      for x:=0 to FInfo.output_width-1 do begin
+        Color.Red:=SampRow^[x*4+0];
+        Color.Green:=SampRow^[x*4+1];
+        Color.Blue:=SampRow^[x*4+2];
+        Color.alpha:=SampRow^[x*4+3];
+        SetPixel(x, y, CorrectYCCK(Color));
+      end
+      else
+      if fgrayscale then begin
+       for x:=0 to FInfo.output_width-1 do begin
+         c:= SampRow^[x] shl 8;
+         Color.Red:=c;
+         Color.Green:=c;
+         Color.Blue:=c;
+         SetPixel(x, y, Color);
+       end;
+      end
+      else begin
+       for x:=0 to FInfo.output_width-1 do begin
+         Color.Red:=SampRow^[x*3+0] shl 8;
+         Color.Green:=SampRow^[x*3+1] shl 8;
+         Color.Blue:=SampRow^[x*3+2] shl 8;
+         SetPixel(x, y, Color);
+       end;
+      end;
+      inc(y);
+    end;
+  end;
+begin
+  InitReadingPixels;
 
-    Continue:=true;
+  Continue:=true;
-    Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue);
+  Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue);
-    if not Continue then exit;
+  if not Continue then exit;
 
-    jpeg_start_decompress(@FInfo);
+  jpeg_start_decompress(@FInfo);
 
-    Img.SetSize(FWidth,FHeight);
+  Img.SetSize(FWidth,FHeight);
 
-    GetMem(SampArray,SizeOf(JSAMPROW));
+  GetMem(SampArray,SizeOf(JSAMPROW));
-    GetMem(SampRow,FInfo.output_width*FInfo.output_components);
+  GetMem(SampRow,FInfo.output_width*FInfo.output_components);
-    SampArray^[0]:=SampRow;
+  SampArray^[0]:=SampRow;
-    try
+  try
-      case FProgressiveEncoding of
+    case FProgressiveEncoding of
-        false:
+      false:
-          begin
+        begin
+          ReturnValue:=true;
+          OutputScanLines();
+          if FInfo.buffered_image then jpeg_finish_output(@FInfo);
+        end;
+      true:
+        begin
+          while true do begin
+            (* The RestartLoop variable drops a placeholder for suspension
+               mode, or partial jpeg decode, return and continue. In case
+               of support this suspension, the RestartLoop:=True should be
+               changed by an Exit and in the routine enter detects that it
+               is being called from a suspended state to not
+               reinitialize some buffer *)
+            RestartLoop:=false;
+            repeat
+              status := jpeg_consume_input(@FInfo);
+            until (status=JPEG_SUSPENDED) or (status=JPEG_REACHED_EOI);
             ReturnValue:=true;
-            OutputScanLines();
+            if FInfo.output_scanline = 0 then begin
-            if FInfo.buffered_image then jpeg_finish_output(@FInfo);
+              Scan := FInfo.input_scan_number;
-          end;
+              (* if we haven't displayed anything yet (output_scan_number==0)
-        true:
+                and we have enough data for a complete scan, force output
-          begin
+                of the last full scan *)
-            while true do begin
+              if (FInfo.output_scan_number = 0) and (Scan > 1) and
-              (* The RestartLoop variable drops a placeholder for suspension
+                (status <> JPEG_REACHED_EOI) then Dec(Scan);
-                 mode, or partial jpeg decode, return and continue. In case
-                 of support this suspension, the RestartLoop:=True should be
-                 changed by an Exit and in the routine enter detects that it
-                 is being called from a suspended state to not
-                 reinitialize some buffer *)
-              RestartLoop:=false;
-              repeat
-                status := jpeg_consume_input(@FInfo);
-              until (status=JPEG_SUSPENDED) or (status=JPEG_REACHED_EOI);
-              ReturnValue:=true;
-              if FInfo.output_scanline = 0 then begin
-                Scan := FInfo.input_scan_number;
-                (* if we haven't displayed anything yet (output_scan_number==0)
-                  and we have enough data for a complete scan, force output
-                  of the last full scan *)
-                if (FInfo.output_scan_number = 0) and (Scan > 1) and
-                  (status <> JPEG_REACHED_EOI) then Dec(Scan);
 
-                if not jpeg_start_output(@FInfo, Scan) then begin
+              if not jpeg_start_output(@FInfo, Scan) then begin
-                  RestartLoop:=true; (* I/O suspension *)
+                RestartLoop:=true; (* I/O suspension *)
+              end;
+            end;
+
+            if not RestartLoop then begin
+              if (FInfo.output_scanline = $ffffff) then
+                FInfo.output_scanline := 0;
+
+              OutputScanLines();
+
+              if ReturnValue=false then begin
+                if (FInfo.output_scanline = 0) then begin
+                   (* didn't manage to read any lines - flag so we don't call
+                      jpeg_start_output() multiple times for the same scan *)
+                   FInfo.output_scanline := $ffffff;
                 end;
+                RestartLoop:=true; (* I/O suspension *)
               end;
 
               if not RestartLoop then begin
-                if (FInfo.output_scanline = $ffffff) then
+                if (FInfo.output_scanline = FInfo.output_height) then begin
-                  FInfo.output_scanline := 0;
+                  if not jpeg_finish_output(@FInfo) then begin
-
+                    RestartLoop:=true; (* I/O suspension *)
-                OutputScanLines();
-
-                if ReturnValue=false then begin
-                  if (FInfo.output_scanline = 0) then begin
-                     (* didn't manage to read any lines - flag so we don't call
-                        jpeg_start_output() multiple times for the same scan *)
-                     FInfo.output_scanline := $ffffff;
                   end;
-                  RestartLoop:=true; (* I/O suspension *)
-                end;
 
-                if not RestartLoop then begin
+                  if not RestartLoop then begin
-                  if (FInfo.output_scanline = FInfo.output_height) then begin
+                    if (jpeg_input_complete(@FInfo) and
-                    if not jpeg_finish_output(@FInfo) then begin
+                       (FInfo.input_scan_number = FInfo.output_scan_number)) then
-                      RestartLoop:=true; (* I/O suspension *)
+                      break;
-                    end;
 
-                    if not RestartLoop then begin
+                    FInfo.output_scanline := 0;
-                      if (jpeg_input_complete(@FInfo) and
-                         (FInfo.input_scan_number = FInfo.output_scan_number)) then
-                        break;
-
-                      FInfo.output_scanline := 0;
-                    end;
                   end;
                 end;
               end;
-              if RestartLoop then begin
+            end;
-                (* Suspension mode, but as not supported by this implementation
+            if RestartLoop then begin
-                   it will simple break the loop to avoid endless looping. *)
+              (* Suspension mode, but as not supported by this implementation
-                break;
+                 it will simple break the loop to avoid endless looping. *)
-              end;
+              break;
             end;
           end;
-      end;
+        end;
-    finally
-      FreeMem(SampRow);
-      FreeMem(SampArray);
     end;
-
+  finally
-    jpeg_finish_decompress(@FInfo);
+    FreeMem(SampRow);
-
+    FreeMem(SampArray);
-    Progress(psEnding, 100, false, Rect(0,0,0,0), '', Continue);
   end;
 
+  jpeg_finish_decompress(@FInfo);
+
+  Progress(psEnding, 100, false, Rect(0,0,0,0), '', Continue);
+end;
+
+
+
+procedure TFPReaderJPEG.InternalRead(Str: TStream; Img: TFPCustomImage);
+var
+  MemStream: TMemoryStream;
+
 begin
   FWidth:=0;
   FHeight:=0;
@@ -517,9 +525,12 @@ begin
         FProgressMgr.pub.progress_monitor := @ProgressCallback;
         FProgressMgr.instance := Self;
         FInfo.progress := @FProgressMgr.pub;
-        SetSource;
+
-        ReadHeader;
+        MemStream.Position:=0;
-        ReadPixels;
+        jpeg_stdio_src(@FInfo, @MemStream);
+
+        ReadHeader(MemStream, Img);
+        ReadPixels(MemStream, Img);
       finally
         jpeg_Destroy_Decompress(@FInfo);
       end;
@@ -535,18 +546,6 @@ var
   JInfo: jpeg_decompress_struct;
   JError: jpeg_error_mgr;
 
-  procedure SetSource;
-  begin
-    jpeg_stdio_src(@JInfo, @Str);
-  end;
-
-  procedure ReadHeader;
-  begin
-    jpeg_read_header(@JInfo, TRUE);
-    Result.X := JInfo.image_width;
-    Result.Y := JInfo.image_height;
-  end;
-
 begin
   FillChar(JInfo,SizeOf(JInfo),0);
   if Str.Position < Str.Size then begin
@@ -554,8 +553,11 @@ begin
     JInfo.err := @JError;
     jpeg_CreateDecompress(@JInfo, JPEG_LIB_VERSION, SizeOf(JInfo));
     try
-      SetSource;
+       jpeg_stdio_src(@JInfo, @Str);
-      ReadHeader;
+
+       jpeg_read_header(@JInfo, TRUE);
+       Result.X := JInfo.image_width;
+       Result.Y := JInfo.image_height;
     finally
       jpeg_Destroy_Decompress(@JInfo);
     end;

packages/fcl-image/src/fpreadpsd.pas

@@ -14,6 +14,11 @@
  **********************************************************************
 
   ToDo: read further images
+
+  2023-07  - Massimo Magnano
+           - code fixes for reading palettes
+           - added Read of Image Resources Section
+
 }
 unit FPReadPSD;
 
@@ -24,6 +29,133 @@ interface
 uses
   Classes, SysUtils, FPimage;
 
+const
+  { Image color modes  }
+  PSD_BITMAP = 0;       { Bitmap image  }
+  PSD_GRAYSCALE = 1;	{ Greyscale image  }
+  PSD_INDEXED = 2;	{ Indexed image  }
+  PSD_RGB = 3;	        { RGB image  }
+  PSD_CMYK = 4;	        { CMYK  }
+  PSD_MULTICHANNEL = 7;	{ Multichannel image }
+  PSD_DUOTONE = 8;	{ Duotone image }
+  PSD_LAB = 9;	        { L*a*b image  }
+
+  { Image color spaces  }
+  PSD_CS_RGB = 0;	{ RGB  }
+  PSD_CS_HSB = 1;	{ Hue, Saturation, Brightness  }
+  PSD_CS_CMYK = 2;	{ CMYK  }
+  PSD_CS_PANTONE = 3;	{ Pantone matching system (Lab) }
+  PSD_CS_FOCOLTONE = 4;	{ Focoltone color system (CMYK) }
+  PSD_CS_TRUMATCH = 5;	{ Trumatch color (CMYK) }
+  PSD_CS_TOYO = 6;	{ Toyo 88 colorfinder 1050 (Lab) }
+  PSD_CS_LAB = 7;	{ L*a*b }
+  PSD_CS_GRAYSCALE = 8;	{ Grey scale  }
+  PSD_CS_HKS = 10;	{ HKS colors (CMYK) }
+  PSD_CS_DIC = 11;	{ DIC color guide (Lab) }
+  PSD_CS_ANPA = 3000;	{ Anpa color (Lab) }
+
+  { Image Resource IDs  }
+  PSD_ResourceSectionSignature ='8BIM';
+
+  PSD_PS2_IMAGE_INFO = $03e8;   { Obsolete - ps 2.0 image info  }
+  PSD_MAC_PRINT_INFO = $03e9;   { Optional - Mac print manager print info record  }
+  PSD_PS2_COLOR_TAB = $03eb;    { Obsolete - ps 2.0 indexed color table  }
+  PSD_RESN_INFO = $03ed;        { ResolutionInfo structure  }
+  PSD_ALPHA_NAMES = $03ee;      { Alpha channel names  }
+  PSD_DISPLAY_INFO = $03ef;     { Superceded by PSD_DISPLAY_INFO_NEW for ps CS3 and higher - DisplayInfo structure  }
+  PSD_CAPTION = $03f0;          { Optional - Caption string  }
+  PSD_BORDER_INFO = $03f1;      { Border info  }
+  PSD_BACKGROUND_COL = $03f2;   { Background color  }
+  PSD_PRINT_FLAGS = $03f3;      { Print flags  }
+  PSD_GREY_HALFTONE = $03f4;    { Greyscale and multichannel halftoning info  }
+  PSD_COLOR_HALFTONE = $03f5;   { Color halftoning info  }
+  PSD_DUOTONE_HALFTONE = $03f6; { Duotone halftoning info  }
+  PSD_GREY_XFER = $03f7;        { Greyscale and multichannel transfer functions  }
+  PSD_COLOR_XFER = $03f8;       { Color transfer functions  }
+  PSD_DUOTONE_XFER = $03f9;     { Duotone transfer functions  }
+  PSD_DUOTONE_INFO = $03fa;     { Duotone image information  }
+  PSD_EFFECTIVE_BW = $03fb;     { Effective black & white values for dot range  }
+  PSD_OBSOLETE_01 = $03fc;      { Obsolete  }
+  PSD_EPS_OPT = $03fd;          { EPS options  }
+  PSD_QUICK_MASK = $03fe;       { Quick mask info  }
+  PSD_OBSOLETE_02 = $03ff;      { Obsolete  }
+  PSD_LAYER_STATE = $0400;      { Layer state info  }
+  PSD_WORKING_PATH = $0401;     { Working path (not saved)  }
+  PSD_LAYER_GROUP = $0402;      { Layers group info  }
+  PSD_OBSOLETE_03 = $0403;      { Obsolete  }
+  PSD_IPTC_NAA_DATA = $0404;    { IPTC-NAA record (IMV4.pdf)  }
+  PSD_IMAGE_MODE_RAW = $0405;   { Image mode for raw format files  }
+  PSD_JPEG_QUAL = $0406;        { JPEG quality  }
+  PSD_GRID_GUIDE = $0408;       { Grid & guide info  }
+  PSD_THUMB_RES = $0409;        { Thumbnail resource  }
+  PSD_COPYRIGHT_FLG = $040a;    { Copyright flag  }
+  PSD_URL = $040b;              { URL string  }
+  PSD_THUMB_RES2 = $040c;       { Thumbnail resource  }
+  PSD_GLOBAL_ANGLE = $040d;     { Superceded by PSD_NEW_COLOR_SAMPLER for ps CS3 and higher - Global angle  }
+  PSD_COLOR_SAMPLER = $040e;    { Superceded by PSD_NEW_COLOR_SAMPLER for ps CS3 and higher - Color samplers resource  }
+  PSD_ICC_PROFILE = $040f;      { ICC Profile  }
+  PSD_WATERMARK = $0410;        { Watermark  }
+  PSD_ICC_UNTAGGED = $0411;     { Do not use ICC profile flag  }
+  PSD_EFFECTS_VISIBLE = $0412;  { Show / hide all effects layers  }
+  PSD_SPOT_HALFTONE = $0413;    { Spot halftone  }
+  PSD_DOC_IDS = $0414;          { Document specific IDs  }
+  PSD_ALPHA_NAMES_UNI = $0415;  { Unicode alpha names  }
+  PSD_IDX_COL_TAB_CNT = $0416;  { Indexed color table count  }
+  PSD_IDX_TRANSPARENT = $0417;  { Index of transparent color (if any)  }
+  PSD_GLOBAL_ALT = $0419;       { Global altitude  }
+  PSD_SLICES = $041a;           { Slices  }
+  PSD_WORKFLOW_URL_UNI = $041b; { Workflow URL - Unicode string  }
+  PSD_JUMP_TO_XPEP = $041c;     { Jump to XPEP (?)  }
+  PSD_ALPHA_ID = $041d;         { Alpha IDs  }
+  PSD_URL_LIST_UNI = $041e;     { URL list - unicode  }
+  PSD_VERSION_INFO = $0421;     { Version info  }
+  PSD_EXIF_DATA = $0422;        { Exif data block 1  }
+  PSD_EXIF_DATA_3 = $0423;      { Exif data block 3 (?)  }
+  PSD_XMP_DATA = $0424;         { XMP data block  }
+  PSD_CAPTION_DIGEST = $0425;   { Caption digest  }
+  PSD_PRINT_SCALE = $0426;      { Print scale  }
+  PSD_PIXEL_AR = $0428;         { Pixel aspect ratio  }
+  PSD_LAYER_COMPS = $0429;      { Layer comps  }
+  PSD_ALT_DUOTONE_COLOR = $042A;{ Alternative Duotone colors  }
+  PSD_ALT_SPOT_COLOR = $042B;   { Alternative Spot colors  }
+  PSD_LAYER_SELECT_ID = $042D;  { Layer selection ID  }
+  PSD_HDR_TONING_INFO = $042E;  { HDR toning information  }
+  PSD_PRINT_INFO_SCALE = $042F; { Print scale  }
+  PSD_LAYER_GROUP_E_ID = $0430; { Layer group(s) enabled ID  }
+  PSD_COLOR_SAMPLER_NEW = $0431;{ Color sampler resource for ps CS3 and higher PSD files  }
+  PSD_MEASURE_SCALE = $0432;    { Measurement scale  }
+  PSD_TIMELINE_INFO = $0433;    { Timeline information  }
+  PSD_SHEET_DISCLOSE = $0434;   { Sheet discloser  }
+  PSD_DISPLAY_INFO_NEW = $0435; { DisplayInfo structure for ps CS3 and higher PSD files  }
+  PSD_ONION_SKINS = $0436;      { Onion skins  }
+  PSD_COUNT_INFO = $0438;       { Count information }
+  PSD_PRINT_INFO = $043A;       { Print information added in ps CS5 }
+  PSD_PRINT_STYLE = $043B;      { Print style  }
+  PSD_MAC_NSPRINTINFO = $043C;  { Mac NSPrintInfo }
+  PSD_WIN_DEVMODE = $043D;      { Windows DEVMODE  }
+  PSD_AUTO_SAVE_PATH = $043E;   { Auto save file path  }
+  PSD_AUTO_SAVE_FORMAT = $043F; { Auto save format  }
+  PSD_PATH_INFO_FIRST = $07d0;  { First path info block  }
+  PSD_PATH_INFO_LAST = $0bb6;   { Last path info block  }
+  PSD_CLIPPING_PATH = $0bb7;    { Name of clipping path  }
+  PSD_PLUGIN_R_FIRST = $0FA0;   { First plugin resource  }
+  PSD_PLUGIN_R_LAST = $1387;    { Last plugin resource  }
+  PSD_IMAGEREADY_VARS = $1B58;  { Imageready variables  }
+  PSD_IMAGEREADY_DATA = $1B59;  { Imageready data sets  }
+  PSD_LIGHTROOM_WORK = $1F40;   { Lightroom workflow  }
+  PSD_PRINT_FLAGS_2 = $2710;    { Print flags  }
+
+  { Display resolution units  }
+  PSD_RES_INCH = 1; { Pixels / inch  }
+  PSD_RES_CM = 2;   { Pixels / cm  }
+
+  { Width and height units  }
+  PSD_UNIT_INCH = 1;  { inches  }
+  PSD_UNIT_CM = 2;    { cm  }
+  PSD_UNIT_POINT = 3; { points  (72 points =   1 inch)  }
+  PSD_UNIT_PICA = 4;  { pica    ( 6 pica   =   1 inch)  }
+  PSD_UNIT_COLUMN = 5;{ columns ( column defined in ps prefs, default = 2.5 inches)  }
+
 type
   TRGB = packed record
     Red, Green, Blue : Byte;
@@ -33,7 +165,7 @@ type
     L, a, b: byte;
   end;
 
-
+  { File Header Section }
   TPSDHeader = packed record
     Signature : array[0..3] of Char;   // File IDs '8BPS'
     Version : word;                    // Version number, always 1
@@ -42,70 +174,31 @@ type
     Rows : Cardinal;                   // Height of image in pixels (1-30000)
     Columns : Cardinal;                // Width of image in pixels (1-30000)
     Depth : Word;                      // Number of bits per channel (1, 8, and 16)
-    Mode: Word;                        // Color mode
+    Mode: Word;                        // Color mode (see previous  Image color modes consts)
   end;
-  {
-  Mode Description
-  0 Bitmap (monochrome)
-  1 Gray-scale
-  2 Indexed color (palette color)
-  3 RGB color
-  4 CMYK color
-  7 Multichannel color
-  8 Duotone (halftone)
-  9 Lab color
-  }
 
-  TColorModeDataBlock = packed record
+  { Image Resource Blocks }
+  TPSDResourceBlock = packed record
     Types : array[0..3] of Char;   // Always "8BIM"
-    ID:word;                       // (See table below)
+    ID:word;                       // see previous Image Resource IDs consts
-    Name:byte;                     // Even-length Pascal-format string, 2 bytes or longer
+    NameLen:Byte;                  // Pascal-format string, 2 bytes or longer
-    Size : Cardinal;               // Length of resource data following, in bytes
+    Name:Char;
-    Data:byte;                     // Resource data, padded to even length
   end;
-  {
+  PPSDResourceBlock =^TPSDResourceBlock;
-  ID Data Format Description
+
-  03e8 WORD[5] Channels, rows, columns, depth, and mode
+  TPSDResourceBlockData = packed record
-  03e9 Optional Macintosh print manager information
+    Size:LongWord;
-  03eb Indexed color table
+    Data:Byte;
-  03ed (See below) Resolution information
+  end;
-       "TResolutionInfo"
+  PPSDResourceBlockData =^TPSDResourceBlockData;
-  03ee BYTE[] Alpha channel names (Pascal-format strings)
+
-  03ef (See below) Display information for each channel
+  //MaxM: Resolution always recorded in a fixed point implied decimal int32
-       "TDisplayInfo"
+  //      with 16 bits before point and 16 after (cast as DWord and divide resolution by 2^16
-  03f0 BYTE[] Optional Pascal-format caption string
-  03f1 LONG, WORD Fixed-point border width, border units (see below)
-  03f2 Background color
-  03f3 BYTE[8] Print flags (see below)
-  03f4 Gray-scale and halftoning information
-  03f5 Color halftoning information
-  03f6 Duotone halftoning information
-  03f7 Gray-scale and multichannel transfer function
-  03f8 Color transfer functions
-  03f9 Duotone transfer functions
-  03fa Duotone image information
-  03fb BYTE[2] Effective black and white value for dot range
-  03fc
-  03fd EPS options
-  03fe WORD, BYTE Quick Mask channel ID, flag for mask initially empty
-  03ff
-  0400 WORD Index of target layer (0=bottom)
-  0401 Working path
-  0402 WORD[] Layers group info, group ID for dragging groups
-  0403
-  0404 IPTC-NAA record
-  0405 Image mode for raw-format files
-  0406 JPEG quality (Adobe internal)
-  07d0
-  0bb6 Saved path information
-  0bb7 Clipping pathname
-  2710 (See below) Print flags information
-  }
   TResolutionInfo = record
-    hRes:Cardinal;     // Fixed-point number: pixels per inch
+    hRes:Cardinal;     // Fixed-point number: pixels per inch  (see note before)
     hResUnit:word;     // 1=pixels per inch, 2=pixels per centimeter
     WidthUnit:word;    // 1=in, 2=cm, 3=pt, 4=picas, 5=columns
-    vRes:Cardinal;     // Fixed-point number: pixels per inch
+    vRes:Cardinal;     // Fixed-point number: pixels per inch  (see note before)
     vResUnit:word;     // 1=pixels per inch, 2=pixels per centimeter
     HeightUnit:word;   // 1=in, 2=cm, 3=pt, 4=picas, 5=columns
   end;
@@ -131,7 +224,6 @@ type
     FOnCreateImage: TPSDCreateCompatibleImgEvent;
   protected
     FHeader        : TPSDHeader;
-    FColorDataBlock: TColorModeDataBlock;
     FBytesPerPixel : Byte;
     FScanLine      : PByte;
     FLineSize      : PtrInt;
@@ -146,6 +238,8 @@ type
     procedure CreateBWPalette;
     function ReadPalette(Stream: TStream): boolean;
     procedure AnalyzeHeader;
+    procedure ReadResourceBlockData(Img: TFPCustomImage; blockID:Word;
+                                    blockName:ShortString; Size:LongWord; Data:Pointer); virtual;
     procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
     function ReadScanLine(Stream: TStream): boolean; virtual;
     procedure WriteScanLine(Img: TFPCustomImage); virtual;
@@ -233,37 +327,57 @@ end;
 
 function TFPReaderPSD.ReadPalette(Stream: TStream): boolean;
 Var
-  I : Integer;
-  c : TFPColor;
-  OldPos: Integer;
   BufSize:Longint;
-  PalBuf: array[0..767] of Byte;
+
-  ContProgress: Boolean;
+  procedure ReadPaletteFromStream;
+  var
+    i : Integer;
+    c : TFPColor;
+    {%H-}PalBuf: array[0..767] of Byte;
+    ContProgress: Boolean;
+
+  begin
+    Stream.Read({%H-}PalBuf, BufSize);
+    ContProgress:=true;
+    Progress(FPimage.psRunning, 0, False, Rect(0,0,0,0), '', ContProgress);
+    if not ContProgress then exit;
+    for i:=0 to BufSize div 3 do
+    begin
+      with c do
+      begin
+        Red:=PalBuf[I] shl 8;
+        Green:=PalBuf[I+(BufSize div 3)] shl 8;
+        Blue:=PalBuf[I+(BufSize div 3)* 2] shl 8;
+        Alpha:=alphaOpaque;
+      end;
+      FPalette.Add(c);
+    end;
+  end;
+
 begin
-  Result:=false;
+  Result:=False;
-  ThePalette.count := 0;
-  OldPos := Stream.Position;
   BufSize:=0;
   Stream.Read(BufSize, SizeOf(BufSize));
   BufSize:=BEtoN(BufSize);
-  Stream.Read(PalBuf, BufSize);
+
-  ContProgress:=true;
+  Case FHeader.Mode of
-  Progress(FPimage.psRunning, trunc(100.0 * (Stream.position / Stream.size)),
+  PSD_BITMAP :begin  // Bitmap (monochrome)
-           False, Rect(0,0,0,0), '', ContProgress);
+                FPalette := TFPPalette.Create(0);
-  if not ContProgress then exit;
+                CreateBWPalette;
-  For I:=0 To BufSize div 3 Do
+              end;
-  Begin
+  PSD_GRAYSCALE,
-    With c do
+  PSD_DUOTONE:begin // Gray-scale or Duotone image
-    begin
+                FPalette := TFPPalette.Create(0);
-      Red:=PalBuf[I] shl 8;
+                CreateGrayPalette;
-      Green:=PalBuf[I+(BufSize div 3)] shl 8;
+              end;
-      Blue:=PalBuf[I+(BufSize div 3)* 2] shl 8;
+  PSD_INDEXED:begin // Indexed color (palette color)
-      Alpha:=alphaOpaque;
+                FPalette := TFPPalette.Create(0);
-    end;
+                if (BufSize=0) then exit;
-    ThePalette.Add(C);
+                ReadPaletteFromStream;
-  End;
+              end;
-  Stream.Position := OldPos;
+  end;
-  Result:=true;
+
+  Result:=True;
 end;
 
 procedure TFPReaderPSD.AnalyzeHeader;
@@ -288,12 +402,76 @@ begin
   end;
 end;
 
+procedure TFPReaderPSD.ReadResourceBlockData(Img: TFPCustomImage; blockID: Word;
+                                             blockName: ShortString; Size: LongWord; Data: Pointer);
+begin
+end;
+
 procedure TFPReaderPSD.InternalRead(Stream: TStream; Img: TFPCustomImage);
 var
   H: Integer;
   BufSize:Cardinal;
   Encoding:word;
   ContProgress: Boolean;
+
+  procedure ReadResourceBlocks;
+  var
+     TotalBlockSize,
+     pPosition:LongWord;
+     blockData,
+     curBlock :PPSDResourceBlock;
+     curBlockData :PPSDResourceBlockData;
+     signature:String[4];
+     blockName:ShortString;
+     blockID:Word;
+     dataSize:LongWord;
+
+  begin
+    //MaxM: Do NOT Remove the Casts after BEToN
+    Stream.Read(TotalBlockSize, 4);
+    TotalBlockSize :=BEtoN(DWord(TotalBlockSize));
+    GetMem(blockData, TotalBlockSize);
+    try
+       Stream.Read(blockData^, TotalBlockSize);
+
+       pPosition :=0;
+       curBlock :=blockData;
+
+       repeat
+         signature :=curBlock^.Types;
+
+         if (signature=PSD_ResourceSectionSignature) then
+         begin
+           blockID :=BEtoN(Word(curBlock^.ID));
+           blockName :=curBlock^.Name;
+           setLength(blockName, curBlock^.NameLen);
+           curBlockData :=PPSDResourceBlockData(curBlock);
+
+           Inc(Pointer(curBlockData), sizeof(TPSDResourceBlock));
+
+           if (curBlock^.NameLen>0) then //MaxM: Maybe tested, in all my tests is always 0
+           begin
+             Inc(Pointer(curBlockData), curBlock^.NameLen);
+             if not(Odd(curBlock^.NameLen))
+             then Inc(Pointer(curBlockData), 1);
+           end;
+
+           dataSize :=BEtoN(DWord(curBlockData^.Size));
+           Inc(Pointer(curBlockData), 4);
+           ReadResourceBlockData(Img, blockID, blockName, dataSize, curBlockData);
+           Inc(Pointer(curBlockData), dataSize);
+         end
+         else Inc(Pointer(curBlockData), 1); //skip padding or something went wrong, search for next '8BIM'
+
+         curBlock :=PPSDResourceBlock(curBlockData);
+         pPosition :=Pointer(curBlockData)-Pointer(blockData);
+       until (pPosition >= TotalBlockSize);
+
+    finally
+      FreeMem(blockData, TotalBlockSize);
+    end;
+  end;
+
 begin
   FScanLine:=nil;
   FPalette:=nil;
@@ -307,35 +485,17 @@ begin
     Progress(FPimage.psRunning, trunc(100.0 * (Stream.position / Stream.size)), False, Rect(0,0,0,0), '', ContProgress);
     if not ContProgress then exit;
     AnalyzeHeader;
-    Case FHeader.Mode of
+
-        0:begin  // Bitmap (monochrome)
+    //  color palette
-            FPalette := TFPPalette.Create(0);
+    ReadPalette(Stream);
-            CreateBWPalette;
-          end;
-        1, 8:begin // Gray-scale
-            FPalette := TFPPalette.Create(0);
-            CreateGrayPalette;
-          end;
-        2:begin // Indexed color (palette color)
-            FPalette := TFPPalette.Create(0);
-            if not ReadPalette(stream) then exit;
-          end;
-    end;
 
     if Assigned(OnCreateImage) then
       OnCreateImage(Self,Img);
     Img.SetSize(FWidth,FHeight);
 
-    //  color palette
+    // Image Resources Section
-    BufSize:=0;
+    ReadResourceBlocks;
-    Stream.Read(BufSize, SizeOf(BufSize));
+
-    BufSize:=BEtoN(BufSize);
-    Stream.Seek(BufSize, soCurrent);
-    //  color data block
-    Stream.Read(BufSize, SizeOf(BufSize));
-    BufSize:=BEtoN(BufSize);
-    Stream.Read(FColorDataBlock, SizeOf(FColorDataBlock));
-    Stream.Seek(BufSize-SizeOf(FColorDataBlock), soCurrent);
     //  mask
     Stream.Read(BufSize, SizeOf(BufSize));
     BufSize:=BEtoN(BufSize);

packages/fcl-image/src/fpwritejpeg.pas

@@ -13,6 +13,10 @@
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation, Inc.,
   51 Franklin Street, Fifth Floor, Boston, MA 02111-1301, USA.
+
+  2023-07  - Massimo Magnano
+           - procedure inside InternalWrite moved to protected methods (virtual)
+
 }
 unit FPWriteJPEG;
 
@@ -31,14 +35,16 @@ type
 
   TFPWriterJPEG = class(TFPCustomImageWriter)
   private
-    FGrayscale: boolean;
+    FGrayscale,   Continue: Boolean;
     FInfo: jpeg_compress_struct;
     FError: jpeg_error_mgr;
     FProgressiveEncoding: boolean;
     FQuality: TFPJPEGCompressionQuality;
     FProgressMgr: TFPJPEGProgressManager;
   protected
-    procedure InitWriting; virtual;
+    procedure InitWriting(Str: TStream; Img: TFPCustomImage); virtual;
+    procedure WriteHeader(Str: TStream; Img: TFPCustomImage); virtual;
+    procedure WritePixels(Str: TStream; Img: TFPCustomImage); virtual;
     procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override;
     property CompressInfo : jpeg_compress_struct Read FInfo Write FInfo;
   public
@@ -98,7 +104,7 @@ end;
 { TFPWriterJPEG }
 
 
-procedure TFPWriterJPEG.InitWriting;
+procedure TFPWriterJPEG.InitWriting(Str: TStream; Img: TFPCustomImage);
 begin
   FError := jpeg_std_error;
   FInfo := Default(jpeg_compress_struct);
@@ -107,13 +113,76 @@ begin
   FInfo.progress := @FProgressMgr.pub;
   FProgressMgr.pub.progress_monitor := @ProgressCallback;
   FProgressMgr.instance := Self;
+end;
 
+procedure TFPWriterJPEG.WriteHeader(Str: TStream; Img: TFPCustomImage);
+begin
+  FInfo.image_width := Img.Width;
+  FInfo.image_height := Img.Height;
+  if FGrayscale then
+  begin
+    FInfo.input_components := 1;
+    FInfo.in_color_space := JCS_GRAYSCALE;
+  end
+  else
+  begin
+    FInfo.input_components := 3; // RGB has 3 components
+    FInfo.in_color_space := JCS_RGB;
+  end;
+
+  jpeg_set_defaults(@FInfo);
+  jpeg_set_quality(@FInfo, FQuality, True);
+
+  if ProgressiveEncoding then
+    jpeg_simple_progression(@FInfo);
+end;
+
+procedure TFPWriterJPEG.WritePixels(Str: TStream; Img: TFPCustomImage);
+var
+  LinesWritten: Cardinal;
+  SampArray: JSAMPARRAY;
+  SampRow: JSAMPROW;
+  Color: TFPColor;
+  x: Integer;
+  y: Integer;
+begin
+  Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue);
+  if not Continue then exit;
+  jpeg_start_compress(@FInfo, True);
+
+  // write one line per call
+  GetMem(SampArray,SizeOf(JSAMPROW));
+  GetMem(SampRow,FInfo.image_width*FInfo.input_components);
+  SampArray^[0]:=SampRow;
+  try
+    y:=0;
+    while (FInfo.next_scanline < FInfo.image_height) do begin
+      if FGrayscale then
+      for x:=0 to FInfo.image_width-1 do
+        SampRow^[x]:=CalculateGray(Img.Colors[x,y]) shr 8
+      else
+      for x:=0 to FInfo.image_width-1 do begin
+        Color:=Img.Colors[x,y];
+        SampRow^[x*3+0]:=Color.Red shr 8;
+        SampRow^[x*3+1]:=Color.Green shr 8;
+        SampRow^[x*3+2]:=Color.Blue shr 8;
+      end;
+      LinesWritten := jpeg_write_scanlines(@FInfo, SampArray, 1);
+      if LinesWritten<1 then break;
+      inc(y);
+    end;
+  finally
+    FreeMem(SampRow);
+    FreeMem(SampArray);
+  end;
+
+  jpeg_finish_compress(@FInfo);
+  Progress(psEnding, 100, False, Rect(0,0,0,0), '', Continue);
 end;
 
 procedure TFPWriterJPEG.InternalWrite(Str: TStream; Img: TFPCustomImage);
 var
   MemStream: TMemoryStream;
-  Continue: Boolean;
 
   procedure SetDestination;
   begin
@@ -124,71 +193,6 @@ var
     jpeg_stdio_dest(@FInfo, @MemStream);
   end;
 
-  procedure WriteHeader;
-  begin
-    FInfo.image_width := Img.Width;
-    FInfo.image_height := Img.Height;
-    if FGrayscale then
-    begin
-      FInfo.input_components := 1;
-      FInfo.in_color_space := JCS_GRAYSCALE;
-    end
-    else
-    begin
-      FInfo.input_components := 3; // RGB has 3 components
-      FInfo.in_color_space := JCS_RGB;
-    end;
-
-    jpeg_set_defaults(@FInfo);
-    jpeg_set_quality(@FInfo, FQuality, True);
-
-    if ProgressiveEncoding then
-      jpeg_simple_progression(@FInfo);
-  end;
-
-  procedure WritePixels;
-  var
-    LinesWritten: Cardinal;
-    SampArray: JSAMPARRAY;
-    SampRow: JSAMPROW;
-    Color: TFPColor;
-    x: Integer;
-    y: Integer;
-  begin
-    Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue);
-    if not Continue then exit;
-    jpeg_start_compress(@FInfo, True);
-
-    // write one line per call
-    GetMem(SampArray,SizeOf(JSAMPROW));
-    GetMem(SampRow,FInfo.image_width*FInfo.input_components);
-    SampArray^[0]:=SampRow;
-    try
-      y:=0;
-      while (FInfo.next_scanline < FInfo.image_height) do begin
-        if FGrayscale then
-        for x:=0 to FInfo.image_width-1 do
-          SampRow^[x]:=CalculateGray(Img.Colors[x,y]) shr 8
-        else
-        for x:=0 to FInfo.image_width-1 do begin
-          Color:=Img.Colors[x,y];
-          SampRow^[x*3+0]:=Color.Red shr 8;
-          SampRow^[x*3+1]:=Color.Green shr 8;
-          SampRow^[x*3+2]:=Color.Blue shr 8;
-        end;
-        LinesWritten := jpeg_write_scanlines(@FInfo, SampArray, 1);
-        if LinesWritten<1 then break;
-        inc(y);
-      end;
-    finally
-      FreeMem(SampRow);
-      FreeMem(SampArray);
-    end;
-
-    jpeg_finish_compress(@FInfo);
-    Progress(psEnding, 100, False, Rect(0,0,0,0), '', Continue);
-  end;
-
   procedure EndWriting;
   begin
     jpeg_destroy_compress(@FInfo);
@@ -198,10 +202,10 @@ begin
   Continue := true;
   MemStream:=nil;
   try
-    InitWriting;
+    InitWriting(Str, Img);
     SetDestination;
-    WriteHeader;
+    WriteHeader(MemStream, Img);
-    WritePixels;
+    WritePixels(MemStream, Img);
     if MemStream<>Str then begin
       MemStream.Position:=0;
       Str.CopyFrom(MemStream,MemStream.Size);