paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
3813bcca82
lazarus-ccr/components/fpexif/fpeiptcreadwrite.pas
wp_xxyyzz 13726c172b fpexif: Fix compilation under Delphi 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6081 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2017-12-02 18:30:58 +00:00

487 lines
14 KiB
ObjectPascal
Raw Blame History

{
Reader and writer for IPTC data (Adobe image resource blocks)
NOTE: Data is in Big-Endian format.
Adobe Image Resource Block:
--------------------------
https://www.adobe.com/devnet-apps/photoshop/fileformatashtml/#50577409_pgfId-1037504
Length Description
------ ----------------------------------------------------------------
4 Signature: '8BIM'
2 Unique identifier for the resource.
(var) Name: Pascal string, padded to make the size even
(a null name consists of two bytes of 0)
4 Actual size of resource data that follows
(var) The resource data, described in the sections on the individual
resource types. It is padded to make the size even.
The image resource block with unique identifier $0404 is the IPTC block.
https://www.iptc.org/std/IIM/4.2/specification/IIMV4.2.pdf
The IPTC block consists of several "records".
Every "record" constists of several "datasets".
Every "dataset" consists of a unique tag and a data field.
There are two types of tags:
"Standard" tag:
- 1 byte: tag "marker" ($1C)
- 1 byte: record number
- 1 byte: dataset number
- 2 bytes: datafield byte count
"Extended" tag (probably not used):
- 1 byte: tag "marker" ($1C)
- 1 byte: record number
- 1 byte: dataset number
- 2 bytes: count of bytes (n) used in "datafield byte count" field
(always has highest bit set)
- n bytes: datafield byte count
}
unit fpeIptcReadWrite;
{$IFDEF FPC}
{$MODE objfpc}{$H+}
{$ENDIF}
interface
uses
Classes, SysUtils,
fpeGlobal, fpeUtils, fpeTags, fpeMetadata, fpeIptcData;
type
{ TIPTCReader }
TIPTCReader = class(TBasicMetadataReader)
private
function ExtractTag(const ABuffer: TBytes; var AStart: Integer): TTag;
procedure ReadImageResourceBlock(AStream: TStream; out AID: Word;
out AName: String; out AData: TBytes);
protected
public
procedure ReadFromStream(AStream: TStream; AImgFormat: TImgFormat); override;
procedure ReadIPTCData(const ABuffer: TBytes);
end;
{ TIPTCWriter }
TIPTCWriter = class(TBasicMetadataWriter)
private
FIPTCSegmentStartPos: Int64;
protected
procedure WriteEndOfDataResourceBlock(AStream: TStream);
procedure WriteImageResourceBlockHeader(AStream: TStream; AResourceID: Integer;
AResourceName: String); //; ABuffer: Pointer; ABufferSize: DWord);
procedure WriteIPTCHeader(AStream: TStream);
procedure WriteIPTCImageResourceBlock(AStream: TStream; AName: String);
procedure WriteTag(AStream: TStream; ATag: TTag); overload;
public
constructor Create(AImgInfo: TImgInfo); override;
procedure WriteToStream(AStream: TStream; AImgFormat: TImgFormat); override;
end;
implementation
uses
fpeStrConsts;
type
// http://search.cpan.org/dist/Image-MetaData-JPEG/lib/Image/MetaData/JPEG/Structures.pod#Structure_of_an_IPTC_data_block
TIptcTag = packed record
TagMarker: Byte; // must be $1C
RecordNumber: Byte; // this is the number before the colon in the tag listing
DatasetNumber: Byte; // this is the number after the colon in the tag listing ("Tag")
Size: Word; // Size of data if < 32768, otherwise size of datalength element
// SizeOfDatasize: word --> if Size of data > 32767
// Data: variable
end;
const
IPTC_SIGNATURE: ansistring = 'Photoshop 3.0'#0;
RESOURCE_MARKER: ansistring = '8BIM';
IPTC_IMAGERESOURCEID = $0404;
//------------------------------------------------------------------------------
// TIptcReader
//------------------------------------------------------------------------------
function TIptcReader.ExtractTag(const ABuffer: TBytes; var AStart: Integer): TTag;
var
recordNo: Byte;
datasetNo: Byte;
len: DWord;
tagdef: TTagDef;
tagID: TTagID;
s: String;
w: Word;
sa: ansistring;
begin
Result := nil;
recordNo := ABuffer[AStart];
datasetNo := ABuffer[AStart+1];
len := BEtoN(PWord(@ABuffer[AStart+2])^);
inc(AStart, 4);
// Take care of highest bit which indicates an Extended Dataset
if word(len) and $8000 <> 0 then
begin
len := word(len) and (not $8000);
if len = 2 then
begin
len := BEtoN(PWord(@ABuffer[AStart])^);
inc(AStart, 2);
end else
if len = 4 then
begin
len := BEtoN(PDWord(@ABuffer[AStart - len])^);
inc(AStart, 4);
end else
Error(Format(rsIptcExtendedDataSizeNotSupported, [len]));
end;
if not (recordNo in [1, 2, 8]) then begin
AStart := AStart + Integer(len);
exit;
end;
tagID := (recordNo shl 8) or datasetNo or TAGPARENT_IPTC;
tagdef := FindIPTCTagDef(tagID);
if tagdef <> nil then begin
Result := tagdef.TagClass.Create(tagdef, true);
case tagdef.TagType of
ttString:
begin
{$IFDEF FPC}
SetLength(s, len);
Move(ABuffer[AStart], s[1], len);
{$ELSE}
SetLength(sa,len);
Move(ABuffer[AStart], sa[1], len);
s := UTF8Decode(sa);
{$ENDIF}
if Result is TIptcDateTag then
with TIptcDateTag(Result) do begin
FormatStr := IPTC_DATE_FORMAT;
AsString := s;
FormatStr := '';
end
else
if Result is TIptcTimeTag then
with TIptcTimeTag(Result) do begin
FormatStr := IPTC_TIME_FORMAT;
AsString := s;
FormatStr := '';
end
else
(Result as TStringTag).AsString := s;
end;
ttUInt16:
begin
w := BEtoN(PWord(@ABuffer[AStart])^);
(Result as TIntegerTag).AsInteger := w;
end;
else
Warning(Format(rsTagTypeNotSupported, [tagDef.Name]));
end;
end else
begin
// to do: create a dummy tag for the unknown tagdef
end;
AStart := AStart + Integer(len);
end;
procedure TIptcReader.ReadFromStream(AStream: TStream; AImgFormat: TImgFormat);
const
MARKER_SIZE = 4;
var
marker: packed array[1..MARKER_SIZE] of ansichar;
lID: Word; // Image resoure ID
lName: String;
lData: TBytes;
begin
FImgFormat := AImgFormat;
SetLength(lData, Length(IPTC_SIGNATURE)); // 'Photoshop 3.0'
if AStream.Read(lData[0], Length(lData)) <> Length(lData) then begin
Error(rsIncorrectFileStructure);
exit;
end;
if not CompareMem(@lData[0], @IPTC_SIGNATURE[1], Length(lData)) then begin
Error(rsNoValidIptcSignature);
exit;
end;
while (AStream.Position < AStream.Size) do begin
AStream.Read({%H-}marker[1], MARKER_SIZE);
if AStream.Position >= AStream.Size then begin
Error(rsIncorrectFileStructure);
break;
end;
if not CompareMem(@marker[1], @RESOURCE_MARKER[1], MARKER_SIZE) then // '8BIM'
break;
ReadImageResourceBlock(AStream, lID, lName, lData);
if lID = IPTC_IMAGERESOURCEID then begin // $0404
FImgInfo.IptcData.AddImageResourceBlock(lID, lName, nil);
ReadIptcData(lData);
end else
FImgInfo.IptcData.AddImageResourceBlock(lID, lName, lData);
end;
end;
procedure TIptcReader.ReadImageResourceBlock(AStream: TStream;
out AID: Word; out AName: String; out AData: TBytes);
var
len: Byte;
s: Ansistring;
lSize: DWord;
begin
AID := BEtoN(ReadWord(AStream));
len := ReadByte(AStream);
if len = 0 then begin
ReadByte(AStream);
AName := '';
end else begin
SetLength(s, len);
AStream.Read(s[1], len);
if s[len] = #0 then SetLength(s, len-1);
AName := s;
end;
lSize := BEToN(ReadDWord(AStream));
SetLength(AData, lSize);
AStream.Read(AData[0], lSize);
end;
procedure TIptcReader.ReadIptcData(const ABuffer: TBytes);
var
tag, parentTag: TTag;
start: Integer;
begin
FImgInfo.IptcData.Clear;
if Length(ABuffer) = 0 then begin
Error(rsIptcDataExpected);
exit;
end;
start := 0;
while (start < High(ABuffer) - 1) do
begin
if ABuffer[start] <> $1C then
Error(rsNoValidIptcFile);
inc(start);
tag := ExtractTag(ABuffer, start);
if tag is TIptcMultiStringTag then begin
// if tag.Count = IPTC_MULTI_TAG_COUNT then begin
parentTag := FImgInfo.IptcData.TagByID[tag.TagID];
if parentTag = nil then
FImgInfo.IptcData.AddTag(tag)
else begin
FImgInfo.IptcData.AppendTagTo(tag, parentTag);
tag.Free;
end;
end else
FImgInfo.IptcData.AddTag(tag);
end;
end;
//------------------------------------------------------------------------------
// TIptcWriter
//------------------------------------------------------------------------------
constructor TIPTCWriter.Create(AImgInfo: TImgInfo);
begin
inherited;
FIPTCSegmentStartPos := -1;
end;
procedure TIptcWriter.WriteEndOfDataResourceBlock(AStream: TStream);
begin
WriteImageResourceBlockHeader(AStream, $0B04, ''); //, nil, 0);
end;
//------------------------------------------------------------------------------
// Writes the IPTC header needed by JPEG files (Segment APP13 header)
// Call WriteToStream immediately afterwards
//------------------------------------------------------------------------------
procedure TIPTCWriter.WriteIPTCHeader(AStream: TStream);
const
SEGMENT_MARKER: array[0..1] of byte = ($FF, $ED);
begin
FIPTCSegmentStartPos := AStream.Position;
AStream.WriteBuffer(SEGMENT_MARKER[0], 2);
// Next two zero bytes are the size of the entire IPTC segiment, they will be
// replaced when the segment is completely written. For this, we store the
// offset to the begin of the IPTC segment in FIPTCSegmentStartPos.
WriteWord(AStream, 0);
AStream.WriteBuffer(IPTC_SIGNATURE[1], Length(IPTC_SIGNATURE));
end;
procedure TIPTCWriter.WriteIPTCImageResourceBlock(AStream: TStream; AName: String);
var
i: Integer;
tag: TTag;
ms: TMemoryStream;
dw: DWord;
begin
// Write the image resource header
WriteImageResourceBlockHeader(AStream, IPTC_IMAGERESOURCEID, AName);
// Now, we must write the length of the ImageResourceBlock.
// Since we don't know this we write the tags to a memory stream first
ms := TMemoryStream.Create;
try
// Write the tags to the temporary memory stream
for i := 0 to FImgInfo.IptcData.TagCount-1 do begin
tag := FImgInfo.IptcData.TagByIndex[i];
WriteTag(ms, tag);
end;
// Now the length of the data field is known (ms.Size).
// Write the length field to "real" stream
dw := ms.Size;
WriteDWord(AStream, NtoBE(dw));
// Copy the tags from the memorystream to the "real" stream
ms.Position := 0;
AStream.Copyfrom(ms, ms.Size);
finally
ms.Free;
end;
end;
procedure TIPTCWriter.WriteImageResourceBlockHeader(AStream: TStream;
AResourceID: Integer; AResourceName: String);
var
dw: DWord;
sa: ansistring;
begin
// Resource marker: 8BIM
AStream.WriteBuffer(RESOURCE_MARKER[1], Length(RESOURCE_MARKER));
// Resource ID
WriteWord(AStream, NtoBE(word(AResourceID)));
// Resource name
if Length(AResourceName) = 0 then
WriteWord(AStream, 0)
else
begin
sa := AResourceName;
dw := Length(sa);
if dw > 255 then begin
dw := 255;
SetLength(sa, dw);
Warning(Format(rsImageResourceNameTooLong, [AResourceName]));
end;
if not odd(dw) then begin
inc(dw);
sa := sa + #0;
end;
WriteByte(AStream, byte(dw));
AStream.WriteBuffer(sa[1], dw);
end;
end;
procedure TIptcWriter.WriteTag(AStream: TStream; ATag: TTag);
const
TAG_MARKER = $1C;
var
iptcTag: TIptcTag;
len: DWord;
begin
iptcTag.TagMarker := byte(TAG_MARKER);
iptcTag.RecordNumber := byte((ATag.TagID and $FF00) shr 8);
iptctag.DatasetNumber := byte(ATag.TagID and $00FF);
case ATag.TagType of
ttUInt16:
begin
iptcTag.Size := NtoBE(2);
AStream.WriteBuffer(iptcTag, SizeOf(iptcTag));
AStream.WriteBuffer(ATag.RawData[0], 2);
end;
ttString:
begin
len := Length(ATag.RawData);
if odd(len) then begin
inc(len);
end;
// "Standard" dataset
if len < 32768 then begin
iptcTag.Size := NtoBE(word(len));
AStream.WriteBuffer(iptcTag, SizeOf(iptcTag));
AStream.WriteBuffer(ATag.RawData[0], Length(ATag.RawData));
end else
// "Extended" dataset
if len < 65536 then begin
// Size is 2, but we must set highest bit to mark tag as being extended.
iptcTag.Size := NtoBE($8002);
AStream.WriteBuffer(iptcTag, SizeOf(iptcTag));
WriteWord(AStream, NtoBE(word(len)));
AStream.WriteBuffer(ATag.RawData[0], Length(ATag.RawData));
end else begin
// Size is 4, but we must set highest bit to mark tag as being extended.
iptcTag.Size := $8004;
AStream.WriteBuffer(iptcTag, SizeOf(iptcTag));
WriteDWord(AStream, NtoBE(len));
AStream.WriteBuffer(ATag.RawData[0], Length(ATag.RawData));
end;
if odd(Length(ATag.RawData)) then // zero-termination of string
WriteByte(AStream, 0);
end;
else
// I've never seen other tag types than USHORT and STRING...
Error(Format(rsTagTypeNotSupported, [ATag.Name]));
end;
end;
procedure TIptcWriter.WriteToStream(AStream: TStream; AImgFormat: TImgFormat);
var
i: Integer;
lID: Word;
lName: String;
lData: TBytes;
begin
FImgFormat := AImgFormat;
case FImgFormat of
ifJpeg:
WriteIptcHeader(AStream);
else
Error(rsImageFormatNotSupported);
end;
if (FImgInfo.IptcData.GetImageResourceBlockCount = 0) and
(FImgInfo.IptcData.TagCount > 0)
then
FImgInfo.IptcData.AddImageResourceBlock(IPTC_IMAGERESOURCEID, '', nil);
for i := 0 to FImgInfo.IptcData.GetImageResourceBlockCount-1 do begin
FImgInfo.IptcData.GetImageResourceBlock(i, lID, lName, lData);
if lID = IPTC_IMAGERESOURCEID then
// Write the IPTC tags
WriteIptcImageResourceBlock(AStream, lName)
else begin
// Write the other image resource blocks.
WriteImageResourceBlockHeader(AStream, lID, lName);
if odd(Length(lData)) then begin
SetLength(lData, Length(lData) + 1);
lData[High(lData)] := 0;
end;
WriteDWord(AStream, NtoBE(Length(lData)));
AStream.Write(lData[0], Length(lData));
end;
end;
// If WriteToStream is called within a JPEG structure we must update the
// size of the IPTC segment.
UpdateSegmentSize(AStream, FIptcSegmentStartPos);
end;
end.
Reference in New Issue View Git Blame Copy Permalink