+ Added jpeg support via jpeglib

fcl/image/Makefile

@@ -1,8 +1,8 @@
 #
-# Don't edit, this file is generated by FPCMake Version 1.1 [2004/01/05]
+# Don't edit, this file is generated by FPCMake Version 1.1 [2003/09/24]
 #
 default: all
-MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom
+MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx
 override PATH:=$(subst \,/,$(PATH))
 ifeq ($(findstring ;,$(PATH)),)
 inUnix=1
@@ -10,7 +10,6 @@ SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH)))
 else
 SEARCHPATH:=$(subst ;, ,$(PATH))
 endif
-SEARCHPATH+=$(patsubst %/,%,$(subst \,/,$(dir $(MAKE))))
 PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(SEARCHPATH))))
 ifeq ($(PWD),)
 PWD:=$(strip $(wildcard $(addsuffix /pwd,$(SEARCHPATH))))
@@ -205,7 +204,7 @@ UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
 endif
 PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
 override PACKAGE_NAME=fcl
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm  ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg.pas fpwritejpeg.pas ellipses
 ifeq ($(OS_TARGET),linux)
 override TARGET_UNITS+=freetypeh freetype ftfont
 endif
@@ -301,17 +300,9 @@ endif
 endif
 ifndef INSTALL_BINDIR
 ifdef UNIXINSTALLDIR
-ifdef CROSSCOMPILE
-INSTALL_BINDIR:=$(INSTALL_BASEDIR)/cross/$(FULL_TARGET)/bin
-else
 INSTALL_BINDIR:=$(INSTALL_PREFIX)/bin
-endif
-else
-ifdef CROSSCOMPILE
-INSTALL_BINDIR:=$(INSTALL_BASEDIR)/cross/$(FULL_TARGET)/bin
 else
 INSTALL_BINDIR:=$(INSTALL_BASEDIR)/bin
-endif
 ifdef INSTALL_FPCPACKAGE
 INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(OS_TARGET)
 endif
@@ -443,14 +434,6 @@ STATICLIBPREFIX=
 FPCMADE=fpcmade.dos
 ZIPSUFFIX=go32
 endif
-ifeq ($(OS_TARGET),watcom)
-STATICLIBPREFIX=
-FPCMADE=fpcmade.wat
-ZIPSUFFIX=watc
-OEXT=.obj
-ASMEXT=.asm
-SHAREDLIBEXT=.dll
-endif
 ifeq ($(OS_TARGET),linux)
 EXEEXT=
 HASSHAREDLIB=1
@@ -553,11 +536,6 @@ STATICLIBPREFIX=
 FPCMADE=fpcmade.dos
 ZIPSUFFIX=go32
 endif
-ifeq ($(OS_TARGET),watcom)
-STATICLIBPREFIX=
-FPCMADE=fpcmade.dos
-ZIPSUFFIX=watcom
-endif
 ifeq ($(OS_TARGET),linux)
 EXEEXT=
 HASSHAREDLIB=1
@@ -746,11 +724,7 @@ endif
 endif
 export MVPROG
 ifndef ECHOREDIR
-ifndef inUnix
+ECHOREDIR:=$(subst /,$(PATHSEP),$(ECHO))
-ECHOREDIR=echo
-else
-ECHOREDIR=$(ECHO)
-endif
 endif
 ifndef COPY
 COPY:=$(CPPROG) -fp
@@ -821,16 +795,14 @@ TARPROG:=$(firstword $(TARPROG))
 endif
 endif
 export TARPROG
-ASNAME=$(BINUTILSPREFIX)as
-LDNAME=$(BINUTILSPREFIX)ld
-ARNAME=$(BINUTILSPREFIX)ar
-RCNAME=$(BINUTILSPREFIX)rc
-ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
-ifeq ($(OS_TARGET),win32)
 ASNAME=as
 LDNAME=ld
 ARNAME=ar
-endif
+RCNAME=rc
+ifeq ($(OS_TARGET),win32)
+ASNAME=asw
+LDNAME=ldw
+ARNAME=arw
 endif
 ifndef ASPROG
 ifdef CROSSBINDIR
@@ -982,18 +954,6 @@ REQUIRE_PACKAGES_RTL=1
 REQUIRE_PACKAGES_PASZLIB=1
 endif
 endif
-ifeq ($(OS_TARGET),netbsd)
-ifeq ($(CPU_TARGET),powerpc)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-endif
-endif
-ifeq ($(OS_TARGET),netbsd)
-ifeq ($(CPU_TARGET),sparc)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-endif
-endif
 ifeq ($(OS_TARGET),amiga)
 ifeq ($(CPU_TARGET),m68k)
 REQUIRE_PACKAGES_RTL=1
@@ -1072,12 +1032,6 @@ REQUIRE_PACKAGES_RTL=1
 REQUIRE_PACKAGES_PASZLIB=1
 endif
 endif
-ifeq ($(OS_TARGET),watcom)
-ifeq ($(CPU_TARGET),i386)
-REQUIRE_PACKAGES_RTL=1
-REQUIRE_PACKAGES_PASZLIB=1
-endif
-endif
 ifdef REQUIRE_PACKAGES_RTL
 PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/$(OS_TARGET)/Makefile.fpc,$(PACKAGESDIR))))))
 ifneq ($(PACKAGEDIR_RTL),)
@@ -1139,14 +1093,6 @@ endif
 ifeq ($(OS_SOURCE),openbsd)
 override FPCOPT+=-FD$(NEW_BINUTILS_PATH)
 endif
-ifndef CROSSBOOTSTRAP
-ifneq ($(BINUTILSPREFIX),)
-override FPCOPT+=-XP$(BINUTILSPREFIX) -Xc
-endif
-ifneq ($(BINUTILSPREFIX),)
-override FPCOPT+=-Xr$(RLINKPATH)
-endif
-endif
 ifdef UNITDIR
 override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
 endif
@@ -1271,7 +1217,7 @@ endif
 .PHONY: fpc_examples
 ifdef TARGET_EXAMPLES
 HASEXAMPLES=1
-override EXAMPLESOURCEFILES:=$(wildcard $(addsuffix .pp,$(TARGET_EXAMPLES)) $(addsuffix .pas,$(TARGET_EXAMPLES)) $(addsuffix .dpr,$(TARGET_EXAMPLES)))
+override EXAMPLESOURCEFILES:=$(wildcard $(addsuffix .pp,$(TARGET_EXAMPLES)) $(addsuffix .pas,$(TARGET_EXAMPLES)))
 override EXAMPLEFILES:=$(addsuffix $(EXEEXT),$(TARGET_EXAMPLES))
 override EXAMPLEOFILES:=$(addsuffix $(OEXT),$(TARGET_EXAMPLES)) $(addprefix $(STATICLIBPREFIX),$(addsuffix $(STATICLIBEXT),$(TARGET_EXAMPLES)))
 override CLEANEXEFILES+=$(EXAMPLEFILES) $(EXAMPLEOFILES)
@@ -1296,7 +1242,7 @@ fpc_debug:
 	$(MAKE) all DEBUG=1
 fpc_release:
 	$(MAKE) all RELEASE=1
-.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .dpr .pp .rc .res
+.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp .rc .res
 %$(PPUEXT): %.pp
 	$(COMPILER) $<
 	$(EXECPPAS)
@@ -1309,14 +1255,10 @@ fpc_release:
 %$(EXEEXT): %.pas
 	$(COMPILER) $<
 	$(EXECPPAS)
-%$(EXEEXT): %.dpr
-	$(COMPILER) $<
-	$(EXECPPAS)
 %.res: %.rc
 	windres -i $< -o $@
 vpath %.pp $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
 vpath %.pas $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
-vpath %.dpr $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
 vpath %$(PPUEXT) $(COMPILER_UNITTARGETDIR)
 .PHONY: fpc_install fpc_sourceinstall fpc_exampleinstall
 ifdef INSTALL_UNITS

fcl/image/Makefile.fpc

@@ -11,7 +11,7 @@ packages=paszlib
 [target]
 units=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm \
       clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp \
-      fpreadbmp bmpcomn fpreadpnm fpwritepnm  \
+      fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg.pas fpwritejpeg.pas \
       ellipses
 units_win32=freetypeh freetype ftfont
 units_linux=freetypeh freetype ftfont

fcl/image/fpreadjpeg.pas

@@ -0,0 +1,317 @@
+{ Copyright (C) 2003 Mattias Gaertner
+
+  This library is free software; you can redistribute it and/or modify it
+  under the terms of the GNU Library General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or (at your
+  option) any later version.
+
+  This program is distributed in the hope that it will be useful, but WITHOUT
+  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+  for more details.
+
+  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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+  ToDo:
+    - grayscale
+    - palette
+}
+unit FPReadJPEG;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FPImage, JPEGLib, JdAPImin, JDataSrc, JdAPIstd, JmoreCfg;
+
+type
+  { TFPReaderJPEG }
+  { This is a FPImage reader for jpeg images. }
+  
+  TFPReaderJPEG = class;
+
+  PFPJPEGProgressManager = ^TFPJPEGProgressManager;
+  TFPJPEGProgressManager = record
+    pub : jpeg_progress_mgr;
+    instance: TObject;
+    last_pass: Integer;
+    last_pct: Integer;
+    last_time: Integer;
+    last_scanline: Integer;
+  end;
+
+  TJPEGScale = (jsFullSize, jsHalf, jsQuarter, jsEighth);
+  TJPEGReadPerformance = (jpBestQuality, jpBestSpeed);
+
+  TFPReaderJPEG = class(TFPCustomImageReader)
+  private
+    FSmoothing: boolean;
+    FWidth: Integer;
+    FHeight: Integer;
+    FGrayscale: boolean;
+    FProgressiveEncoding: boolean;
+    FError: jpeg_error_mgr;
+    FProgressMgr: TFPJPEGProgressManager;
+    FInfo: jpeg_decompress_struct;
+    FScale: TJPEGScale;
+    FPerformance: TJPEGReadPerformance;
+    procedure SetPerformance(const AValue: TJPEGReadPerformance);
+    procedure SetSmoothing(const AValue: boolean);
+  protected
+    procedure InternalRead(Str: TStream; Img: TFPCustomImage); override;
+    function  InternalCheck(Str: TStream): boolean; override;
+  public
+    constructor Create; override;
+    destructor Destroy; override;
+    property GrayScale: boolean read FGrayscale;
+    property ProgressiveEncoding: boolean read FProgressiveEncoding;
+    property Smoothing: boolean read FSmoothing write SetSmoothing;
+    property Performance: TJPEGReadPerformance read FPerformance write SetPerformance;
+  end;
+
+implementation
+
+procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
+                                     StartSize: integer);
+var
+  NewLength: Integer;
+  ReadLen: Integer;
+  Buffer: string;
+begin
+  if (SrcStream is TMemoryStream) or (SrcStream is TFileStream)
+  or (SrcStream is TStringStream)
+  then begin
+    // read as one block
+    DestStream.CopyFrom(SrcStream,SrcStream.Size-SrcStream.Position);
+  end else begin
+    // read exponential
+    if StartSize<=0 then StartSize:=1024;
+    SetLength(Buffer,StartSize);
+    NewLength:=0;
+    repeat
+      ReadLen:=SrcStream.Read(Buffer[NewLength+1],length(Buffer)-NewLength);
+      inc(NewLength,ReadLen);
+      if NewLength<length(Buffer) then break;
+      SetLength(Buffer,length(Buffer)*2);
+    until false;
+    if NewLength>0 then
+      DestStream.Write(Buffer[1],NewLength);
+  end;
+end;
+
+procedure JPEGError(CurInfo: j_common_ptr);
+begin
+  if CurInfo=nil then exit;
+  writeln('JPEGError ',CurInfo^.err^.msg_code,' ');
+  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;
+  writeln('FormatMessage ',buffer);
+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;
+
+procedure ProgressCallback(CurInfo: j_common_ptr);
+begin
+  if CurInfo=nil then exit;
+  // ToDo
+end;
+
+{ TFPReaderJPEG }
+
+procedure TFPReaderJPEG.SetSmoothing(const AValue: boolean);
+begin
+  if FSmoothing=AValue then exit;
+  FSmoothing:=AValue;
+end;
+
+procedure TFPReaderJPEG.SetPerformance(const AValue: TJPEGReadPerformance);
+begin
+  if FPerformance=AValue then exit;
+  FPerformance:=AValue;
+end;
+
+procedure TFPReaderJPEG.InternalRead(Str: TStream; Img: TFPCustomImage);
+var
+  MemStream: TMemoryStream;
+  
+  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;
+  begin
+    FInfo.scale_num := 1;
+    FInfo.scale_denom := 1;// shl Byte(FScale);
+    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;
+  
+  procedure ReadPixels;
+  var
+    Continue: Boolean;
+    SampArray: JSAMPARRAY;
+    SampRow: JSAMPROW;
+    Color: TFPColor;
+    LinesRead: Cardinal;
+    x: Integer;
+    y: Integer;
+  begin
+    InitReadingPixels;
+    
+    Continue:=true;
+    Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue);
+    if not Continue then exit;
+    
+    jpeg_start_decompress(@FInfo);
+    
+    Img.SetSize(FInfo.output_width,FInfo.output_height);
+
+    // read one line per call
+    GetMem(SampArray,SizeOf(JSAMPROW));
+    GetMem(SampRow,FInfo.output_width*FInfo.output_components);
+    SampArray^[0]:=SampRow;
+    try
+      Color.Alpha:=alphaOpaque;
+      y:=0;
+      while (FInfo.output_scanline < FInfo.output_height) do begin
+        LinesRead := jpeg_read_scanlines(@FInfo, SampArray, 1);
+        if LinesRead<1 then break;
+        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;
+          Img.Colors[x,y]:=Color;
+        end;
+        inc(y);
+      end;
+    finally
+      FreeMem(SampRow);
+      FreeMem(SampArray);
+    end;
+
+    if FInfo.buffered_image then jpeg_finish_output(@FInfo);
+    jpeg_finish_decompress(@FInfo);
+
+    Progress(psEnding, 100, false, Rect(0,0,0,0), '', Continue);
+  end;
+  
+begin
+  FWidth:=0;
+  FHeight:=0;
+  MemStream:=nil;
+  FillChar(FInfo,SizeOf(FInfo),0);
+  try
+    if Str is TMemoryStream then
+      MemStream:=TMemoryStream(Str)
+    else begin
+      MemStream:=TMemoryStream.Create;
+      ReadCompleteStreamToStream(Str,MemStream,1024);
+      MemStream.Position:=0;
+    end;
+    if MemStream.Size > 0 then begin
+      FError:=jpeg_std_error;
+      FInfo.err := @FError;
+      jpeg_CreateDecompress(@FInfo, JPEG_LIB_VERSION, SizeOf(FInfo));
+      try
+        FProgressMgr.pub.progress_monitor := @ProgressCallback;
+        FProgressMgr.instance := Self;
+        FInfo.progress := @FProgressMgr;
+        SetSource;
+        ReadHeader;
+        ReadPixels;
+      finally
+        jpeg_Destroy_Decompress(@FInfo);
+      end;
+    end;
+  finally
+    if (MemStream<>nil) and (MemStream<>Str) then
+      MemStream.Free;
+  end;
+end;
+
+function TFPReaderJPEG.InternalCheck(Str: TStream): boolean;
+begin
+  // ToDo: read header and check
+  Result:=false;
+  if Str=nil then exit;
+  Result:=true;
+end;
+
+constructor TFPReaderJPEG.Create;
+begin
+  FScale:=jsFullSize;
+  FPerformance:=jpBestSpeed;
+  inherited Create;
+end;
+
+destructor TFPReaderJPEG.Destroy;
+begin
+  inherited Destroy;
+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.
+

fcl/image/fpwritejpeg.pas

@@ -0,0 +1,220 @@
+{ Copyright (C) 2003 Mattias Gaertner
+
+  This library is free software; you can redistribute it and/or modify it
+  under the terms of the GNU Library General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or (at your
+  option) any later version.
+
+  This program is distributed in the hope that it will be useful, but WITHOUT
+  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+  for more details.
+
+  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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+unit FPWriteJPEG;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FPImage, JPEGLib, FPReadJPEG, JcAPIstd, JcAPImin, JDataDst,
+  JcParam, JError;
+  
+type
+  { TFPWriterJPEG }
+  
+  TFPJPEGCompressionQuality = 1..100;   // 100 = best quality, 25 = pretty awful
+
+  TFPWriterJPEG = class(TFPCustomImageWriter)
+  private
+    FGrayscale: boolean;
+    FInfo: jpeg_compress_struct;
+    FError: jpeg_error_mgr;
+    FProgressiveEncoding: boolean;
+    FQuality: TFPJPEGCompressionQuality;
+    FProgressMgr: TFPJPEGProgressManager;
+  protected
+    procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override;
+  public
+    constructor Create; override;
+    destructor Destroy; override;
+    property CompressionQuality: TFPJPEGCompressionQuality read FQuality write FQuality;
+    property ProgressiveEncoding: boolean read FProgressiveEncoding write FProgressiveEncoding;
+    property GrayScale: boolean read FGrayscale;
+  end;
+
+implementation
+
+procedure JPEGError(CurInfo: j_common_ptr);
+begin
+  if CurInfo=nil then exit;
+  writeln('JPEGError ',CurInfo^.err^.msg_code,' ');
+  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;
+  writeln('FormatMessage ',buffer);
+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;
+
+procedure ProgressCallback(CurInfo: j_common_ptr);
+begin
+  if CurInfo=nil then exit;
+  // ToDo
+end;
+
+{ TFPWriterJPEG }
+
+procedure TFPWriterJPEG.InternalWrite(Str: TStream; Img: TFPCustomImage);
+var
+  MemStream: TMemoryStream;
+  Continue: Boolean;
+
+  procedure InitWriting;
+  begin
+    FillChar(FInfo, sizeof(FInfo), 0);
+    FError := jpeg_std_error;
+    FInfo.err := jerror.jpeg_std_error(FError);
+
+    jpeg_create_compress(@FInfo);
+    FProgressMgr.pub.progress_monitor := @ProgressCallback;
+    FProgressMgr.instance := Self;
+    FInfo.progress := @FProgressMgr;
+  end;
+  
+  procedure SetDestination;
+  begin
+    if Str is TMemoryStream then
+      MemStream:=TMemoryStream(Str)
+    else
+      MemStream := TMemoryStream.Create;
+    jpeg_stdio_dest(@FInfo, @MemStream);
+  end;
+  
+  procedure WriteHeader;
+  begin
+    FInfo.image_width := Img.Width;
+    FInfo.image_height := Img.Height;
+    FInfo.input_components := 3; // RGB has 3 components
+    FInfo.in_color_space := JCS_RGB;
+    if FGrayscale then
+      jpeg_set_colorspace(@FInfo, JCS_GRAYSCALE);
+
+    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
+        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);
+  end;
+
+begin
+  Continue := true;
+  MemStream:=nil;
+  try
+    InitWriting;
+    SetDestination;
+    WriteHeader;
+    WritePixels;
+    if MemStream<>Str then begin
+      MemStream.Position:=0;
+      Str.CopyFrom(MemStream,MemStream.Size);
+    end;
+  finally
+    EndWriting;
+    if MemStream<>Str then
+      MemStream.Free;
+  end;
+end;
+
+constructor TFPWriterJPEG.Create;
+begin
+  inherited Create;
+  FQuality:=75;
+end;
+
+destructor TFPWriterJPEG.Destroy;
+begin
+  inherited Destroy;
+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.
+