{

This is a modification of FPReadJPEG.pas, to read JPEG-Streams into TCanvasOPBitmaps
 - mitjastachowiak.de -

}



unit JPEGtoOPBitmap;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, JPEGLib, JdAPImin, JDataSrc, JdAPIstd, JmoreCfg, OPBitmap, ColorTools, Dialogs;

type
  TJPEGScale = (jsFullSize, jsHalf, jsQuarter, jsEighth);
  TJPEGReadPerformance = (jpBestQuality, jpBestSpeed);
  TJPEGReader = class
   type
    TPixCast = Array [0..1] of BGRAColor;
    PPixCast = ^TPixCast;
   private
    FSmoothing: boolean;
    FMinHeight:integer;
    FMinWidth:integer;
    FWidth: Integer;
    FHeight: Integer;
    FGrayscale: boolean;
    FProgressiveEncoding: boolean;
    FError: jpeg_error_mgr;
    FInfo: jpeg_decompress_struct;
    FScale: TJPEGScale;
    FPerformance: TJPEGReadPerformance;
   public
    constructor Create;
    procedure ReadToOPBitmap(MemStream: TMemoryStream; Img: TCanvasOPBitmap);
  end;

implementation

procedure JPEGError(CurInfo: j_common_ptr);
begin
  if CurInfo=nil then exit;
  raise Exception.CreateFmt('JPEG error',[CurInfo^.err^.msg_code]);
end;

procedure EmitMessage(CurInfo: j_common_ptr; msg_level: Integer);
begin
  if CurInfo=nil then exit;
  if msg_level=0 then ;
end;

procedure OutputMessage(CurInfo: j_common_ptr);
begin
  if CurInfo=nil then exit;
end;

procedure FormatMessage(CurInfo: j_common_ptr; var buffer: string);
begin
  if CurInfo=nil then exit;
  {$ifdef FPC_Debug_Image}
     writeln('FormatMessage ',buffer);
  {$endif}
end;

procedure ResetErrorMgr(CurInfo: j_common_ptr);
begin
  if CurInfo=nil then exit;
  CurInfo^.err^.num_warnings := 0;
  CurInfo^.err^.msg_code := 0;
end;

var
  jpeg_std_error: jpeg_error_mgr;




constructor TJPEGReader.Create;
begin
 FScale:=jsFullSize;
 FPerformance:=jpBestSpeed;
 inherited Create;
end;

procedure TJPEGReader.ReadToOPBitmap(MemStream: TMemoryStream; Img: TCanvasOPBitmap);
var lines : Array of TJPEGReader.PPixCast;

  procedure SetSource;
  begin
    MemStream.Position:=0;
    jpeg_stdio_src(@FInfo, @MemStream);
  end;

  procedure ReadHeader;
  begin
    jpeg_read_header(@FInfo, TRUE);
    FWidth := FInfo.image_width;
    FHeight := FInfo.image_height;
    FGrayscale := FInfo.jpeg_color_space = JCS_GRAYSCALE;
    FProgressiveEncoding := jpeg_has_multiple_scans(@FInfo);
  end;

  procedure InitReadingPixels;
  var d1,d2:integer;

    function DToScale(inp:integer):TJPEGScale;
    begin
      if inp>7 then Result:=jsEighth else
      if inp>3 then Result:=jsQuarter else
      if inp>1 then Result:=jsHalf else
      Result:=jsFullSize;
    end;

  begin
    FInfo.scale_num := 1;

    if (FMinWidth>0) and (FMinHeight>0) then
      if (FInfo.image_width>FMinWidth) or (FInfo.image_height>FMinHeight) then
        begin
        d1:=Round((FInfo.image_width / FMinWidth)-0.5);
        d2:=Round((FInfo.image_height /  FMinHeight)-0.5);
        if d1>d2 then fScale:=DToScale(d2) else fScale:=DtoScale(d1);
        end;

    FInfo.scale_denom :=1 shl Byte(FScale); //1
    FInfo.do_block_smoothing := FSmoothing;

    if FGrayscale then FInfo.out_color_space := JCS_GRAYSCALE;
    if (FInfo.out_color_space = JCS_GRAYSCALE) then
      begin
      FInfo.quantize_colors := True;
      FInfo.desired_number_of_colors := 236;
      end;

    if FPerformance = jpBestSpeed then
      begin
      FInfo.dct_method := JDCT_IFAST;
      FInfo.two_pass_quantize := False;
      FInfo.dither_mode := JDITHER_ORDERED;
      // FInfo.do_fancy_upsampling := False;  can create an AV inside jpeglib
      end;

    if FProgressiveEncoding then
      begin
      FInfo.enable_2pass_quant := FInfo.two_pass_quantize;
      FInfo.buffered_image := True;
      end;
  end;

  function CorrectCMYK(const C: BGRAColor): BGRAColor; inline;
  var
    MinColor: word;
  begin
    // accuracy not 100%
    if C.r<C.g then MinColor:=C.r
    else MinColor:= C.g;
    if C.b<MinColor then MinColor:= C.b;
    if MinColor+ C.a>$FF then MinColor:=$FF-C.a;
    Result.r:=(C.r-MinColor);
    Result.g:=(C.g-MinColor);
    Result.b:=(C.b-MinColor);
    Result.a:=alphaOpaque;
  end;
  function CorrectYCCK(const C: BGRAColor): BGRAColor; inline;
  var
    MinColor: word;
  begin
    if C.r<C.g then MinColor:=C.r
    else MinColor:= C.g;
    if C.b<MinColor then MinColor:= C.b;
    if MinColor+ C.a>$FF then MinColor:=$FF-C.a;
    Result.r:=(C.r-MinColor);
    Result.g:=(C.g-MinColor);
    Result.b:=(C.b-MinColor);
    Result.a:=alphaOpaque;
  end;
  procedure ReadPixels;
  var
    Continue: Boolean;
    SampArray: JSAMPARRAY;
    SampRow: JSAMPROW;
    Color: BGRAColor;
    LinesRead: Cardinal;
    x: Integer;
    y: Integer;
    c: word;
    Status,Scan: integer;
    ReturnValue,RestartLoop: Boolean;
    procedure OutputScanLines();
    var
      x: integer;
    begin
      Color.A:=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.R:=SampRow^[x*4+0];
          Color.G:=SampRow^[x*4+1];
          Color.B:=SampRow^[x*4+2];
          Color.a:=SampRow^[x*4+3];
          lines[y]^[x]:=CorrectCMYK(Color);
        end
        else
        if (FInfo.jpeg_color_space = JCS_YCCK) then
        for x:=0 to FInfo.output_width-1 do begin
          Color.R:=SampRow^[x*4+0];
          Color.G:=SampRow^[x*4+1];
          Color.B:=SampRow^[x*4+2];
          Color.a:=SampRow^[x*4+3];
          lines[y]^[x]:=CorrectYCCK(Color);
        end
        else
        if fgrayscale then begin
         for x:=0 to FInfo.output_width-1 do begin
           c:= SampRow^[x];
           Color.R:=c;
           Color.G:=c;
           Color.B:=c;
           lines[y]^[x]:=Color;
         end;
        end
        else begin
         for x:=0 to FInfo.output_width-1 do begin
           Color.R:=SampRow^[x*3+0];
           Color.G:=SampRow^[x*3+1];
           Color.B:=SampRow^[x*3+2];
           lines[y]^[x]:=Color;
         end;
        end;
        inc(y);
      end;
    end;
  begin
    InitReadingPixels;

    Continue:=true;
    if not Continue then exit;

    jpeg_start_decompress(@FInfo);

    Img.Width := FInfo.output_width;
    Img.Height := FInfo.output_height;
    SetLength(lines, FInfo.output_height);
    for y := 0 to FInfo.output_height-1 do lines[y] := img.ScanLine[y];

    GetMem(SampArray,SizeOf(JSAMPROW));
    GetMem(SampRow,FInfo.output_width*FInfo.output_components);
    SampArray^[0]:=SampRow;
    try
      case FProgressiveEncoding of
        false:
          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;
              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
                  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 = FInfo.output_height) then begin
                    if not jpeg_finish_output(@FInfo) then begin
                      RestartLoop:=true; (* I/O suspension *)
                    end;

                    if not RestartLoop then begin
                      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
                (* Suspension mode, but as not supported by this implementation
                   it will simple break the loop to avoid endless looping. *)
                break;
              end;
            end;
          end;
      end;
    finally
      FreeMem(SampRow);
      FreeMem(SampArray);
    end;

    jpeg_finish_decompress(@FInfo);

  end;

begin
  FWidth:=0;
  FHeight:=0;
  MemStream.Position:=0;
  FillChar(FInfo,SizeOf(FInfo),0);
  try
    if MemStream.Size > 0 then begin
      FError:=jpeg_std_error;
      FInfo.err := @FError;
      jpeg_CreateDecompress(@FInfo, JPEG_LIB_VERSION, SizeOf(FInfo));
      try
        SetSource;
        ReadHeader;
        ReadPixels;
      finally
        jpeg_Destroy_Decompress(@FInfo);
      end;
    end;
  finally
  end;
end;

initialization
  with jpeg_std_error do begin
    error_exit:=@JPEGError;
    emit_message:=@EmitMessage;
    output_message:=@OutputMessage;
    format_message:=@FormatMessage;
    reset_error_mgr:=@ResetErrorMgr;
  end;

end.