ImagingJpeg.pas 22 KB

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