ImagingJpeg.pas 23 KB

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