qimport3xml.pas

Advanced Data Import Component Suite for Borland Delphi and C++ Builder allows you to import your da

unit QImport3XML;

{$I QImport3VerCtrl.Inc}

interface

uses Classes, QImport3, IniFiles, QImport3StrTypes;

type

  TXMLTagList = class;

  TXMLTag = class(TCollectionItem)
  private
    FParent: TXMLTag;
    FTagList: TXMLTagList;
//    FName: string;
    FName: qiString;
    FAttributes: TqiStrings;
    FChildren: TXMLTagList;

    procedure SetAttributes(Value: TqiStrings);
    procedure SetChildren(Value: TXMLTagList);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;

    property Parent: TXMLTag read FParent;
    property TagList: TXMLTagList read FTagList;
//    property Name: string read FName write FName;
    property Name: qiString read FName write FName;
    property Attributes: TqiStrings read FAttributes write SetAttributes;
    property Children: TXMLTagList read FChildren write SetChildren;
  end;

  TXMLTagList = class(TCollection)
  private
    FParent: TxmlTag;
    function GetItem(Index: integer): TXMLTag;
    procedure SetItem(Index: integer; Value: TXMLTag);
  public
    constructor Create(Parent: TxmlTag);
    function Add: TXMLTag;
    property Parent: TxmlTag read FParent;
    property Items[Index: integer]: TXMLTag read GetItem write SetItem; default;
  end;

  TXMLFile = class
  private
    FStream: TFileStream;
    FFileName: string;
    FHeader: TXMLTag;
    FTags: TXMLTagList;
    FLoaded: boolean;
    FData: AnsiString;
    FEof: boolean;
    FPosition: integer;

    procedure SetHeader(Value: TXMLTag);
    procedure SetTags(Value: TXMLTagList);
    function GetFields: TXMLTagList;
    function GetFieldCount: integer;
    function GetRows: TXMLTagList;
    function GetRowCount: integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Open;
    procedure Close;
    function GetNextTag: TxmlTag;
    procedure Load(FieldsOnly: boolean);
    procedure Clear;

    property FileName: string read FFileName write FFileName;
    property Header: TXMLTag read FHeader write SetHeader;
    property Tags: TXMLTagList read FTags write SetTags;
    property Fields: TXMLTagList read GetFields;
    property FieldCount: integer read GetFieldCount;
    property Rows: TXMLTagList read GetRows;
    property RowCount: integer read GetRowCount;

    property Eof: boolean read FEof;
  end;

  TQImport3XML = class(TQImport3)
  private
    FXML: TXMLFile;
    FCounter: integer;
    FWriteOnFly: boolean;
    FXMLTag: TXMLTag;
  protected
    procedure BeforeImport; override;
    procedure AfterImport; override;
    procedure StartImport; override;
    function CheckCondition: boolean; override;
    procedure ChangeCondition; override;
    procedure FinishImport; override;
    procedure FillImportRow; override;
    function Skip: boolean; override;
    function ImportData: TQImportResult; override;

    procedure DoLoadConfiguration(IniFile: TIniFile); override;
    procedure DoSaveConfiguration(IniFile: TIniFile); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property FileName;
    property SkipFirstRows default 0;
    property WriteOnFly: boolean read FWriteOnFly write FWriteOnFly
      default false;
  end;

//function ParseXML(XMLFile: TXMLFile; const XML: string; FieldsOnly,
function ParseXML(XMLFile: TXMLFile; const XML: string; FieldsOnly,
  OneTag: boolean): TXMLTag;

implementation

uses SysUtils, QImport3Common, Math{$IFDEF VCL9}, Windows{$ENDIF};

const
  sFileNameNotDefined = 'File name is not defined';
  sFileNotFound = 'File %s not found';
  sXMLHeaderFailed = 'XML header failed';
  sFileNotXML = 'File %s is not in XML format';
  sUnexpectedSymbol = 'Unexpected symbol %s at position %d';
  sVersionAttributeExpected = 'Version attribute expected but $s found';
  sInvalidXMLDeclaration = 'Invalid XML declaration';
  sAttributeDuplicates = 'Attribute %s duplicates';
  sUnexpectedAttributeName = 'Unexpected attriute name %s';
  sExpectingOneButOtherFound = 'Expecting %s but %s found';
  sUnexpectedTagName = 'Unexpected tag name %s';
  sCorrespondingTagNotFound = '%s - corresponding tag not found';

const
  sWhiteSpace = [#$20, #$9, #$D, #$A];
  sLetter     = [#$41..#$5A, #$61..#$7A, #$C0..#$D6, #$D8..#$F6, #$F8..#$FF];
  sNumber     = [#$30..#$39];
  sNameChar   = sLetter + sNumber + ['.', '-', '_', ':', #$B7];
  sNameStart  = sLetter + ['_', ':'];
  sQuote      = ['"', ''''];
  sSlash      = '/';

  sQuot       = '"'; sQuotEncode = '"';
  sAmp        = '&'; sAmpEncode  = '&';
  sLt         = '<'; sLtEncode   = '&lt;';
  sGt         = '>'; sGtEncode   = '&gt;';
  sSp         = ' '; sSpEncode   = '&#160;';

  sEqual      = '=';
  sQuestion   = '?';

  sDATAPACKET = 'DATAPACKET';
  sMETADATA   = 'METADATA';
  sFIELDS     = 'FIELDS';
  sFIELD      = 'FIELD';
  sROWDATA    = 'ROWDATA';
  sROW        = 'ROW';

type
  TxmlState = (stWaitXMLDecl, stReadXMLDecl, stWaitTag, stReadTag, stBreak);
  TxmlTagState = (tstUnknown, tstWaitXMLDecl, tstWaitTagName, tstReadTagName,
    tstWaitAttrName, tstReadAttrName, tstWaitEqual, tstWaitAttrValue,
    tstReadAttrValue);

function ParseXML(XMLFile: TXMLFile; const XML: string; FieldsOnly,
  OneTag: boolean): TxmlTag;
var
//  i: integer;
  ch: Char;
  st: TxmlState;
  buf: string;
  FAttributes: TqiStrings;
  FTag: TXMLTag;
  FAttrName, FAttrValue: string;

  {procedure CheckTagName(const TagName: AnsiString);
  var
    WaitTagName: AnsiString;
  begin
    if not Assigned(FTag) then begin
      if AnsiCompareText(TagName, sDATAPACKET) = 0 then begin
        FTag := XMLFile.Tags.Add;
        FTag.Name := TagName;
      end
      else raise Exception.CreateFmt(sUnexpectedTagName, [TagName]);
    end
    else begin
      if (AnsiUpperCase(FTag.Name) = sDATAPACKET) then
        WaitTagName := sMETADATA
      else if (AnsiUpperCase(FTag.Name) = sMETADATA) then
        WaitTagName := sFIELDS
      else if (AnsiUpperCase(FTag.Name) = sFIELD)
    end
  end;}

  procedure CheckAttributeName(const AttrName: string);
  var
    i: integer;
  begin
    case st of
      stReadXMLDecl: begin
        if XMLFile.Header.Attributes.Count = 0 then begin
          if AttrName <> 'version' then
            raise Exception.CreateFmt(sVersionAttributeExpected, [AttrName]);
        end
        else if (AttrName = 'standalone') or (AttrName = 'encoding') then begin
          for i := 0 to XMLFile.Header.Attributes.Count - 1 do
            if XMLFile.Header.Attributes[i] = FAttrName then
              raise Exception.CreateFmt(sAttributeDuplicates, [FAttrName]);
        end
        else raise Exception.CreateFmt(sUnexpectedAttributeName, [AttrName]);
      end;
    end;
    FAttrName := AttrName;
  end;

//  procedure ReadAttributes(const AttrStr: string);
  procedure ReadAttributes(const AttrStr: qiString);
  var
    i: integer;
    tst: TxmlTagState;
//    ch: Char;
    ch: qiChar;
//    buf: string;
    buf: qiString;
//    qu: Char;
    qu: qiChar;
  begin
    tst := tstWaitAttrName;
    buf := EmptyStr;
    qu := #0;
    for i := 1 to Length(AttrStr) do begin
      ch := AttrStr[i];
      case tst of
        tstWaitAttrName: begin
          if QImport3Common.CharInSet(ch, sWhiteSpace) then
            tst := tstWaitAttrName
          else if QImport3Common.CharInSet(ch, sNameStart) then begin
            tst := tstReadAttrName;
            buf := EmptyStr;
          end
          else
          raise Exception.CreateFmt(sUnexpectedSymbol, [ch, i]);
        end;
        tstReadAttrName: begin
          if QImport3Common.CharInSet(ch, sNameChar) then
            tst := tstReadAttrName
          else if QImport3Common.CharInSet(ch, sWhiteSpace) then begin
            CheckAttributeName(buf);
            tst := tstWaitEqual;
          end
          else if ch = sEqual then begin
            CheckAttributeName(buf);
            tst := tstWaitAttrValue;
          end
          else raise Exception.CreateFmt(sUnexpectedSymbol, [ch, i]);
        end;
        tstWaitEqual: begin
          if QImport3Common.CharInSet(ch, sWhiteSpace) then
            tst := tstWaitEqual
          else if ch = sEqual then
            tst := tstWaitAttrValue
          else raise Exception.CreateFmt(sUnexpectedSymbol, [ch, i]);
        end;
        tstWaitAttrValue: begin
          if QImport3Common.CharInSet(ch, sWhiteSpace) then
            tst := tstWaitAttrValue
          else if QImport3Common.CharInSet(ch, sQuote) then begin
            qu := ch;
            tst := tstReadAttrValue;
            buf := EmptyStr;
            Continue;
          end
          else raise Exception.CreateFmt(sUnexpectedSymbol, [ch, i]);
        end;
        tstReadAttrValue: begin
          if QImport3Common.CharInSet(ch, sQuote) and (ch = qu) then begin
            FAttrValue := buf;
            if Assigned(FAttributes) then begin
              FAttributes.Values[FAttrName] := FAttrValue;
              tst := tstWaitAttrName;
              buf := EmptyStr;
              FAttrName := EmptyStr;
              FAttrValue := EmptyStr;
            end;
            qu := #0;
          end;
        end;
      end;
      buf := buf + ch;
    end;
  end;

//  procedure ParseXMLTag(const Tag: string);
  procedure ParseXMLTag(const Tag: qiString);
  var
    i: integer;
//    ch: Char;
    ch: qiChar;
//    buf: string;
    buf: qiString;
    tst: TxmlTagState;
    TagList: TXMLTagList;
    NewTag: TXMLTag;
  begin
    buf := EmptyStr;
    case st of
      stReadXMLDecl: begin
        buf := Copy(Tag, 1, 4);
        if (buf = '?xml') and (Tag[Length(Tag)] = '?') then begin
          FAttributes := XMLFile.Header.Attributes;
          buf := Copy(Tag, 5, Length(Tag) - 5);
          ReadAttributes(buf);
          //utf-8
//          XMLFile.Futf8 := (AnsiUpperCase(FAttributes.Values['encoding']) = 'UTF-8');
        end
        else raise Exception.Create(sXMLHeaderFailed)
      end;
      stReadTag: begin
        tst := tstWaitTagName;
        for i := 1 to Length(Tag) do begin
          ch := Tag[i];
          case tst of
            tstWaitTagName: begin
              if QImport3Common.CharInSet(ch, sNameStart + [sSlash]) then
                tst := tstReadTagName
              else raise Exception.CreateFmt(sUnexpectedSymbol, [ch, i]);
            end;
            tstReadTagName: begin
              if QImport3Common.CharInSet(ch, sNameChar) then
                tst := tstReadTagName
              else if QImport3Common.CharInSet(ch,sWhiteSpace) then
                Break
              else raise Exception.CreateFmt(sUnexpectedSymbol, [ch, i]);
            end;
          end;
          buf := buf + ch;
        end;

        if buf[1] = sSlash then begin
          if not OneTag then begin
            if not (Assigned(FTag) and
               (Copy(buf, 2, Length(buf) - 1) = FTag.Name)) then
              raise Exception.CreateFmt(sCorrespondingTagNotFound, [buf]);
            FTag := FTag.Parent;
            if (AnsiUpperCase(buf) = sSlash + sFields) and FieldsOnly then
              st := stBreak;
          end
        end
        else begin
          //CheckTagName(buf);

          if not OneTag then begin
            if not Assigned(FTag)
              then TagList := XMLFile.Tags
              else TagList := FTag.Children;

            NewTag := TagList.Add;
          end
          else NewTag := TXMLTag.Create(nil);

          NewTag.Name := buf;
          FAttributes := NewTag.Attributes;
          if Tag[Length(Tag)] <> sSlash then FTag := NewTag;

          buf := Copy(Tag, Length(buf) + 1,
            Length(Tag) - Length(buf) - Integer(Tag[Length(Tag)] = sSlash));
          ReadAttributes(buf);

          //*****
          Result := NewTag;
          //if Assigned(XMLFile.OnLoadTag) then XMLFile.OnLoadTag(XMLFile, NewTag);
        end;
      end;
    end;
  end;

begin
  Result := nil;
  buf := EmptyStr;
  if XMLFile.FPosition = 1
    then st := stWaitXMLDecl
    else st := stWaitTag;
  FAttributes := nil;
  FTag := nil;
  FAttrName := EmptyStr;
  FAttrValue := EmptyStr;
  //i := 1;

  while XMLFile.FPosition <{=} Length(XML) do begin
    ch := XML[XMLFile.FPosition];

    case st of
      stWaitXMLDecl: begin
        if QImport3Common.CharInSet(ch, sWhiteSpace) then
          st := stWaitXMLDecl
        else if ch = sLt then begin
          st := stReadXMLDecl;
          FAttributes := XMLFile.Header.Attributes;
          buf := EmptyStr;
          Inc(XMLFile.FPosition);
          Continue;
        end