unit hkJpegLoad;
{.$define libjpeg-turbo}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
{$ifdef libjpeg-turbo}
turbojpeg, ctypes,
{$else}
FPReadJPEG,
{$EndIf}
BGRABitmap,
BGRABitmapTypes;
function LoadJpegFromFile(const aFileName: string): TBGRABitmap;
function LoadJpegFromMemStream(aStream: TMemoryStream): TBGRABitmap;
implementation
function IsAdobeRGB(aStream: TMemoryStream): boolean;
var pCnt, pSize: Int64;
p, picc, pdesc: PByte;
pw: PWord;
pdw: PDWord;
len, offset, tagcount: integer;
pFoundApp2: boolean;
s, sdesc: ansistring;
begin
Result := False;
// Find APP2 marker $FF $E2
// Check valid Jpeg file must start with $FF $D8
p := aStream.Memory;
if p^ <> $FF then exit;
inc(p);
if p^ <> $D8 then exit;
pFoundApp2 := False;
pCnt := 2;
pSize := aStream.Size;
inc(p);
while (pCnt < pSize) do begin
if p^ <> $FF then
exit;
inc(p);
if p^ = $DA then begin
// $DA SOS marker stop loop, app2 not found
exit;
end;
if p^ = $E2 then begin
pFoundApp2 := True;
break;
end;
inc(p);
pw := PWord(p);
len := BEToN(pw^);
inc(p, len);
pCnt := pCnt + 2 + len;
end;
if not pFoundApp2 then
exit;
inc(p);
pw := PWord(p);
len := BEToN(pw^); // length of app2 data
inc(p,2); // point to ICC_PROFILE#0 12-bytes
inc(p, 12);
// implemented only 65535 length icc_profile
if p^<>1 then
exit; // first chunk
inc(p);
if p^<>1 then
exit; // total num of chunks
inc(p);
pdw := PDWord(p);
len := BEToN(pdw^);
// Now we have ICC_Profile pointing in p with length=len
picc := p;
// icc_parsing looking for description tag desc with value "Adobe RGB (1998)"
inc(p, $80); // go to tag count in tag table
pdw := PDWord(p);
tagcount := BEToN(pdw^); // Number of tags;
inc(p,4);
SetLength(s, 4);
while tagcount>0 do begin
Move(p^, s[1], 4);
if s='desc' then begin
inc(p, 4);
pdw := PDWord(p);
offset := BEToN(pdw^);
inc(p, 4);
pdw := PDWord(p);
len := BEToN(pdw^);
pdesc := picc + offset;
inc(pdesc, 8); // skip desc and 4 $0
pdw := PDWord(pdesc);
len := BEToN(pdw^);
inc(pdesc, 4);
SetLength(sdesc, len);
Move(pdesc^, sdesc[1], len);
if AnsiStrComp(PChar(sdesc), PChar('Adobe RGB (1998)'))=0 then begin
Result := True;
break;
end;
end;
inc(p, 12);
dec(tagcount);
end;
end;
function LoadJpegFromFile(const aFileName: string): TBGRABitmap;
var ms: TMemoryStream;
begin
ms := TMemoryStream.Create;
try
ms.LoadFromFile(aFileName);
Result := LoadJpegFromMemStream(ms);
finally
ms.Free;
end;
end;
function LoadJpegFromMemStream(aStream: TMemoryStream): TBGRABitmap;
var b: TBGRABitmap;
p: PBGRAPixel;
i: Integer;
{$ifdef libjpeg-turbo}
function LoadTurbo: TBGRABitmap;
var jpegDecompressor: tjhandle;
jpegWidth,jpegHeight: cint;
jpegSubSamp: cint;
begin
jpegDecompressor := tjInitDecompress();
tjDecompressHeader2(jpegDecompressor, PCUChar(aStream.Memory), aStream.Size, @jpegWidth, @jpegHeight, @jpegSubsamp);
Result := TBGRABitmap.Create(jpegWidth, jpegHeight);
tjDecompress2(jpegDecompressor, PCUChar(aStream.Memory), aStream.Size, pcuchar(Result.Data), jpegWidth, 0, jpegHeight, cint(TJPF_BGRA), {TJFLAG_FASTDCT}TJFLAG_ACCURATEDCT);
tjDestroy(jpegDecompressor);
end;
{$else}
function LoadBGRA: TBGRABitmap;
var pReader: TFPReaderJPEG;
begin
pReader := TFPReaderJPEG.Create;
try
pReader.Performance:=jpBestQuality;
Result := TBGRABitmap.Create;
Result.LoadFromStream(aStream, pReader, []);
finally
pReader.Free;
end;
end;
{$endif}
begin
{$ifdef libjpeg-turbo}
b := LoadTurbo;
{$else}
b := LoadBGRA;
{$EndIf}
if IsAdobeRGB(aStream) then begin
p := b.Data;
for i := 0 to b.NbPixels-1 do
begin
p^ := TAdobeRGBA.New(p^.red, p^.green, p^.blue);
inc(p);
end;
end;
Result := b;
end;
end.
Recent
