src/lib/vampimg/ImagingJpeg.pas

   1 {
   2   Vampyre Imaging Library
   3   by Marek Mauder
   4   http://imaginglib.sourceforge.net
   5
   6   The contents of this file are used with permission, subject to the Mozilla
   7   Public License Version 1.1 (the "License"); you may not use this file except
   8   in compliance with the License. You may obtain a copy of the License at
   9   http://www.mozilla.org/MPL/MPL-1.1.html
  10
  11   Software distributed under the License is distributed on an "AS IS" basis,
  12   WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  13   the specific language governing rights and limitations under the License.
  14
  15   Alternatively, the contents of this file may be used under the terms of the
  16   GNU Lesser General Public License (the  "LGPL License"), in which case the
  17   provisions of the LGPL License are applicable instead of those above.
  18   If you wish to allow use of your version of this file only under the terms
  19   of the LGPL License and not to allow others to use your version of this file
  20   under the MPL, indicate your decision by deleting  the provisions above and
  21   replace  them with the notice and other provisions required by the LGPL
  22   License.  If you do not delete the provisions above, a recipient may use
  23   your version of this file under either the MPL or the LGPL License.
  24
  25   For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
  26 }
  27
  28 { This unit contains image format loader/saver for Jpeg images.}
  29 unit ImagingJpeg;
  30
  31 {$I ImagingOptions.inc}
  32
  33 { You can choose which Pascal JpegLib implementation will be used.
  34   IMJPEGLIB is version bundled with Imaging which works with all supported
  35   compilers and platforms.
  36   PASJPEG is original JpegLib translation or version modified for FPC
  37   (and shipped with it). You can use PASJPEG if this version is already
  38   linked with another part of your program and you don't want to have
  39   two quite large almost the same libraries linked to your exe.
  40   This is the case with Lazarus applications for example.}
  41
  42 {$DEFINE IMJPEGLIB}
  43 { $DEFINE PASJPEG}
  44
  45 { Automatically use FPC's PasJpeg when compiling with Lazarus. But not when
  46   WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html.
  47   Fixed in FPC revision 13963: http://bugs.freepascal.org/view.php?id=14928 }
  48 {$IF Defined(LCL) and not Defined(WINDOWS)}
  49   {$UNDEF IMJPEGLIB}
  50   {$DEFINE PASJPEG}
  51 {$IFEND}
  52
  53 { We usually want to skip the rest of the corrupted file when loading JEPG files
  54   instead of getting exception. JpegLib's error handler can only be
  55   exited using setjmp/longjmp ("non-local goto") functions to get error
  56   recovery when loading corrupted JPEG files. This is implemented in assembler
  57   and currently available only for 32bit Delphi targets and FPC.}
  58 {$DEFINE ErrorJmpRecovery}
  59 {$IF Defined(DCC) and not Defined(CPUX86)}
  60   {$UNDEF ErrorJmpRecovery}
  61 {$IFEND}
  62
  63 interface
  64
  65 uses
  66   SysUtils, ImagingTypes, Imaging, ImagingColors,
  67 {$IF Defined(IMJPEGLIB)}
  68   imjpeglib, imjmorecfg, imjcomapi, imjdapimin, imjdeferr, imjerror,
  69   imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam,
  70 {$ELSEIF Defined(PASJPEG)}
  71   jpeglib, jmorecfg, jcomapi, jdapimin, jdeferr, jerror,
  72   jdapistd, jcapimin, jcapistd, jdmarker, jcparam,
  73 {$IFEND}
  74   ImagingUtility;
  75
  76 {$IF Defined(FPC) and Defined(PASJPEG)}
  77   { When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB}
  78   {$DEFINE RGBSWAPPED}
  79 {$IFEND}
  80
  81 type
  82   { Class for loading/saving Jpeg images. Supports load/save of
  83     8 bit grayscale and 24 bit RGB images. Jpegs can be saved with optional
  84     progressive encoding.
  85     Based on IJG's JpegLib so doesn't support alpha channels and lossless
  86     coding.}
  87   TJpegFileFormat = class(TImageFileFormat)
  88   private
  89     FGrayScale: Boolean;
  90   protected
  91     FQuality: LongInt;
  92     FProgressive: LongBool;
  93     procedure SetJpegIO(const JpegIO: TIOFunctions); virtual;
  94     procedure Define; override;
  95     function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
  96       OnlyFirstLevel: Boolean): Boolean; override;
  97     function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
  98       Index: LongInt): Boolean; override;
  99     procedure ConvertToSupported(var Image: TImageData;
 100       const Info: TImageFormatInfo); override;
 101   public
 102     function TestFormat(Handle: TImagingHandle): Boolean; override;
 103     procedure CheckOptionsValidity; override;
 104   published
 105     { Controls Jpeg save compression quality. It is number in range 1..100.
 106       1 means small/ugly file, 100 means large/nice file. Accessible trough
 107       ImagingJpegQuality option.}
 108     property Quality: LongInt read FQuality write FQuality;
 109     { If True Jpeg images are saved in progressive format. Accessible trough
 110       ImagingJpegProgressive option.}
 111     property Progressive: LongBool read FProgressive write FProgressive;
 112   end;
 113
 114 implementation
 115
 116 const
 117   SJpegFormatName = 'Joint Photographic Experts Group Image';
 118   SJpegMasks      = '*.jpg,*.jpeg,*.jfif,*.jpe,*.jif';
 119   JpegSupportedFormats: TImageFormats = [ifR8G8B8, ifGray8];
 120   JpegDefaultQuality = 90;
 121   JpegDefaultProgressive = False;
 122
 123 const
 124   { Jpeg file identifiers.}
 125   JpegMagic: TChar2 = #$FF#$D8;
 126   BufferSize = 16384;
 127
 128 resourcestring
 129   SJpegError = 'JPEG Error';
 130
 131 type
 132   TJpegContext = record
 133     case Byte of
 134       0: (common: jpeg_common_struct);
 135       1: (d: jpeg_decompress_struct);
 136       2: (c: jpeg_compress_struct);
 137   end;
 138
 139   TSourceMgr = record
 140     Pub: jpeg_source_mgr;
 141     Input: TImagingHandle;
 142     Buffer: JOCTETPTR;
 143     StartOfFile: Boolean;
 144   end;
 145   PSourceMgr = ^TSourceMgr;
 146
 147   TDestMgr = record
 148     Pub: jpeg_destination_mgr;
 149     Output: TImagingHandle;
 150     Buffer: JOCTETPTR;
 151   end;
 152   PDestMgr = ^TDestMgr;
 153
 154 var
 155   JIO: TIOFunctions;
 156   JpegErrorMgr: jpeg_error_mgr;
 157
 158 { Intenal unit jpeglib support functions }
 159
 160 {$IFDEF ErrorJmpRecovery}
 161   {$IFDEF DCC}
 162   type
 163     jmp_buf = record
 164       EBX,
 165       ESI,
 166       EDI,
 167       ESP,
 168       EBP,
 169       EIP: LongWord;
 170     end;
 171     pjmp_buf = ^jmp_buf;
 172
 173   { JmpLib SetJmp/LongJmp Library
 174     (C)Copyright 2003, 2004 Will DeWitt Jr. <edge@boink.net> }
 175   function  SetJmp(out jmpb: jmp_buf): Integer;
 176   asm
 177   {     ->  EAX     jmpb   }
 178   {     <-  EAX     Result }
 179             MOV     EDX, [ESP]  // Fetch return address (EIP)
 180             // Save task state
 181             MOV     [EAX+jmp_buf.&EBX], EBX
 182             MOV     [EAX+jmp_buf.&ESI], ESI
 183             MOV     [EAX+jmp_buf.&EDI], EDI
 184             MOV     [EAX+jmp_buf.&ESP], ESP
 185             MOV     [EAX+jmp_buf.&EBP], EBP
 186             MOV     [EAX+jmp_buf.&EIP], EDX
 187
 188             SUB     EAX, EAX
 189   @@1:
 190   end;
 191
 192   procedure LongJmp(const jmpb: jmp_buf; retval: Integer);
 193   asm
 194   {     ->  EAX     jmpb   }
 195   {         EDX     retval }
 196   {     <-  EAX     Result }
 197             XCHG    EDX, EAX
 198
 199             MOV     ECX, [EDX+jmp_buf.&EIP]
 200             // Restore task state
 201             MOV     EBX, [EDX+jmp_buf.&EBX]
 202             MOV     ESI, [EDX+jmp_buf.&ESI]
 203             MOV     EDI, [EDX+jmp_buf.&EDI]
 204             MOV     ESP, [EDX+jmp_buf.&ESP]
 205             MOV     EBP, [EDX+jmp_buf.&EBP]
 206             MOV     [ESP], ECX  // Restore return address (EIP)
 207
 208             TEST    EAX, EAX    // Ensure retval is <> 0
 209             JNZ     @@1
 210             MOV     EAX, 1
 211   @@1:
 212   end;
 213   {$ENDIF}
 214
 215 type
 216   TJmpBuf = jmp_buf;
 217   TErrorClientData = record
 218     JmpBuf: TJmpBuf;
 219     ScanlineReadReached: Boolean;
 220   end;
 221   PErrorClientData = ^TErrorClientData;
 222 {$ENDIF}
 223
 224 procedure JpegError(CInfo: j_common_ptr);
 225
 226   procedure RaiseError;
 227   var
 228     Buffer: AnsiString;
 229   begin
 230     // Create the message and raise exception
 231     CInfo.err.format_message(CInfo, Buffer);
 232     // Warning: you can get "Invalid argument index in format" exception when
 233     // using FPC (see http://bugs.freepascal.org/view.php?id=21229).
 234     // Fixed in FPC 2.7.1
 235   {$IF Defined(FPC) and (FPC_FULLVERSION <= 20701)}
 236     raise EImagingError.CreateFmt(SJPEGError + ' %d', [CInfo.err.msg_code]);
 237   {$ELSE}
 238     raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + string(Buffer), [CInfo.err.msg_code]);
 239   {$IFEND}
 240   end;
 241
 242 begin
 243 {$IFDEF ErrorJmpRecovery}
 244   // Only recovers on loads and when header is sucessfully loaded
 245   // (error occurs when reading scanlines)
 246   if (CInfo.client_data <> nil) and
 247     PErrorClientData(CInfo.client_data).ScanlineReadReached then
 248   begin
 249     // Non-local jump to error handler in TJpegFileFormat.LoadData
 250     longjmp(PErrorClientData(CInfo.client_data).JmpBuf, 1)
 251   end
 252   else
 253     RaiseError;
 254 {$ELSE}
 255   RaiseError;
 256 {$ENDIF}
 257 end;
 258
 259 procedure OutputMessage(CurInfo: j_common_ptr);
 260 begin
 261 end;
 262
 263 procedure ReleaseContext(var jc: TJpegContext);
 264 begin
 265   if jc.common.err = nil then
 266     Exit;
 267   jpeg_destroy(@jc.common);
 268   jpeg_destroy_decompress(@jc.d);
 269   jpeg_destroy_compress(@jc.c);
 270   jc.common.err := nil;
 271 end;
 272
 273 procedure InitSource(cinfo: j_decompress_ptr);
 274 begin
 275   PSourceMgr(cinfo.src).StartOfFile := True;
 276 end;
 277
 278 function FillInputBuffer(cinfo: j_decompress_ptr): Boolean;
 279 var
 280   NBytes: LongInt;
 281   Src: PSourceMgr;
 282 begin
 283   Src := PSourceMgr(cinfo.src);
 284   NBytes := JIO.Read(Src.Input, Src.Buffer, BufferSize);
 285
 286   if NBytes <= 0 then
 287   begin
 288     PByteArray(Src.Buffer)[0] := $FF;
 289     PByteArray(Src.Buffer)[1] := JPEG_EOI;
 290     NBytes := 2;
 291   end;
 292   Src.Pub.next_input_byte := Src.Buffer;
 293   Src.Pub.bytes_in_buffer := NBytes;
 294   Src.StartOfFile := False;
 295   Result := True;
 296 end;
 297
 298 procedure SkipInputData(cinfo: j_decompress_ptr; num_bytes: LongInt);
 299 var
 300   Src: PSourceMgr;
 301 begin
 302   Src := PSourceMgr(cinfo.src);
 303   if num_bytes > 0 then
 304   begin
 305     while num_bytes > Src.Pub.bytes_in_buffer do
 306     begin
 307       Dec(num_bytes, Src.Pub.bytes_in_buffer);
 308       FillInputBuffer(cinfo);
 309     end;
 310     Src.Pub.next_input_byte := @PByteArray(Src.Pub.next_input_byte)[num_bytes];
 311     //Inc(LongInt(Src.Pub.next_input_byte), num_bytes);
 312     Dec(Src.Pub.bytes_in_buffer, num_bytes);
 313   end;
 314 end;
 315
 316 procedure TermSource(cinfo: j_decompress_ptr);
 317 var
 318   Src: PSourceMgr;
 319 begin
 320   Src := PSourceMgr(cinfo.src);
 321   // Move stream position back just after EOI marker so that more that one
 322   // JPEG images can be loaded from one stream
 323   JIO.Seek(Src.Input, -Src.Pub.bytes_in_buffer, smFromCurrent);
 324 end;
 325
 326 procedure JpegStdioSrc(var cinfo: jpeg_decompress_struct; Handle:
 327   TImagingHandle);
 328 var
 329   Src: PSourceMgr;
 330 begin
 331   if cinfo.src = nil then
 332   begin
 333     cinfo.src := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
 334       SizeOf(TSourceMgr));
 335     Src := PSourceMgr(cinfo.src);
 336     Src.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
 337       BufferSize * SizeOf(JOCTET));
 338   end;
 339   Src := PSourceMgr(cinfo.src);
 340   Src.Pub.init_source := InitSource;
 341   Src.Pub.fill_input_buffer := FillInputBuffer;
 342   Src.Pub.skip_input_data := SkipInputData;
 343   Src.Pub.resync_to_restart := jpeg_resync_to_restart;
 344   Src.Pub.term_source := TermSource;
 345   Src.Input := Handle;
 346   Src.Pub.bytes_in_buffer := 0;
 347   Src.Pub.next_input_byte := nil;
 348 end;
 349
 350 procedure InitDest(cinfo: j_compress_ptr);
 351 var
 352   Dest: PDestMgr;
 353 begin
 354   Dest := PDestMgr(cinfo.dest);
 355   Dest.Pub.next_output_byte := Dest.Buffer;
 356   Dest.Pub.free_in_buffer := BufferSize;
 357 end;
 358
 359 function EmptyOutput(cinfo: j_compress_ptr): Boolean;
 360 var
 361   Dest: PDestMgr;
 362 begin
 363   Dest := PDestMgr(cinfo.dest);
 364   JIO.Write(Dest.Output, Dest.Buffer, BufferSize);
 365   Dest.Pub.next_output_byte := Dest.Buffer;
 366   Dest.Pub.free_in_buffer := BufferSize;
 367   Result := True;
 368 end;
 369
 370 procedure TermDest(cinfo: j_compress_ptr);
 371 var
 372   Dest: PDestMgr;
 373   DataCount: LongInt;
 374 begin
 375   Dest := PDestMgr(cinfo.dest);
 376   DataCount := BufferSize - Dest.Pub.free_in_buffer;
 377   if DataCount > 0 then
 378     JIO.Write(Dest.Output, Dest.Buffer, DataCount);
 379 end;
 380
 381 procedure JpegStdioDest(var cinfo: jpeg_compress_struct; Handle:
 382   TImagingHandle);
 383 var
 384   Dest: PDestMgr;
 385 begin
 386   if cinfo.dest = nil then
 387     cinfo.dest := cinfo.mem.alloc_small(j_common_ptr(@cinfo),
 388       JPOOL_PERMANENT, SizeOf(TDestMgr));
 389   Dest := PDestMgr(cinfo.dest);
 390   Dest.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_IMAGE,
 391     BufferSize * SIZEOF(JOCTET));
 392   Dest.Pub.init_destination := InitDest;
 393   Dest.Pub.empty_output_buffer := EmptyOutput;
 394   Dest.Pub.term_destination := TermDest;
 395   Dest.Output := Handle;
 396 end;
 397
 398 procedure SetupErrorMgr(var jc: TJpegContext);
 399 begin
 400   // Set standard error handlers and then override some
 401   jc.common.err := jpeg_std_error(JpegErrorMgr);
 402   jc.common.err.error_exit := JpegError;
 403   jc.common.err.output_message := OutputMessage;
 404 end;
 405
 406 procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
 407 begin
 408   jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
 409   JpegStdioSrc(jc.d, Handle);
 410   jpeg_read_header(@jc.d, True);
 411   jc.d.scale_num := 1;
 412   jc.d.scale_denom := 1;
 413   jc.d.do_block_smoothing := True;
 414   if jc.d.out_color_space = JCS_GRAYSCALE then
 415   begin
 416     jc.d.quantize_colors := True;
 417     jc.d.desired_number_of_colors := 256;
 418   end;
 419 end;
 420
 421 procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
 422   Saver: TJpegFileFormat);
 423 begin
 424   jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
 425   JpegStdioDest(jc.c, Handle);
 426   if Saver.FGrayScale then
 427     jc.c.in_color_space := JCS_GRAYSCALE
 428   else
 429     jc.c.in_color_space := JCS_RGB;
 430   jpeg_set_defaults(@jc.c);
 431   jpeg_set_quality(@jc.c, Saver.FQuality, True);
 432   if Saver.FProgressive then
 433     jpeg_simple_progression(@jc.c);
 434 end;
 435
 436 { TJpegFileFormat class implementation }
 437
 438 procedure TJpegFileFormat.Define;
 439 begin
 440   FName := SJpegFormatName;
 441   FFeatures := [ffLoad, ffSave];
 442   FSupportedFormats := JpegSupportedFormats;
 443
 444   FQuality := JpegDefaultQuality;
 445   FProgressive := JpegDefaultProgressive;
 446
 447   AddMasks(SJpegMasks);
 448   RegisterOption(ImagingJpegQuality, @FQuality);
 449   RegisterOption(ImagingJpegProgressive, @FProgressive);
 450 end;
 451
 452 procedure TJpegFileFormat.CheckOptionsValidity;
 453 begin
 454   // Check if option values are valid
 455   if not (FQuality in [1..100]) then
 456     FQuality := JpegDefaultQuality;
 457 end;
 458
 459 function TJpegFileFormat.LoadData(Handle: TImagingHandle;
 460   var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
 461 var
 462   PtrInc, LinesPerCall, LinesRead, I: Integer;
 463   Dest: PByte;
 464   jc: TJpegContext;
 465   Info: TImageFormatInfo;
 466   Col32: PColor32Rec;
 467   NeedsRedBlueSwap: Boolean;
 468   Pix: PColor24Rec;
 469 {$IFDEF ErrorJmpRecovery}
 470   ErrorClient: TErrorClientData;
 471 {$ENDIF}
 472
 473   procedure LoadMetaData;
 474   var
 475     XDensity, YDensity: Single;
 476     ResUnit: TResolutionUnit;
 477   begin
 478     // Density unit: 0 - undef, 1 - inch, 2 - cm
 479     if jc.d.saw_JFIF_marker and (jc.d.density_unit > 0) and
 480       (jc.d.X_density > 0) and (jc.d.Y_density > 0) then
 481     begin
 482       XDensity := jc.d.X_density;
 483       YDensity := jc.d.Y_density;
 484       ResUnit := ruDpi;
 485       if jc.d.density_unit = 2 then
 486         ResUnit := ruDpcm;
 487       FMetadata.SetPhysicalPixelSize(ResUnit, XDensity, YDensity);
 488     end;
 489   end;
 490
 491 begin
 492   // Copy IO functions to global var used in JpegLib callbacks
 493   Result := False;
 494   SetJpegIO(GetIO);
 495   SetLength(Images, 1);
 496
 497   with JIO, Images[0] do
 498   try
 499     ZeroMemory(@jc, SizeOf(jc));
 500     SetupErrorMgr(jc);
 501   {$IFDEF ErrorJmpRecovery}
 502     ZeroMemory(@ErrorClient, SizeOf(ErrorClient));
 503     jc.common.client_data := @ErrorClient;
 504     if setjmp(ErrorClient.JmpBuf) <> 0 then
 505     begin
 506       Result := True;
 507       Exit;
 508     end;
 509   {$ENDIF}
 510     InitDecompressor(Handle, jc);
 511
 512     case jc.d.out_color_space of
 513       JCS_GRAYSCALE: Format := ifGray8;
 514       JCS_RGB:       Format := ifR8G8B8;
 515       JCS_CMYK:      Format := ifA8R8G8B8;
 516     else
 517       Exit;
 518     end;
 519
 520     NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
 521     jpeg_start_decompress(@jc.d);
 522     GetImageFormatInfo(Format, Info);
 523     PtrInc := Width * Info.BytesPerPixel;
 524     LinesPerCall := 1;
 525     Dest := Bits;
 526
 527     // If Jpeg's colorspace is RGB and not YCbCr we need to swap
 528     // R and B to get Imaging's native order
 529     NeedsRedBlueSwap := jc.d.jpeg_color_space = JCS_RGB;
 530   {$IFDEF RGBSWAPPED}
 531     // Force R-B swap for FPC's PasJpeg
 532     NeedsRedBlueSwap := True;
 533   {$ENDIF}
 534
 535   {$IFDEF ErrorJmpRecovery}
 536     ErrorClient.ScanlineReadReached := True;
 537   {$ENDIF}
 538
 539     while jc.d.output_scanline < jc.d.output_height do
 540     begin
 541       LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
 542       if NeedsRedBlueSwap and (Format = ifR8G8B8) then
 543       begin
 544         Pix := PColor24Rec(Dest);
 545         for I := 0 to Width - 1 do
 546         begin
 547           SwapValues(Pix.R, Pix.B);
 548           Inc(Pix);
 549         end;
 550       end;
 551       Inc(Dest, PtrInc * LinesRead);
 552     end;
 553
 554     if jc.d.out_color_space = JCS_CMYK then
 555     begin
 556       Col32 := Bits;
 557       // Translate from CMYK to RGB
 558       for I := 0 to Width * Height - 1 do
 559       begin
 560         CMYKToRGB(255 - Col32.B, 255 - Col32.G, 255 - Col32.R, 255 - Col32.A,
 561           Col32.R, Col32.G, Col32.B);
 562         Col32.A := 255;
 563         Inc(Col32);
 564       end;
 565     end;
 566
 567     // Store supported metadata
 568     LoadMetaData;
 569
 570     jpeg_finish_output(@jc.d);
 571     jpeg_finish_decompress(@jc.d);
 572     Result := True;
 573   finally
 574     ReleaseContext(jc);
 575   end;
 576 end;
 577
 578 function TJpegFileFormat.SaveData(Handle: TImagingHandle;
 579   const Images: TDynImageDataArray; Index: LongInt): Boolean;
 580 var
 581   PtrInc, LinesWritten: LongInt;
 582   Src, Line: PByte;
 583   jc: TJpegContext;
 584   ImageToSave: TImageData;
 585   Info: TImageFormatInfo;
 586   MustBeFreed: Boolean;
 587 {$IFDEF RGBSWAPPED}
 588   I: LongInt;
 589   Pix: PColor24Rec;
 590 {$ENDIF}
 591
 592   procedure SaveMetaData;
 593   var
 594     XRes, YRes: Single;
 595   begin
 596     if FMetadata.GetPhysicalPixelSize(ruDpcm, XRes, YRes, True) then
 597     begin
 598       jc.c.density_unit := 2; // Dots per cm
 599       jc.c.X_density := Round(XRes);
 600       jc.c.Y_density := Round(YRes)
 601     end;
 602   end;
 603
 604 begin
 605   Result := False;
 606   // Copy IO functions to global var used in JpegLib callbacks
 607   SetJpegIO(GetIO);
 608
 609   // Makes image to save compatible with Jpeg saving capabilities
 610   if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
 611   with JIO, ImageToSave do
 612   try
 613     ZeroMemory(@jc, SizeOf(jc));
 614     SetupErrorMgr(jc);
 615
 616     GetImageFormatInfo(Format, Info);
 617     FGrayScale := Format = ifGray8;
 618     InitCompressor(Handle, jc, Self);
 619     jc.c.image_width := Width;
 620     jc.c.image_height := Height;
 621     if FGrayScale then
 622     begin
 623       jc.c.input_components := 1;
 624       jc.c.in_color_space := JCS_GRAYSCALE;
 625     end
 626     else
 627     begin
 628       jc.c.input_components := 3;
 629       jc.c.in_color_space := JCS_RGB;
 630     end;
 631
 632     PtrInc := Width * Info.BytesPerPixel;
 633     Src := Bits;
 634
 635   {$IFDEF RGBSWAPPED}
 636     GetMem(Line, PtrInc);
 637   {$ENDIF}
 638
 639     // Save supported metadata
 640     SaveMetaData;
 641
 642     jpeg_start_compress(@jc.c, True);
 643     while (jc.c.next_scanline < jc.c.image_height) do
 644     begin
 645     {$IFDEF RGBSWAPPED}
 646       if Format = ifR8G8B8 then
 647       begin
 648         Move(Src^, Line^, PtrInc);
 649         Pix := PColor24Rec(Line);
 650         for I := 0 to Width - 1 do
 651         begin
 652           SwapValues(Pix.R, Pix.B);
 653           Inc(Pix, 1);
 654         end;
 655       end;
 656     {$ELSE}
 657       Line := Src;
 658     {$ENDIF}
 659
 660       LinesWritten := jpeg_write_scanlines(@jc.c, @Line, 1);
 661       Inc(Src, PtrInc * LinesWritten);
 662     end;
 663
 664     jpeg_finish_compress(@jc.c);
 665     Result := True;
 666   finally
 667     ReleaseContext(jc);
 668     if MustBeFreed then
 669       FreeImage(ImageToSave);
 670   {$IFDEF RGBSWAPPED}
 671     FreeMem(Line);
 672   {$ENDIF}
 673   end;
 674 end;
 675
 676 procedure TJpegFileFormat.ConvertToSupported(var Image: TImageData;
 677   const Info: TImageFormatInfo);
 678 begin
 679   if Info.HasGrayChannel then
 680     ConvertImage(Image, ifGray8)
 681   else
 682     ConvertImage(Image, ifR8G8B8);
 683 end;
 684
 685 function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
 686 var
 687   ReadCount: LongInt;
 688   ID: array[0..9] of AnsiChar;
 689 begin
 690   Result := False;
 691   if Handle <> nil then
 692   with GetIO do
 693   begin
 694     FillChar(ID, SizeOf(ID), 0);
 695     ReadCount := Read(Handle, @ID, SizeOf(ID));
 696     Seek(Handle, -ReadCount, smFromCurrent);
 697     Result := (ReadCount = SizeOf(ID)) and
 698       CompareMem(@ID, @JpegMagic, SizeOf(JpegMagic));
 699   end;
 700 end;
 701
 702 procedure TJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions);
 703 begin
 704   JIO := JpegIO;
 705 end;
 706
 707 initialization
 708   RegisterImageFileFormat(TJpegFileFormat);
 709
 710 {
 711   File Notes:
 712
 713  -- TODOS ----------------------------------------------------
 714     - nothing now
 715
 716   -- 0.77.1 ---------------------------------------------------
 717     - Able to read corrupted JPEG files - loads partial image
 718       and skips the corrupted parts (FPC and x86 Delphi).
 719     - Fixed reading of physical resolution metadata, could cause
 720       "divided by zero" later on for some files.
 721
 722   -- 0.26.5 Changes/Bug Fixes ---------------------------------
 723     - Fixed loading of some JPEGs with certain APPN markers (bug in JpegLib).
 724     - Fixed swapped Red-Blue order when loading Jpegs with
 725       jc.d.jpeg_color_space = JCS_RGB.
 726     - Added loading and saving of physical pixel size metadata.
 727
 728   -- 0.26.3 Changes/Bug Fixes ---------------------------------
 729     - Changed the Jpeg error manager, messages were not properly formated.
 730
 731   -- 0.26.1 Changes/Bug Fixes ---------------------------------
 732     - Fixed wrong color space setting in InitCompressor.
 733     - Fixed problem with progressive Jpegs in FPC (modified JpegLib,
 734       can't use FPC's PasJpeg in Windows).
 735
 736   -- 0.25.0 Changes/Bug Fixes ---------------------------------
 737     - FPC's PasJpeg wasn't really used in last version, fixed.
 738
 739   -- 0.24.1 Changes/Bug Fixes ---------------------------------
 740     - Fixed loading of CMYK jpeg images. Could cause heap corruption
 741       and loaded image looked wrong.
 742
 743   -- 0.23 Changes/Bug Fixes -----------------------------------
 744     - Removed JFIF/EXIF detection from TestFormat. Found JPEGs
 745       with different headers (Lavc) which weren't recognized.
 746
 747   -- 0.21 Changes/Bug Fixes -----------------------------------
 748     - MakeCompatible method moved to base class, put ConvertToSupported here.
 749       GetSupportedFormats removed, it is now set in constructor.
 750     - Made public properties for options registered to SetOption/GetOption
 751       functions.
 752     - Changed extensions to filename masks.
 753     - Changed SaveData, LoadData, and MakeCompatible methods according
 754       to changes in base class in Imaging unit.
 755     - Changes in TestFormat, now reads JFIF and EXIF signatures too.
 756
 757   -- 0.19 Changes/Bug Fixes -----------------------------------
 758     - input position is now set correctly to the end of the image
 759       after loading is done. Loading of sequence of JPEG files stored in
 760       single stream works now
 761     - when loading and saving images in FPC with PASJPEG read and
 762       blue channels are swapped to have the same chanel order as IMJPEGLIB
 763     - you can now choose between IMJPEGLIB and PASJPEG implementations
 764
 765   -- 0.17 Changes/Bug Fixes -----------------------------------
 766     - added SetJpegIO method which is used by JNG image format
 767 }
 768 end.