src/lib/vampimg/ImagingJpeg.pas

   1 {
   2   $Id: ImagingJpeg.pas 168 2009-08-22 18:50:21Z galfar $
   3   Vampyre Imaging Library
   4   by Marek Mauder
   5   http://imaginglib.sourceforge.net
   6
   7   The contents of this file are used with permission, subject to the Mozilla
   8   Public License Version 1.1 (the "License"); you may not use this file except
   9   in compliance with the License. You may obtain a copy of the License at
  10   http://www.mozilla.org/MPL/MPL-1.1.html
  11
  12   Software distributed under the License is distributed on an "AS IS" basis,
  13   WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  14   the specific language governing rights and limitations under the License.
  15
  16   Alternatively, the contents of this file may be used under the terms of the
  17   GNU Lesser General Public License (the  "LGPL License"), in which case the
  18   provisions of the LGPL License are applicable instead of those above.
  19   If you wish to allow use of your version of this file only under the terms
  20   of the LGPL License and not to allow others to use your version of this file
  21   under the MPL, indicate your decision by deleting  the provisions above and
  22   replace  them with the notice and other provisions required by the LGPL
  23   License.  If you do not delete the provisions above, a recipient may use
  24   your version of this file under either the MPL or the LGPL License.
  25
  26   For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
  27 }
  28
  29 { This unit contains image format loader/saver for Jpeg images.}
  30 unit ImagingJpeg;
  31
  32 {$I ImagingOptions.inc}
  33
  34 { You can choose which Pascal JpegLib implementation will be used.
  35   IMJPEGLIB is version bundled with Imaging which works with all supported
  36   compilers and platforms.
  37   PASJPEG is original JpegLib translation or version modified for FPC
  38   (and shipped with it). You can use PASJPEG if this version is already
  39   linked with another part of your program and you don't want to have
  40   two quite large almost the same libraries linked to your exe.
  41   This is the case with Lazarus applications for example.}
  42
  43 {$DEFINE IMJPEGLIB}
  44 { $DEFINE PASJPEG}
  45
  46 { Automatically use FPC's PasJpeg when compiling with Lazarus. But not when
  47   WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html}
  48 {$IF Defined(LCL) and not Defined(WINDOWS)}
  49   {$UNDEF IMJPEGLIB}
  50   {$DEFINE PASJPEG}
  51 {$IFEND}
  52
  53 interface
  54
  55 uses
  56   SysUtils, ImagingTypes, Imaging, ImagingColors,
  57 {$IF Defined(IMJPEGLIB)}
  58   imjpeglib, imjmorecfg, imjcomapi, imjdapimin, imjdeferr, imjerror,
  59   imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam,
  60 {$ELSEIF Defined(PASJPEG)}
  61   jpeglib, jmorecfg, jcomapi, jdapimin, jdeferr, jerror,
  62   jdapistd, jcapimin, jcapistd, jdmarker, jcparam,
  63 {$IFEND}
  64   ImagingUtility;
  65
  66 {$IF Defined(FPC) and Defined(PASJPEG)}
  67   { When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB}
  68   {$DEFINE RGBSWAPPED}
  69 {$IFEND}
  70
  71 type
  72   { Class for loading/saving Jpeg images. Supports load/save of
  73     8 bit grayscale and 24 bit RGB images. Jpegs can be saved with optional
  74     progressive encoding.
  75     Based on IJG's JpegLib so doesn't support alpha channels and lossless
  76     coding.}
  77   TJpegFileFormat = class(TImageFileFormat)
  78   private
  79     FGrayScale: Boolean;
  80   protected
  81     FQuality: LongInt;
  82     FProgressive: LongBool;
  83     procedure SetJpegIO(const JpegIO: TIOFunctions); virtual;
  84     function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
  85       OnlyFirstLevel: Boolean): Boolean; override;
  86     function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
  87       Index: LongInt): Boolean; override;
  88     procedure ConvertToSupported(var Image: TImageData;
  89       const Info: TImageFormatInfo); override;
  90   public
  91     constructor Create; override;
  92     function TestFormat(Handle: TImagingHandle): Boolean; override;
  93     procedure CheckOptionsValidity; override;
  94   published
  95     { Controls Jpeg save compression quality. It is number in range 1..100.
  96       1 means small/ugly file, 100 means large/nice file. Accessible trough
  97       ImagingJpegQuality option.}
  98     property Quality: LongInt read FQuality write FQuality;
  99     { If True Jpeg images are saved in progressive format. Accessible trough
 100       ImagingJpegProgressive option.}
 101     property Progressive: LongBool read FProgressive write FProgressive;
 102   end;
 103
 104 implementation
 105
 106 const
 107   SJpegFormatName = 'Joint Photographic Experts Group Image';
 108   SJpegMasks      = '*.jpg,*.jpeg,*.jfif,*.jpe,*.jif';
 109   JpegSupportedFormats: TImageFormats = [ifR8G8B8, ifGray8];
 110   JpegDefaultQuality = 90;
 111   JpegDefaultProgressive = False;
 112
 113 const
 114   { Jpeg file identifiers.}
 115   JpegMagic: TChar2 = #$FF#$D8;
 116   BufferSize = 16384;
 117
 118 resourcestring
 119   SJpegError = 'JPEG Error';
 120
 121 type
 122   TJpegContext = record
 123     case Byte of
 124       0: (common: jpeg_common_struct);
 125       1: (d: jpeg_decompress_struct);
 126       2: (c: jpeg_compress_struct);
 127   end;
 128
 129   TSourceMgr = record
 130     Pub: jpeg_source_mgr;
 131     Input: TImagingHandle;
 132     Buffer: JOCTETPTR;
 133     StartOfFile: Boolean;
 134   end;
 135   PSourceMgr = ^TSourceMgr;
 136
 137   TDestMgr = record
 138     Pub: jpeg_destination_mgr;
 139     Output: TImagingHandle;
 140     Buffer: JOCTETPTR;
 141   end;
 142   PDestMgr = ^TDestMgr;
 143
 144 var
 145   JIO: TIOFunctions;
 146   JpegErrorMgr: jpeg_error_mgr;
 147
 148 { Intenal unit jpeglib support functions }
 149
 150 procedure JpegError(CInfo: j_common_ptr);
 151 var
 152   Buffer: string;
 153 begin
 154   { Create the message and raise exception }
 155   CInfo^.err^.format_message(CInfo, buffer);
 156   raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + Buffer, [CInfo.err^.msg_code]);
 157 end;
 158
 159 procedure OutputMessage(CurInfo: j_common_ptr);
 160 begin
 161 end;
 162
 163 procedure ReleaseContext(var jc: TJpegContext);
 164 begin
 165   if jc.common.err = nil then
 166     Exit;
 167   jpeg_destroy(@jc.common);
 168   jpeg_destroy_decompress(@jc.d);
 169   jpeg_destroy_compress(@jc.c);
 170   jc.common.err := nil;
 171 end;
 172
 173 procedure InitSource(cinfo: j_decompress_ptr);
 174 begin
 175   PSourceMgr(cinfo.src).StartOfFile := True;
 176 end;
 177
 178 function FillInputBuffer(cinfo: j_decompress_ptr): Boolean;
 179 var
 180   NBytes: LongInt;
 181   Src: PSourceMgr;
 182 begin
 183   Src := PSourceMgr(cinfo.src);
 184   NBytes := JIO.Read(Src.Input, Src.Buffer, BufferSize);
 185
 186   if NBytes <= 0 then
 187   begin
 188     PChar(Src.Buffer)[0] := #$FF;
 189     PChar(Src.Buffer)[1] := Char(JPEG_EOI);
 190     NBytes := 2;
 191   end;
 192   Src.Pub.next_input_byte := Src.Buffer;
 193   Src.Pub.bytes_in_buffer := NBytes;
 194   Src.StartOfFile := False;
 195   Result := True;
 196 end;
 197
 198 procedure SkipInputData(cinfo: j_decompress_ptr; num_bytes: LongInt);
 199 var
 200   Src: PSourceMgr;
 201 begin
 202   Src := PSourceMgr(cinfo.src);
 203   if num_bytes > 0 then
 204   begin
 205     while num_bytes > Src.Pub.bytes_in_buffer do
 206     begin
 207       Dec(num_bytes, Src.Pub.bytes_in_buffer);
 208       FillInputBuffer(cinfo);
 209     end;
 210     Src.Pub.next_input_byte := @PByteArray(Src.Pub.next_input_byte)[num_bytes];
 211     //Inc(LongInt(Src.Pub.next_input_byte), num_bytes);
 212     Dec(Src.Pub.bytes_in_buffer, num_bytes);
 213   end;
 214 end;
 215
 216 procedure TermSource(cinfo: j_decompress_ptr);
 217 var
 218   Src: PSourceMgr;
 219 begin
 220   Src := PSourceMgr(cinfo.src);
 221   // Move stream position back just after EOI marker so that more that one
 222   // JPEG images can be loaded from one stream
 223   JIO.Seek(Src.Input, -Src.Pub.bytes_in_buffer, smFromCurrent);
 224 end;
 225
 226 procedure JpegStdioSrc(var cinfo: jpeg_decompress_struct; Handle:
 227   TImagingHandle);
 228 var
 229   Src: PSourceMgr;
 230 begin
 231   if cinfo.src = nil then
 232   begin
 233     cinfo.src := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
 234       SizeOf(TSourceMgr));
 235     Src := PSourceMgr(cinfo.src);
 236     Src.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
 237       BufferSize * SizeOf(JOCTET));
 238   end;
 239   Src := PSourceMgr(cinfo.src);
 240   Src.Pub.init_source := InitSource;
 241   Src.Pub.fill_input_buffer := FillInputBuffer;
 242   Src.Pub.skip_input_data := SkipInputData;
 243   Src.Pub.resync_to_restart := jpeg_resync_to_restart;
 244   Src.Pub.term_source := TermSource;
 245   Src.Input := Handle;
 246   Src.Pub.bytes_in_buffer := 0;
 247   Src.Pub.next_input_byte := nil;
 248 end;
 249
 250 procedure InitDest(cinfo: j_compress_ptr);
 251 var
 252   Dest: PDestMgr;
 253 begin
 254   Dest := PDestMgr(cinfo.dest);
 255   Dest.Pub.next_output_byte := Dest.Buffer;
 256   Dest.Pub.free_in_buffer := BufferSize;
 257 end;
 258
 259 function EmptyOutput(cinfo: j_compress_ptr): Boolean;
 260 var
 261   Dest: PDestMgr;
 262 begin
 263   Dest := PDestMgr(cinfo.dest);
 264   JIO.Write(Dest.Output, Dest.Buffer, BufferSize);
 265   Dest.Pub.next_output_byte := Dest.Buffer;
 266   Dest.Pub.free_in_buffer := BufferSize;
 267   Result := True;
 268 end;
 269
 270 procedure TermDest(cinfo: j_compress_ptr);
 271 var
 272   Dest: PDestMgr;
 273   DataCount: LongInt;
 274 begin
 275   Dest := PDestMgr(cinfo.dest);
 276   DataCount := BufferSize - Dest.Pub.free_in_buffer;
 277   if DataCount > 0 then
 278     JIO.Write(Dest.Output, Dest.Buffer, DataCount);
 279 end;
 280
 281 procedure JpegStdioDest(var cinfo: jpeg_compress_struct; Handle:
 282   TImagingHandle);
 283 var
 284   Dest: PDestMgr;
 285 begin
 286   if cinfo.dest = nil then
 287     cinfo.dest := cinfo.mem.alloc_small(j_common_ptr(@cinfo),
 288       JPOOL_PERMANENT, SizeOf(TDestMgr));
 289   Dest := PDestMgr(cinfo.dest);
 290   Dest.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_IMAGE,
 291     BufferSize * SIZEOF(JOCTET));
 292   Dest.Pub.init_destination := InitDest;
 293   Dest.Pub.empty_output_buffer := EmptyOutput;
 294   Dest.Pub.term_destination := TermDest;
 295   Dest.Output := Handle;
 296 end;
 297
 298 procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
 299 begin
 300   FillChar(jc, sizeof(jc), 0);
 301   // Set standard error handlers and then override some
 302   jc.common.err := jpeg_std_error(JpegErrorMgr);
 303   jc.common.err.error_exit := JpegError;
 304   jc.common.err.output_message := OutputMessage;
 305
 306   jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
 307   JpegStdioSrc(jc.d, Handle);
 308   jpeg_read_header(@jc.d, True);
 309   jc.d.scale_num := 1;
 310   jc.d.scale_denom := 1;
 311   jc.d.do_block_smoothing := True;
 312   if jc.d.out_color_space = JCS_GRAYSCALE then
 313   begin
 314     jc.d.quantize_colors := True;
 315     jc.d.desired_number_of_colors := 256;
 316   end;
 317 end;
 318
 319 procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
 320   Saver: TJpegFileFormat);
 321 begin
 322   FillChar(jc, sizeof(jc), 0);
 323   // Set standard error handlers and then override some
 324   jc.common.err := jpeg_std_error(JpegErrorMgr);
 325   jc.common.err.error_exit := JpegError;
 326   jc.common.err.output_message := OutputMessage;
 327
 328   jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
 329   JpegStdioDest(jc.c, Handle);
 330   if Saver.FGrayScale then
 331     jc.c.in_color_space := JCS_GRAYSCALE
 332   else
 333     jc.c.in_color_space := JCS_YCbCr;
 334   jpeg_set_defaults(@jc.c);
 335   jpeg_set_quality(@jc.c, Saver.FQuality, True);
 336   if Saver.FProgressive then
 337     jpeg_simple_progression(@jc.c);
 338 end;
 339
 340 { TJpegFileFormat class implementation }
 341
 342 constructor TJpegFileFormat.Create;
 343 begin
 344   inherited Create;
 345   FName := SJpegFormatName;
 346   FCanLoad := True;
 347   FCanSave := True;
 348   FIsMultiImageFormat := False;
 349   FSupportedFormats := JpegSupportedFormats;
 350
 351   FQuality := JpegDefaultQuality;
 352   FProgressive := JpegDefaultProgressive;
 353
 354   AddMasks(SJpegMasks);
 355   RegisterOption(ImagingJpegQuality, @FQuality);
 356   RegisterOption(ImagingJpegProgressive, @FProgressive);
 357 end;
 358
 359 procedure TJpegFileFormat.CheckOptionsValidity;
 360 begin
 361   // Check if option values are valid
 362   if not (FQuality in [1..100]) then
 363     FQuality := JpegDefaultQuality;
 364 end;
 365
 366 function TJpegFileFormat.LoadData(Handle: TImagingHandle;
 367   var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
 368 var
 369   PtrInc, LinesPerCall, LinesRead, I: Integer;
 370   Dest: PByte;
 371   jc: TJpegContext;
 372   Info: TImageFormatInfo;
 373   Col32: PColor32Rec;
 374 {$IFDEF RGBSWAPPED}
 375   Pix: PColor24Rec;
 376 {$ENDIF}
 377 begin
 378   // Copy IO functions to global var used in JpegLib callbacks
 379   Result := False;
 380   SetJpegIO(GetIO);
 381   SetLength(Images, 1);
 382
 383   with JIO, Images[0] do
 384   try
 385     InitDecompressor(Handle, jc);
 386     case jc.d.out_color_space of
 387       JCS_GRAYSCALE: Format := ifGray8;
 388       JCS_RGB:       Format := ifR8G8B8;
 389       JCS_CMYK:      Format := ifA8R8G8B8;
 390     else
 391       Exit;
 392     end;
 393     NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
 394     jpeg_start_decompress(@jc.d);
 395     GetImageFormatInfo(Format, Info);
 396     PtrInc := Width * Info.BytesPerPixel;
 397     LinesPerCall := 1;
 398     Dest := Bits;
 399
 400     while jc.d.output_scanline < jc.d.output_height do
 401     begin
 402       LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
 403     {$IFDEF RGBSWAPPED}
 404       if Format = ifR8G8B8 then
 405       begin
 406         Pix := PColor24Rec(Dest);
 407         for I := 0 to Width - 1 do
 408         begin
 409           SwapValues(Pix.R, Pix.B);
 410           Inc(Pix);
 411         end;
 412       end;
 413     {$ENDIF}
 414       Inc(Dest, PtrInc * LinesRead);
 415     end;
 416
 417     if jc.d.out_color_space = JCS_CMYK then
 418     begin
 419       Col32 := Bits;
 420       // Translate from CMYK to RGB
 421       for I := 0 to Width * Height - 1 do
 422       begin
 423         CMYKToRGB(255 - Col32.B, 255 - Col32.G, 255 - Col32.R, 255 - Col32.A,
 424           Col32.R, Col32.G, Col32.B);
 425         Col32.A := 255;
 426         Inc(Col32);
 427       end;
 428     end;
 429
 430     jpeg_finish_output(@jc.d);
 431     jpeg_finish_decompress(@jc.d);
 432     Result := True;
 433   finally
 434     ReleaseContext(jc);
 435   end;
 436 end;
 437
 438 function TJpegFileFormat.SaveData(Handle: TImagingHandle;
 439   const Images: TDynImageDataArray; Index: LongInt): Boolean;
 440 var
 441   PtrInc, LinesWritten: LongInt;
 442   Src, Line: PByte;
 443   jc: TJpegContext;
 444   ImageToSave: TImageData;
 445   Info: TImageFormatInfo;
 446   MustBeFreed: Boolean;
 447 {$IFDEF RGBSWAPPED}
 448   I: LongInt;
 449   Pix: PColor24Rec;
 450 {$ENDIF}
 451 begin
 452   Result := False;
 453   // Copy IO functions to global var used in JpegLib callbacks
 454   SetJpegIO(GetIO);
 455   // Makes image to save compatible with Jpeg saving capabilities
 456   if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
 457   with JIO, ImageToSave do
 458   try
 459     GetImageFormatInfo(Format, Info);
 460     FGrayScale := Format = ifGray8;
 461     InitCompressor(Handle, jc, Self);
 462     jc.c.image_width := Width;
 463     jc.c.image_height := Height;
 464     if FGrayScale then
 465     begin
 466       jc.c.input_components := 1;
 467       jc.c.in_color_space := JCS_GRAYSCALE;
 468     end
 469     else
 470     begin
 471       jc.c.input_components := 3;
 472       jc.c.in_color_space := JCS_RGB;
 473     end;
 474
 475     PtrInc := Width * Info.BytesPerPixel;
 476     Src := Bits;
 477
 478   {$IFDEF RGBSWAPPED}
 479     GetMem(Line, PtrInc);
 480   {$ENDIF}
 481
 482     jpeg_start_compress(@jc.c, True);
 483     while (jc.c.next_scanline < jc.c.image_height) do
 484     begin
 485     {$IFDEF RGBSWAPPED}
 486       if Format = ifR8G8B8 then
 487       begin
 488         Move(Src^, Line^, PtrInc);
 489         Pix := PColor24Rec(Line);
 490         for I := 0 to Width - 1 do
 491         begin
 492           SwapValues(Pix.R, Pix.B);
 493           Inc(Pix, 1);
 494         end;
 495       end;
 496     {$ELSE}
 497       Line := Src;
 498     {$ENDIF}
 499
 500       LinesWritten := jpeg_write_scanlines(@jc.c, @Line, 1);
 501       Inc(Src, PtrInc * LinesWritten);
 502     end;
 503
 504     jpeg_finish_compress(@jc.c);
 505     Result := True;
 506   finally
 507     ReleaseContext(jc);
 508     if MustBeFreed then
 509       FreeImage(ImageToSave);
 510   {$IFDEF RGBSWAPPED}
 511     FreeMem(Line);
 512   {$ENDIF}
 513   end;
 514 end;
 515
 516 procedure TJpegFileFormat.ConvertToSupported(var Image: TImageData;
 517   const Info: TImageFormatInfo);
 518 begin
 519   if Info.HasGrayChannel then
 520     ConvertImage(Image, ifGray8)
 521   else
 522     ConvertImage(Image, ifR8G8B8);
 523 end;
 524
 525 function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
 526 var
 527   ReadCount: LongInt;
 528   ID: array[0..9] of AnsiChar;
 529 begin
 530   Result := False;
 531   if Handle <> nil then
 532   with GetIO do
 533   begin
 534     FillChar(ID, SizeOf(ID), 0);
 535     ReadCount := Read(Handle, @ID, SizeOf(ID));
 536     Seek(Handle, -ReadCount, smFromCurrent);
 537     Result := (ReadCount = SizeOf(ID)) and
 538       CompareMem(@ID, @JpegMagic, SizeOf(JpegMagic));
 539   end;
 540 end;
 541
 542 procedure TJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions);
 543 begin
 544   JIO := JpegIO;
 545 end;
 546
 547 initialization
 548   RegisterImageFileFormat(TJpegFileFormat);
 549
 550 {
 551   File Notes:
 552
 553  -- TODOS ----------------------------------------------------
 554     - nothing now
 555
 556   -- 0.26.3 Changes/Bug Fixes ---------------------------------
 557     - Changed the Jpeg error manager, messages were not properly formated.
 558
 559   -- 0.26.1 Changes/Bug Fixes ---------------------------------
 560     - Fixed wrong color space setting in InitCompressor.
 561     - Fixed problem with progressive Jpegs in FPC (modified JpegLib,
 562       can't use FPC's PasJpeg in Windows).
 563
 564   -- 0.25.0 Changes/Bug Fixes ---------------------------------
 565     - FPC's PasJpeg wasn't really used in last version, fixed.
 566
 567   -- 0.24.1 Changes/Bug Fixes ---------------------------------
 568     - Fixed loading of CMYK jpeg images. Could cause heap corruption
 569       and loaded image looked wrong.
 570
 571   -- 0.23 Changes/Bug Fixes -----------------------------------
 572     - Removed JFIF/EXIF detection from TestFormat. Found JPEGs
 573       with different headers (Lavc) which weren't recognized.
 574
 575   -- 0.21 Changes/Bug Fixes -----------------------------------
 576     - MakeCompatible method moved to base class, put ConvertToSupported here.
 577       GetSupportedFormats removed, it is now set in constructor.
 578     - Made public properties for options registered to SetOption/GetOption
 579       functions.
 580     - Changed extensions to filename masks.
 581     - Changed SaveData, LoadData, and MakeCompatible methods according
 582       to changes in base class in Imaging unit.
 583     - Changes in TestFormat, now reads JFIF and EXIF signatures too.
 584
 585   -- 0.19 Changes/Bug Fixes -----------------------------------
 586     - input position is now set correctly to the end of the image
 587       after loading is done. Loading of sequence of JPEG files stored in
 588       single stream works now
 589     - when loading and saving images in FPC with PASJPEG read and
 590       blue channels are swapped to have the same chanel order as IMJPEGLIB
 591     - you can now choose between IMJPEGLIB and PASJPEG implementations
 592
 593   -- 0.17 Changes/Bug Fixes -----------------------------------
 594     - added SetJpegIO method which is used by JNG image format
 595 }
 596 end.