qimport3xml.pas

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

        else raise Exception.CreateFmt(sUnexpectedSymbol, [ch, XMLFile.FPosition]);
      end;
      stReadXMLDecl: begin
        if ch = sGt then begin
          ParseXMLTag(buf);
          st := stWaitTag;
        end;
      end;
      stWaitTag: begin
        if QImport3Common.CharInSet(ch, sWhiteSpace) then
          st := stWaitTag
        else if ch = sLt then begin
          st := stReadTag;
          buf := EmptyStr;
          Inc(XMLFile.FPosition);
          Continue;
        end
        else raise Exception.CreateFmt(sUnexpectedSymbol, [ch, XMLFile.FPosition]);
      end;
      stReadTag: begin
        if ch = sGt then begin
          ParseXMLTag(buf);
          if OneTag then begin
            Inc(XMLFile.FPosition);
            Exit;
          end;
          st := stWaitTag;
        end;
      end;
      stBreak: Exit;
    end;

    buf := buf + ch;
    Inc(XMLFile.FPosition);
  end;
  XMLFile.FEof := true;
end;

{ TXMLTag }

constructor TXMLTag.Create(Collection: TCollection);
begin
  inherited;
  FTagList := nil;
  if Collection is TXMLTagList then
    FTagList := Collection as TXMLTagList;
  FParent := nil;
  if Assigned(FTagList) and Assigned(FTagList.Parent) then
    FParent := FTagList.Parent;
  FAttributes := TqiStringList.Create;
  FChildren := TXMLTagList.Create(Self);
end;

destructor TXMLTag.Destroy;
begin
  FChildren.Free;
  FAttributes.Free;
  inherited;
end;

procedure TXMLTag.SetAttributes(Value: TqiStrings);
begin
  FAttributes.Assign(Value);
end;

procedure TXMLTag.SetChildren(Value: TXMLTagList);
begin
  FChildren.Assign(Value);
end;

{ TXMLTagList }

function TXMLTagList.Add: TXMLTag;
begin
  Result := TXMLTag(inherited Add)
end;

constructor TXMLTagList.Create(Parent: TxmlTag);
begin
  inherited Create(TXMLTag);
  FParent := Parent;
end;

function TXMLTagList.GetItem(Index: integer): TXMLTag;
begin
  Result := TXMLTag(inherited Items[Index]);
end;

procedure TXMLTagList.SetItem(Index: integer; Value: TXMLTag);
begin
  inherited Items[Index] := Value;
end;

{ TXMLFile }

constructor TXMLFile.Create;
begin
  inherited;
  FHeader := TXMLTag.Create(nil);
  FTags := TXMLTagList.Create(nil);
  FLoaded := false;
  FEof := true;
end;

destructor TXMLFile.Destroy;
begin
  FTags.Free;
  FHeader.Free;
  inherited;
end;

procedure TXMLFile.Open;
begin
  if FFileName = EmptyStr then
    raise Exception.Create(sFileNameNotDefined);
  if not FileExists(FFileName) then
    raise Exception.CreateFmt(sFileNotFound, [FFileName]);
  FStream := TFileStream.Create(FFileName, fmOpenRead or fmShareDenyWrite);
  FStream.Position := 0;
  SetLength(FData, FStream.Size);
  FStream.Read(FData[1], FStream.Size);
  FPosition := 1;
  FEof := false;
end;

procedure TXMLFile.Close;
begin
  FStream.Free;
  FEof := true;
end;

function TXMLFile.GetNextTag: TxmlTag;
begin
  Result := ParseXML(Self, string(FData), false, true);
end;

procedure TXMLFile.Load(FieldsOnly: boolean);
{var
  FStream: TFileStream;}
begin
  {if FFileName = EmptyStr then
    raise Exception.Create(sFileNameNotDefined);
  if not FileExists(FFileName) then
    raise Exception.CreateFmt(sFileNotFound, [FFileName]);

  FStream := TFileStream.Create(FFileName, fmOpenRead or fmShareDenyWrite);}
  Open;
  try
    {FStream.Position := 0;
    SetLength(FData, FStream.Size);
    FStream.Read(FData[1], FStream.Size);}
    ParseXML(Self, string(FData), FieldsOnly, false);
    FLoaded := true;
  finally
    Close;
    //FStream.Free;
  end;
end;

procedure TXMLFile.Clear;
begin
  Header.Name := EmptyStr;
  Header.Attributes.Clear;
  Header.Children.Clear;
  Tags.Clear;
  FLoaded := false;
end;

procedure TXMLFile.SetHeader(Value: TXMLTag);
begin
  FHeader.Assign(Value);
end;

procedure TXMLFile.SetTags(Value: TXMLTagList);
begin
  FTags.Assign(Value);
end;

function TXMLFile.GetFields: TXMLTagList;
var
  i, j, k: integer;
begin
  Result := nil;
  for i := 0 to Tags.Count - 1 do
    if AnsiCompareText(Tags[i].Name, sDATAPACKET) = 0 then
      for j := 0 to Tags[i].Children.Count - 1 do
        if AnsiCompareText(Tags[i].Children[j].Name, sMETADATA) = 0 then
          for k := 0 to Tags[i].Children[j].Children.Count - 1 do
            if AnsiCompareText(Tags[i].Children[j].Children[k].Name, sFIELDS) = 0 then
              Result := Tags[i].Children[j].Children[k].Children;
end;

function TXMLFile.GetFieldCount: integer;
var
  List: TXMLTagList;
begin
  Result := 0;
  if not FLoaded then Exit;
  List := GetFields;
  if Assigned(List) then Result := List.Count;
end;

function TXMLFile.GetRows: TXMLTagList;
var
  i, j: integer;
begin
  Result := nil;
  for i := 0 to Tags.Count - 1 do
    if AnsiCompareText(Tags[i].Name, sDATAPACKET) = 0 then
      for j := 0 to Tags[i].Children.Count - 1 do
        if AnsiCompareText(Tags[i].Children[j].Name, sROWDATA) = 0 then
          Result := Tags[i].Children[j].Children;
end;

function TXMLFile.GetRowCount: integer;
var
  List: TXMLTagList;
begin
  Result := 0;
  if not FLoaded then Exit;
  List := GetRows;
  if Assigned(List) then Result := List.Count;
end;

{ TQImport3XML }

constructor TQImport3XML.Create(AOwner: TComponent);
begin
  inherited;
  SkipFirstRows := 0;
  FWriteOnFly := false;
end;

procedure TQImport3XML.BeforeImport;
begin
  FXML := TXMLFile.Create;
  FXML.FileName := FileName;
  if FWriteOnFly
    then FXML.Open
    else FXML.Load(false);
  FTotalRecCount := FXML.RowCount;
  inherited;
end;

procedure TQImport3XML.AfterImport;
begin
  if Assigned(FXML) then begin
    if FWriteOnFly then FXML.Close;
    FXML.Free;
    FXML := nil;
  end;
  inherited;
end;

procedure TQImport3XML.DoLoadConfiguration(IniFile: TIniFile);
begin
  inherited;
  with IniFile do begin
    SkipFirstRows := ReadInteger(XML_OPTIONS, XML_SKIP_LINES, SkipFirstRows);
    WriteOnFly := ReadBool(XML_OPTIONS, XML_WRITE_ON_FLY, WriteOnFly);
  end;
end;

procedure TQImport3XML.DoSaveConfiguration(IniFile: TIniFile);
begin
  inherited;
  with IniFile do begin
    WriteInteger(XML_OPTIONS, XML_SKIP_LINES, SkipFirstRows);
    WriteBool(XML_OPTIONS, XML_WRITE_ON_FLY, WriteOnFly);
  end;
end;

procedure TQImport3XML.StartImport;
begin
  FCounter := 0;
end;

function TQImport3XML.CheckCondition: boolean;
begin
  if FWriteOnFly then begin
    repeat
      if Assigned(FXMLTag) then begin
        FXMLTag.Free;
        FXMLTag := nil;
      end;
      FXMLTag := FXML.GetNextTag;
    until (Assigned(FXMLTag) and (AnsiUpperCase(FXMLTag.Name) = 'ROW')) or FXML.Eof;
    Result := Assigned(FXMLTag);
  end
  else Result := FCounter < FXML.RowCount;
end;

procedure TQImport3XML.ChangeCondition;
begin
  Inc(FCounter);
end;

procedure TQImport3XML.FinishImport;
begin
  if not Canceled and not IsCSV then
  begin
    if CommitAfterDone then
      DoNeedCommit
    else if (CommitRecCount > 0) and ((ImportedRecs + ErrorRecs) mod CommitRecCount > 0) then
      DoNeedCommit;
  end;
end;

procedure TQImport3XML.FillImportRow;
var
  j, k, l: integer;
  str: qiString;
  mapValue: qiString;
  p: Pointer;
begin
  FImportRow.ClearValues;

  if not FWriteOnFly and not Assigned(FXML.Rows) then Exit;

  for j := 0 to FImportRow.Count - 1 do
  begin
    if FImportRow.MapNameIdxHash.Search(FImportRow[j].Name, p) then
    begin
      k := Integer(p);

      if FWriteOnFly then
      begin
        if Assigned(FXMLTag) then
        begin
          l := FXMLTag.Attributes.IndexOfName(FImportRow[j].Name);
          str := '';
          if l > -1 then
            str := FXMLTag.Attributes.Values[FImportRow[j].Name];
          FXMLTag.Free;
          FXMLTag := nil;
          FXMLTag := FXML.GetNextTag;
        end;
      end
      else begin
{$IFDEF VCL7}
        mapValue := Map.ValueFromIndex[k];
{$ELSE}
        mapValue := Map.Values[FImportRow[j].Name];
{$ENDIF}
        str := FXML.Rows[FCounter].Attributes.Values[mapValue];
      end;

      str := StringReplace(str, sQuotEncode, sQuot, [rfReplaceAll, rfIgnoreCase]);
      str := StringReplace(str, sAmpEncode, sAmp, [rfReplaceAll, rfIgnoreCase]);
      str := StringReplace(str, sLtEncode, sLt, [rfReplaceAll, rfIgnoreCase]);
      str := StringReplace(str, sGtEncode, sGt, [rfReplaceAll, rfIgnoreCase]);
      str := StringReplace(str, sSpEncode, sSp, [rfReplaceAll, rfIgnoreCase]);

      FImportRow.SetValue(Map.Names[k], str, false);
    end;
    DoUserDataFormat(FImportRow[j]);
  end;
end;

function TQImport3XML.Skip: boolean;
begin
  Result := (SkipFirstRows > 0) and (FCounter < SkipFirstRows);
end;

function TQImport3XML.ImportData: TQImportResult;
begin
  Result := qirOk;
  try
    try
      if Canceled  and not CanContinue then begin
        Result := qirBreak;
        Exit;
      end;

      DataManipulation;

    except
      on E:Exception do begin
        try
          DestinationCancel;
        except
        end;
        DoImportError(E);
        Result := qirContinue;
        Exit;
      end;
    end;
  finally
    if (not IsCSV) and (CommitRecCount > 0) and not CommitAfterDone and
       (
        ((ImportedRecs + ErrorRecs) > 0)
        and ((ImportedRecs + ErrorRecs) mod CommitRecCount = 0)
       )
    then
      DoNeedCommit;
    if (ImportRecCount > 0) and
       ((ImportedRecs + ErrorRecs) mod ImportRecCount = 0) then
      Result := qirBreak;
  end;
end;

end.