xmlworksdb.pas

delphi的XMPRPC通讯例子

unit XMLWorksDB;

interface
uses
  db;

function ADOXMLFromDataSet(Source: TDataSet): String;
function XMLFromDataSet(Source: TDataSet): String;
procedure  DataSetFromXML(Source: String; Target: TDataSet);

implementation
uses
  Classes,
  SysUtils;

type
  TXMLQuickParser = class (TObject)
  private
    FEoF: Boolean;
    FInStream: TMemoryStream;
    FCurrentToken: PChar;
    procedure SkipNonAscii;
    function ReadAscii: String;
    procedure SkipToEndTag;
    function CheckEOF: boolean;
  public
    constructor Create(InputStr: String);
    procedure SeekTag(CONST Tag: String);
    function GetNextTag: String;
    function ReadToNextTag: String;

    property EoF: Boolean read FEoF;
    property CurrentToken: PChar read FCurrentToken;
  end;


  EXMLParseException = class(Exception);


function XMLFromDataSet(Source: TDataSet): String;
var
  FieldIndex: Integer;
  slst: TStringList;
begin
  result := '';

  slst := TStringList.Create;
  try
    // Simple XML header
    slst.Add('<?xml version = "1.0" ?>');

    // Generic name for set of all records
    slst.Add('<RecordSet tablename="' + Source.Name + '">');

    while not Source.EOF do
    begin
      // Generic tag identifying new record
      slst.Add('<Record>');

      // Loop through each of the Fields in the DataSet
      for FieldIndex := 0 to Source.FieldCount-1 do
        // Generate the XML of the data
        slst.Add('<' + Source.Fields[FieldIndex].FieldName + '>' + Source.Fields[FieldIndex].AsString + '</' + Source.Fields[FieldIndex].FieldName + '>');

      // Closing record tag
      slst.Add('</Record>');

      // Go to the next record
      Source.Next;
    end;    // while

    slst.Add('</RecordSet>');

    // return the result
    result := slst.Text;
  finally
    slst.free;
  end;

end;

function FieldTypeToADOString(p_FieldType: TFieldType): string;
begin
  { TODO : Real values }
  case p_FieldType of
    ftUnknown, ftString, ftSmallint, ftInteger, ftWord,
    ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,
    ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo,
    ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString,
    ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob,
    ftVariant, ftInterface, ftIDispatch, ftGuid : result := 'string';
  end;
end;


function ADOXMLFromDataSet(Source: TDataSet): String;
const
  BoolToStrMAP : array[boolean] of string = ('true','false');
var
  FieldIndex: Integer;
  slst: TStringList;
begin
  result := '';

  slst := TStringList.Create;
  try
    // ADO XML Prolog
    slst.Add('<xml xmlns:s="uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882"');
    slst.Add('xmlns:dt="uuid:C2F41010-65B3-11d1-A29F-00AA00C14882"');
    slst.Add('xmlns:rs="urn:schemas-microsoft-com:rowset"');
    slst.Add('xmlns:z="#RowsetSchema">');


    // Schema
    slst.Add('<s:Schema id="RowsetSchema">');
    slst.Add('<s:ElementType name="row" content="eltOnly" rs:updatable="true">');

    // Loop through each of the Fields in the DataSet
    for FieldIndex := 0 to Source.FieldCount-1 do
    begin
      slst.Add(Source.Fields[FieldIndex].FieldName + '="' + Source.Fields[FieldIndex].AsString + '" ');

      slst.Add('<s:AttributeType name="' + Source.Fields[FieldIndex].FieldName + '" rs:number="' + IntToStr(FieldIndex) + '" rs:write="' + BoolToStrMAP[Source.Fields[FieldIndex].ReadOnly] + '">');
      slst.Add('<s:datatype dt:type="' + FieldTypeToADOString(Source.Fields[FieldIndex].DataType) + '" dt:maxLength="' + IntToStr(Source.Fields[FieldIndex].Size) + '"');
      slst.Add(' rs:maybenull="' + BoolToStrMAP[Source.Fields[FieldIndex].Required] + '"/>');
      // rs:precision='0' rs:long='true'
      slst.Add('</s:AttributeType>');
    end;

    slst.Add('<s:extends type="rs:rowbase"/>');
    slst.Add('</s:ElementType>');
    slst.Add('</s:Schema>');

    // Data
    slst.Add('<rs:data>');
    slst.Add('<rs:insert>');

    while not Source.EOF do
    begin
      // Generic tag identifying new record
      slst.Add('<z:row ');

      // Loop through each of the Fields in the DataSet
      for FieldIndex := 0 to Source.FieldCount-1 do
        // Add the Param for the Field
        slst.Add(Source.Fields[FieldIndex].FieldName + '="' + Source.Fields[FieldIndex].AsString + '" ');

      // Close record tag
      slst.Add(' />');

      // Go to the next record
      Source.Next;
    end;    // while

    slst.Add('</rs:insert>');
    slst.Add('</rs:data>');
    slst.Add('</xml>');


    // return the result
    result := slst.Text;
  finally
    slst.free;
  end;

end;


procedure DataSetFromXML(Source: String; Target: TDataSet);

var
  TempField: TField;
  TempValue: String;
  TempTag: string;
begin
  TempTag := '';

  with TXMLQuickParser.Create(Source) do
  begin
    while (AnsiCompareText(TempTag, 'RecordSet') <> 0) and (Not EoF) do
    begin
      TempTag := '';
      SeekTag('Record');
      if not EoF then
        Target.Insert;

      while not EoF do
      begin
        TempTag := GetNextTag;
        if AnsiCompareText(TempTag, '/Record') = 0 then
          break;

        TempField := Target.FindField(TempTag);

        if TempField <> nil then
        begin
          TempValue := ReadToNextTag;
          if TempValue <> '' then
            TempField.AsString := TempValue;
        end;

        TempValue := GetNextTag;
        if AnsiCompareText(TempValue, '/' + TempTag) <> 0 then
          raise EXMLParseException.Create('Invalid simple XML db file');
      end;

    end;  // while
  end;
end;

{ TxmlQuickParser }

function TxmlQuickParser.CheckEOF: boolean;
begin
  FEoF := (FCurrentToken - FInStream.Memory) > FInStream.Size;
  result := EoF;
end;

constructor TxmlQuickParser.Create(InputStr: String);

var
  TempStrStream: TStringStream;
begin
  FInStream  := TMemoryStream.Create;

  // This is ugly, but easy to code
  TempStrStream := TStringStream.Create(InputStr);
  try
    FInStream.CopyFrom(TempStrStream, 0);
  finally
    TempStrStream.Free
  end;

  // Force position to beginning
  FInStream.Position := 0;

  // Set the End of File flag
  FEoF := FInStream.Size = 0;

  // Set the internal pointer
  FCurrentToken := FInStream.Memory;
end;

function TxmlQuickParser.GetNextTag: String;
begin
  SkipNonAscii;
  result := ReadAscii;
  SkipToEndTag;
end;

function TxmlQuickParser.ReadAscii: String;
begin
  result := '';
  while (CurrentToken^ IN ['/','a'..'z','A'..'Z','0'..'9','_']) AND Not CheckEOF do
  begin
    result := result + CurrentToken^;
    Inc(FCurrentToken);
  end;

  if not CheckEoF and (CurrentToken^ = '<') then
    Inc(FCurrentToken);
    
end;

function TxmlQuickParser.ReadToNextTag: String;
begin
  result := '';

  while (CurrentToken^ <> '<') AND Not CheckEOF do
  begin
    result := result + CurrentToken^;
    Inc(FCurrentToken);
  end;
end;

procedure TxmlQuickParser.SeekTag(const Tag: String);
begin
  while (AnsiCompareText(GetNextTag, Tag) <> 0) AND Not EoF do;
end;

procedure TxmlQuickParser.SkipNonAscii;
begin
  while not (CurrentToken^ IN ['/','a'..'z','A'..'Z','0'..'9','_']) AND Not CheckEOF do
    Inc(FCurrentToken);
end;

procedure TxmlQuickParser.SkipToEndTag;
begin
  while (CurrentToken^ <> '>') AND Not CheckEOF do
    Inc(FCurrentToken);

  if Not CheckEOF then
    Inc(FCurrentToken);
end;

end.