lazarus-ccr/components/fpexif/fpexmpdata.pas

unit fpeXMPData;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, contnrs,
  {$IFDEF FPC}
  laz2_dom, laz2_xmlread,
  {$ENDIF}
  fpeGlobal, fpeTags;

const
  XMP_BASE_KEY = 'http://ns.adobe.com/xap/1.0/';
  XMP_KEY = XMP_BASE_KEY + #0; 

type
  TXMPData = class
  private
    FData: String;
    FDoc: TXMLDocument;
    FTags: TStringList;
//    FTags: TTagList;
    function GetTagByIndex(AIndex: Integer): String;
    function GetTagByName(ATagName: String): String;
    function GetTagCount: Integer;
  protected
    {$IFDEF FPC}
    procedure Create_RDFDescription_Tags(ANode: TDOMNode);
    procedure CreateTags;
    {$ENDIF}
  public
    constructor Create;
    destructor Destroy; override;
    procedure ReadFromStream(AStream: TStream; ASize: Integer = -1);
    procedure SaveToStream(AStream: TStream);
    property TagByIndex[AIndex: Integer]: String read GetTagByIndex;
    property TagByName[ATagName: String]: String read GetTagByName;
    property TagCount: Integer read GetTagCount;
  end;
      
function HasXMPHeader(AStream: TStream): Boolean;


implementation

function HasXMPHeader(AStream: TStream): Boolean;
var
  p: Int64;
  hdr: array of ansichar; 
begin
  p := AStream.Position;
  SetLength(hdr, Length(XMP_KEY));
  AStream.Read(hdr[0], Length(XMP_KEY)); 
  Result := CompareMem(@hdr[0], @XMP_KEY[1], Length(XMP_KEY));
  if not Result then
    AStream.Position := p;
end;

  
{ TXMPData }
  
constructor TXMPData.Create;
begin
  inherited;
  FTags := TStringList.Create; //TTagList.Create;
end;

destructor TXMPData.Destroy; 
begin
  {$IFDEF FPC}
  FDoc.Free;
  {$ENDIF}
  FTags.Free;
  inherited;
end;

{$IFDEF FPC}
procedure TXMPData.Create_RDFDescription_Tags(ANode: TDOMNode);
var
  node: TDOMNode;
  nodeName: String;
  i: Integer;
  attr: TDOMNode;
  tagName, tagValue: String;
  lTag: TTag;
begin
  while ANode <> nil do begin
    nodeName := ANode.NodeName;
    for i := 0 to ANode.Attributes.Length-1 do
    begin
      attr := ANode.Attributes.Item[i];
      tagName := attr.NodeName;
      tagValue := attr.NodeValue;
      FTags.Add(tagName + '=' + tagValue);
    end;
    if ANode.HasChildNodes then
    begin
      node := ANode.FirstChild;
      while node <> nil do 
      begin
        nodeName := node.NodeName;
        tagValue := node.TextContent;
        if tagName <> '' then
          FTags.Add(nodeName + '=' + tagValue);
        node := node.NextSibling;
      end;
    end;
    ANode := ANode.NextSibling;
  end;
end;
    
  
procedure TXMPData.CreateTags;
var
  stream: TStringStream;
  node: TDOMNode;
  nodeName: String;
begin
  FDoc.Free;
  stream := TStringStream.Create(FData);
  try
    ReadXMLFile(FDoc, stream);
  finally
    stream.Free;
  end;
  
  FTags.Clear;
  try
    node := FDoc.DocumentElement.FindNode('rdf:RDF');
    if node = nil then exit;
    node := node.FirstChild;
    while node <> nil do 
    begin
      nodeName := node.NodeName;
      if nodeName = 'rdf:Description' then
        Create_RDFDescription_Tags(node);
      node := node.NextSibling;
    end;
  except
    FTags.Clear;
    FreeAndNil(FDoc);
    raise;
  end;
end;
{$ENDIF}

function TXMPData.GetTagByIndex(AIndex: Integer):  String;
begin
  Result := FTags[AIndex];
end;

function TXMPData.GetTagByName(ATagName: String): String;
begin
  Result := FTags.Values[ATagName];;
end;

function TXMPData.GetTagCount: Integer;
begin
  Result := FTags.Count;
end;

procedure TXMPData.ReadFromStream(AStream: TStream; ASize: Integer = -1);
var
  p: Int64;
begin
  if ASize = -1 then 
    ASize := AStream.Size;
  SetLength(FData, ASize);
  p := AStream.Position;
  AStream.Read(FData[1], ASize);
  
  AStream.Position := p;
  {$IFDEF FPC}
  CreateTags;
  {$ENDIF}
end;

procedure TXMPData.SaveToStream(AStream: TStream);
begin
  if FData <> '' then
    AStream.Write(FData[1], Length(FData));
end;

end.