From 32e3cf93ee4df5b80009ecf1d51facb154d5ee39 Mon Sep 17 00:00:00 2001 From: michael Date: Sat, 7 Feb 2004 23:17:59 +0000 Subject: [PATCH] + Added jpeg support via jpeglib --- fcl/image/Makefile | 80 ++-------- fcl/image/Makefile.fpc | 2 +- fcl/image/fpreadjpeg.pas | 317 ++++++++++++++++++++++++++++++++++++++ fcl/image/fpwritejpeg.pas | 220 ++++++++++++++++++++++++++ 4 files changed, 549 insertions(+), 70 deletions(-) create mode 100644 fcl/image/fpreadjpeg.pas create mode 100644 fcl/image/fpwritejpeg.pas diff --git a/fcl/image/Makefile b/fcl/image/Makefile index 3b3593709f..4962f391a5 100644 --- a/fcl/image/Makefile +++ b/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=echo -else -ECHOREDIR=$(ECHO) -endif +ECHOREDIR:=$(subst /,$(PATHSEP),$(ECHO)) 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 diff --git a/fcl/image/Makefile.fpc b/fcl/image/Makefile.fpc index 733a880470..f7616fcae8 100644 --- a/fcl/image/Makefile.fpc +++ b/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 diff --git a/fcl/image/fpreadjpeg.pas b/fcl/image/fpreadjpeg.pas new file mode 100644 index 0000000000..da7f3c2afe --- /dev/null +++ b/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 NewLength0 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. + diff --git a/fcl/image/fpwritejpeg.pas b/fcl/image/fpwritejpeg.pas new file mode 100644 index 0000000000..b55c3201d3 --- /dev/null +++ b/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. +