CentrED/Imaging/ImagingJpeg.pas

590 lines
17 KiB
Plaintext
Raw Normal View History

{
$Id: ImagingJpeg.pas 103 2007-09-15 01:11:14Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains image format loader/saver for Jpeg images.}
unit ImagingJpeg;
{$I ImagingOptions.inc}
{ You can choose which Pascal JpegLib implementation will be used.
IMJPEGLIB is version bundled with Imaging which works with all supported
compilers and platforms.
PASJPEG is original JpegLib translation or version modified for FPC
(and shipped with it). You can use PASJPEG if this version is already
linked with another part of your program and you don't want to have
two quite large almost the same libraries linked to your exe.
This is the case with Lazarus applications for example.}
{$DEFINE IMJPEGLIB}
{ $DEFINE PASJPEG}
{ Automatically use FPC's PasJpeg when compiling with Lazarus.}
{$IFDEF LCL}
{ $UNDEF IMJPEGLIB}
{$DEFINE PASJPEG}
{$ENDIF}
interface
uses
SysUtils, ImagingTypes, Imaging, ImagingColors,
{$IF Defined(IMJPEGLIB)}
imjpeglib, imjmorecfg, imjcomapi, imjdapimin,
imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam,
{$ELSEIF Defined(PASJPEG)}
jpeglib, jmorecfg, jcomapi, jdapimin,
jdapistd, jcapimin, jcapistd, jdmarker, jcparam,
{$IFEND}
ImagingUtility;
{$IF Defined(FPC) and Defined(PASJPEG)}
{ When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB}
{ $DEFINE RGBSWAPPED} // not needed now apparently
{$IFEND}
type
{ Class for loading/saving Jpeg images. Supports load/save of
8 bit grayscale and 24 bit RGB images.}
TJpegFileFormat = class(TImageFileFormat)
private
FGrayScale: Boolean;
protected
FQuality: LongInt;
FProgressive: LongBool;
procedure SetJpegIO(const JpegIO: TIOFunctions); virtual;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
procedure CheckOptionsValidity; override;
published
{ Controls Jpeg save compression quality. It is number in range 1..100.
1 means small/ugly file, 100 means large/nice file. Accessible trough
ImagingJpegQuality option.}
property Quality: LongInt read FQuality write FQuality;
{ If True Jpeg images are saved in progressive format. Accessible trough
ImagingJpegProgressive option.}
property Progressive: LongBool read FProgressive write FProgressive;
end;
implementation
const
SJpegFormatName = 'Joint Photographic Experts Group Image';
SJpegMasks = '*.jpg,*.jpeg,*.jfif,*.jpe,*.jif';
JpegSupportedFormats: TImageFormats = [ifR8G8B8, ifGray8];
JpegDefaultQuality = 90;
JpegDefaultProgressive = False;
const
{ Jpeg file identifiers.}
JpegMagic: TChar2 = #$FF#$D8;
JFIFSignature: TChar4 = 'JFIF';
EXIFSignature: TChar4 = 'Exif';
BufferSize = 16384;
type
TJpegContext = record
case Byte of
0: (common: jpeg_common_struct);
1: (d: jpeg_decompress_struct);
2: (c: jpeg_compress_struct);
end;
TSourceMgr = record
Pub: jpeg_source_mgr;
Input: TImagingHandle;
Buffer: JOCTETPTR;
StartOfFile: Boolean;
end;
PSourceMgr = ^TSourceMgr;
TDestMgr = record
Pub: jpeg_destination_mgr;
Output: TImagingHandle;
Buffer: JOCTETPTR;
end;
PDestMgr = ^TDestMgr;
var
JIO: TIOFunctions;
{ Intenal unit jpeglib support functions }
procedure JpegError(CurInfo: j_common_ptr);
begin
end;
procedure EmitMessage(CurInfo: j_common_ptr; msg_level: Integer);
begin
end;
procedure OutputMessage(CurInfo: j_common_ptr);
begin
end;
procedure FormatMessage(CurInfo: j_common_ptr; var buffer: string);
begin
end;
procedure ResetErrorMgr(CurInfo: j_common_ptr);
begin
CurInfo^.err^.num_warnings := 0;
CurInfo^.err^.msg_code := 0;
end;
var
JpegErrorRec: jpeg_error_mgr = (
error_exit: JpegError;
emit_message: EmitMessage;
output_message: OutputMessage;
format_message: FormatMessage;
reset_error_mgr: ResetErrorMgr);
procedure ReleaseContext(var jc: TJpegContext);
begin
if jc.common.err = nil then
Exit;
jpeg_destroy(@jc.common);
jpeg_destroy_decompress(@jc.d);
jpeg_destroy_compress(@jc.c);
jc.common.err := nil;
end;
procedure InitSource(cinfo: j_decompress_ptr);
begin
PSourceMgr(cinfo.src).StartOfFile := True;
end;
function FillInputBuffer(cinfo: j_decompress_ptr): Boolean;
var
NBytes: LongInt;
Src: PSourceMgr;
begin
Src := PSourceMgr(cinfo.src);
NBytes := JIO.Read(Src.Input, Src.Buffer, BufferSize);
if NBytes <= 0 then
begin
PChar(Src.Buffer)[0] := #$FF;
PChar(Src.Buffer)[1] := Char(JPEG_EOI);
NBytes := 2;
end;
Src.Pub.next_input_byte := Src.Buffer;
Src.Pub.bytes_in_buffer := NBytes;
Src.StartOfFile := False;
Result := True;
end;
procedure SkipInputData(cinfo: j_decompress_ptr; num_bytes: LongInt);
var
Src: PSourceMgr;
begin
Src := PSourceMgr(cinfo.src);
if num_bytes > 0 then
begin
while num_bytes > Src.Pub.bytes_in_buffer do
begin
Dec(num_bytes, Src.Pub.bytes_in_buffer);
FillInputBuffer(cinfo);
end;
Src.Pub.next_input_byte := @PByteArray(Src.Pub.next_input_byte)[num_bytes];
// Inc(LongInt(Src.Pub.next_input_byte), num_bytes);
Dec(Src.Pub.bytes_in_buffer, num_bytes);
end;
end;
procedure TermSource(cinfo: j_decompress_ptr);
var
Src: PSourceMgr;
begin
Src := PSourceMgr(cinfo.src);
// Move stream position back just after EOI marker so that more that one
// JPEG images can be loaded from one stream
JIO.Seek(Src.Input, -Src.Pub.bytes_in_buffer, smFromCurrent);
end;
procedure JpegStdioSrc(var cinfo: jpeg_decompress_struct; Handle:
TImagingHandle);
var
Src: PSourceMgr;
begin
if cinfo.src = nil then
begin
cinfo.src := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
SizeOf(TSourceMgr));
Src := PSourceMgr(cinfo.src);
Src.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
BufferSize * SizeOf(JOCTET));
end;
Src := PSourceMgr(cinfo.src);
Src.Pub.init_source := InitSource;
Src.Pub.fill_input_buffer := FillInputBuffer;
Src.Pub.skip_input_data := SkipInputData;
Src.Pub.resync_to_restart := jpeg_resync_to_restart;
Src.Pub.term_source := TermSource;
Src.Input := Handle;
Src.Pub.bytes_in_buffer := 0;
Src.Pub.next_input_byte := nil;
end;
procedure InitDest(cinfo: j_compress_ptr);
var
Dest: PDestMgr;
begin
Dest := PDestMgr(cinfo.dest);
Dest.Pub.next_output_byte := Dest.Buffer;
Dest.Pub.free_in_buffer := BufferSize;
end;
function EmptyOutput(cinfo: j_compress_ptr): Boolean;
var
Dest: PDestMgr;
begin
Dest := PDestMgr(cinfo.dest);
JIO.Write(Dest.Output, Dest.Buffer, BufferSize);
Dest.Pub.next_output_byte := Dest.Buffer;
Dest.Pub.free_in_buffer := BufferSize;
Result := True;
end;
procedure TermDest(cinfo: j_compress_ptr);
var
Dest: PDestMgr;
DataCount: LongInt;
begin
Dest := PDestMgr(cinfo.dest);
DataCount := BufferSize - Dest.Pub.free_in_buffer;
if DataCount > 0 then
JIO.Write(Dest.Output, Dest.Buffer, DataCount);
end;
procedure JpegStdioDest(var cinfo: jpeg_compress_struct; Handle:
TImagingHandle);
var
Dest: PDestMgr;
begin
if cinfo.dest = nil then
cinfo.dest := cinfo.mem.alloc_small(j_common_ptr(@cinfo),
JPOOL_PERMANENT, SizeOf(TDestMgr));
Dest := PDestMgr(cinfo.dest);
Dest.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_IMAGE,
BufferSize * SIZEOF(JOCTET));
Dest.Pub.init_destination := InitDest;
Dest.Pub.empty_output_buffer := EmptyOutput;
Dest.Pub.term_destination := TermDest;
Dest.Output := Handle;
end;
procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
begin
FillChar(jc, sizeof(jc), 0);
jc.common.err := @JpegErrorRec;
jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
JpegStdioSrc(jc.d, Handle);
jpeg_read_header(@jc.d, True);
jc.d.scale_num := 1;
jc.d.scale_denom := 1;
jc.d.do_block_smoothing := True;
if jc.d.out_color_space = JCS_GRAYSCALE then
begin
jc.d.quantize_colors := True;
jc.d.desired_number_of_colors := 256;
end;
end;
procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
Saver: TJpegFileFormat);
begin
FillChar(jc, sizeof(jc), 0);
jc.common.err := @JpegErrorRec;
jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
JpegStdioDest(jc.c, Handle);
jpeg_set_defaults(@jc.c);
jpeg_set_quality(@jc.c, Saver.FQuality, True);
if Saver.FGrayScale then
jpeg_set_colorspace(@jc.c, JCS_GRAYSCALE)
else
jpeg_set_colorspace(@jc.c, JCS_YCbCr);
if Saver.FProgressive then
jpeg_simple_progression(@jc.c);
end;
{ TJpegFileFormat class implementation }
constructor TJpegFileFormat.Create;
begin
inherited Create;
FName := SJpegFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := False;
FSupportedFormats := JpegSupportedFormats;
FQuality := JpegDefaultQuality;
FProgressive := JpegDefaultProgressive;
AddMasks(SJpegMasks);
RegisterOption(ImagingJpegQuality, @FQuality);
RegisterOption(ImagingJpegProgressive, @FProgressive);
end;
procedure TJpegFileFormat.CheckOptionsValidity;
begin
// Check if option values are valid
if not (FQuality in [1..100]) then
FQuality := JpegDefaultQuality;
end;
function TJpegFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
PtrInc, LinesPerCall, LinesRead, I: Integer;
Dest: PByte;
jc: TJpegContext;
Info: TImageFormatInfo;
Format: TImageFormat;
Col32: PColor32Rec;
{$IFDEF RGBSWAPPED}
I: LongInt;
Pix: PColor24Rec;
{$ENDIF}
begin
// Copy IO functions to global var used in JpegLib callbacks
SetJpegIO(GetIO);
SetLength(Images, 1);
with JIO, Images[0] do
try
InitDecompressor(Handle, jc);
case jc.d.out_color_space of
JCS_GRAYSCALE: Format := ifGray8;
JCS_RGB: Format := ifR8G8B8;
JCS_CMYK: Format := ifA8R8G8B8;
end;
NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
jpeg_start_decompress(@jc.d);
GetImageFormatInfo(Format, Info);
PtrInc := Width * Info.BytesPerPixel;
LinesPerCall := 1;
Dest := Bits;
while jc.d.output_scanline < jc.d.output_height do
begin
LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
{$IFDEF RGBSWAPPED}
if Format = ifR8G8B8 then
begin
Pix := PColor24Rec(Dest);
for I := 0 to Width - 1 do
begin
SwapValues(Pix.R, Pix.B);
Inc(Pix);
end;
end;
{$ENDIF}
Inc(Dest, PtrInc * LinesRead);
end;
if jc.d.out_color_space = JCS_CMYK then
begin
Col32 := Bits;
// Translate from CMYK to RGB
for I := 0 to Width * Height - 1 do
begin
CMYKToRGB(255 - Col32.B, 255 - Col32.G, 255 - Col32.R, 255 - Col32.A,
Col32.R, Col32.G, Col32.B);
Col32.A := 255;
Inc(Col32);
end;
end;
jpeg_finish_output(@jc.d);
jpeg_finish_decompress(@jc.d);
Result := True;
finally
ReleaseContext(jc);
end;
end;
function TJpegFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
PtrInc, LinesWritten: LongInt;
Src, Line: PByte;
jc: TJpegContext;
ImageToSave: TImageData;
Info: TImageFormatInfo;
MustBeFreed: Boolean;
{$IFDEF RGBSWAPPED}
I: LongInt;
Pix: PColor24Rec;
{$ENDIF}
begin
Result := False;
// Copy IO functions to global var used in JpegLib callbacks
SetJpegIO(GetIO);
// Makes image to save compatible with Jpeg saving capabilities
if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
with JIO, ImageToSave do
try
GetImageFormatInfo(Format, Info);
FGrayScale := Format = ifGray8;
InitCompressor(Handle, jc, Self);
jc.c.image_width := Width;
jc.c.image_height := Height;
if FGrayScale then
begin
jc.c.input_components := 1;
jc.c.in_color_space := JCS_GRAYSCALE;
end
else
begin
jc.c.input_components := 3;
jc.c.in_color_space := JCS_RGB;
end;
PtrInc := Width * Info.BytesPerPixel;
Src := Bits;
{$IFDEF RGBSWAPPED}
GetMem(Line, PtrInc);
{$ENDIF}
jpeg_start_compress(@jc.c, True);
while (jc.c.next_scanline < jc.c.image_height) do
begin
{$IFDEF RGBSWAPPED}
if Format = ifR8G8B8 then
begin
Move(Src^, Line^, PtrInc);
Pix := PColor24Rec(Line);
for I := 0 to Width - 1 do
begin
SwapValues(Pix.R, Pix.B);
Inc(Pix, 1);
end;
end;
{$ELSE}
Line := Src;
{$ENDIF}
LinesWritten := jpeg_write_scanlines(@jc.c, @Line, 1);
Inc(Src, PtrInc * LinesWritten);
end;
jpeg_finish_compress(@jc.c);
Result := True;
finally
ReleaseContext(jc);
if MustBeFreed then
FreeImage(ImageToSave);
{$IFDEF RGBSWAPPED}
FreeMem(Line);
{$ENDIF}
end;
end;
procedure TJpegFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
begin
if Info.HasGrayChannel then
ConvertImage(Image, ifGray8)
else
ConvertImage(Image, ifR8G8B8);
end;
function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
ReadCount: LongInt;
ID: array[0..9] of Char;
begin
Result := False;
if Handle <> nil then
with GetIO do
begin
FillChar(ID, SizeOf(ID), 0);
ReadCount := Read(Handle, @ID, SizeOf(ID));
Seek(Handle, -ReadCount, smFromCurrent);
Result := (ReadCount = SizeOf(ID)) and
CompareMem(@ID, @JpegMagic, SizeOf(JpegMagic));
end;
end;
procedure TJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions);
begin
JIO := JpegIO;
end;
initialization
RegisterImageFileFormat(TJpegFileFormat);
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.24.1 Changes/Bug Fixes ---------------------------------
- Fixed loading of CMYK jpeg images. Could cause heap corruption
and loaded image looked wrong.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Removed JFIF/EXIF detection from TestFormat. Found JPEGs
with different headers (Lavc) which weren't recognized.
-- 0.21 Changes/Bug Fixes -----------------------------------
- MakeCompatible method moved to base class, put ConvertToSupported here.
GetSupportedFormats removed, it is now set in constructor.
- Made public properties for options registered to SetOption/GetOption
functions.
- Changed extensions to filename masks.
- Changed SaveData, LoadData, and MakeCompatible methods according
to changes in base class in Imaging unit.
- Changes in TestFormat, now reads JFIF and EXIF signatures too.
-- 0.19 Changes/Bug Fixes -----------------------------------
- input position is now set correctly to the end of the image
after loading is done. Loading of sequence of JPEG files stored in
single stream works now
- when loading and saving images in FPC with PASJPEG read and
blue channels are swapped to have the same chanel order as IMJPEGLIB
- you can now choose between IMJPEGLIB and PASJPEG implementations
-- 0.17 Changes/Bug Fixes -----------------------------------
- added SetJpegIO method which is used by JNG image format
}
end.