xmlvariants.pas

delphi的XMPRPC通讯例子

unit XMLVariants;

{
  XMLVariants
  Version   : 1.0.1
  Date      : 5/5/2002

  Descripton:
  For Latest Versions:
          http://www.DelphiHome.com/xml (North America)
          http://www.XMLWorks.de (German Mirror)

  Author: Sancho Fock
          http://www.thsfock.de
          [e-mail]

  History
  Author      Date         Task
  Sancho Fock 03.May 2002  Initial Revision
  Sancho Fock 05.May 2002  Fixed Bugs: VarArray with negative IndexBounds failed
                                       Interfaces in Arrays have always failed
                                       Made assigning InterfaceValues 2 variants more stable
  Marc Bir    14.May 2002  Added support for VariantArrays of differing types
                           (previously only supported variants)

  Description

    XMLVariants designed to assist XML Works in supporting variants.

    When working with XMLWorks i encountered that the variant support of XMLWorks
    had some problems. After discusing this with Marc and thinking about this problem
    i saw, that complete variant support was much more complicated thrm i thought first.

    Use VariantToXML to get a XMLTag for a variant
    Use XMLToVariant to get a variant value from a Tag created with VariantToXML
}

{$IFDEF VER140}
{$DEFINE Delphi6OrHigher}
{$ENDIF}

{$IFDEF VER150}
{$DEFINE Delphi6OrHigher}
{$ENDIF}

interface

type
  TVarArrayEncoder = class (TObject)
  private
    FArray: Variant;
    function getDimensionCount: Integer;
    function getElementTags4Dimensions: string;
    function getHighBound(Dimension: integer): Integer;
    function getLowBound(Dimension: Integer): Integer;
    function getOverallElementsCount: Integer;
    function GetXML: string;
  protected
    function getDataTag: string; virtual;
    function getDimensionBoundTag(Dimension: Integer): string; virtual;
    function getDimensionCountTag: string; virtual;
    function getVarTypeTag: string; virtual;
  public
    constructor create(const VariantArray: Variant);
  published
    property XML: string read GetXML;
  end;
  
  TVarArrayDecoder = class (TObject)
  private
    FCurrentVariant: Variant;
    FXML: string;
    function CreateProperArray: Variant;
    procedure FillVarArray(var Arr: variant);
    function GetArray: Variant;
    function GetBoundData(Dimension: Integer): string;
    function GetBoundTagName(Dimension: Integer): string;
    function GetDimensionCount: Integer;
    function GetElementTagName(Index: integer): string;
    function GetHighBound(Dimension: integer): Integer;
    function GetLowBound(Dimension: Integer): Integer;
    function GetOverallElementsCount: Integer;
    function GetVariantByElement(const Index: integer): string;
    function GetVarType: Integer;
    function IsProperArray(arr: variant): Boolean;
  public
    constructor Create(XML: string; CurrentVariant: Variant);
  published
    property VariantArray: Variant read GetArray;
  end;
  

function VariantToXML(const Value: variant): string;
procedure XMLToVariant(const p_sXML: string; var propValue: variant);
function VarTypeAsString(const vType: Integer): string;

const
  OPEN_TYPE_TAG = '<VariantType>';
  CLOSE_TYPE_TAG = '</VariantType>';
  OPEN_DATA_TAG = '<VariantData>';
  CLOSE_DATA_TAG = '</VariantData>';
  OPEN_ELEMENT_DATA_TAG = '<VariantArrayElements>';
  CLOSE_ELEMENT_DATA_TAG = '</VariantArrayElements>';
  OPEN_DIMENSION_TAG = '<DimCount>';
  CLOSE_DIMENSION_TAG = '</DimCount>';
  OPEN_DIM_BOUND_TAG = '<DimBound';
  CLOSE_DIM_BOUND_TAG = '</DimBound';
  ARRAY_ELEMENT_NAME = 'ArrayElement';


implementation
uses
{$IFDEF Delphi6OrHigher}
  Variants,  // Delphi 6 support for Variants
{$ENDIF}
  //Variants,
  XMLWorks2, // for usage of XMLToStr and StrToXML
  sysutils,
  FastStrings;

function getVariantDataTag(value: variant): string;
var
  data: string;
  encodeData: boolean;
  arrayEncoder: TVarArrayEncoder;
  vaType: Integer;
begin
  vaType := VarType(Value);
  if (vaType and varByRef) = varByRef then
  begin
    vaType := vaType - varByRef; // ignore the var by Ref Bit, we can't restore the variant as Ref anyway
  end;
  encodeData := true;
  case vaType of
    varEmpty: data := '';
    varNull: data := 'null';
    varSmallint, varInteger, varSingle,
      varDouble, varCurrency, varDate,
      varBoolean, varByte, varStrArg,
{$IFDEF Delphi6OrHigher}
      varLongWord, varInt64, varWord, varShortInt,
{$ENDIF}
      varString, varError, varOleStr: data := value;
    varUnknown, varDispatch:
      begin
        data := InterfaceToXML(Value);
        encodeData := false;
      end;
    (*varVariant  :;
    varAny      :;
    varTypeMask :;
    unsupported jet *)
  else
    if (vaType and varArray) = VarArray then
    begin
      arrayEncoder := TVarArrayEncoder.create(Value);
      try
        data := arrayEncoder.XML;
        encodeData := false;
      finally
        arrayEncoder.free;
      end;
    end
    else
    begin
      Data := 'Unsupported Variant Type';
      { TODO : Need a unknown/unsupported VariantType exception and raise it here }
    end;
  end;
  if encodeData then
    Data := StrToXML(data);
  Result := OPEN_DATA_TAG + data + CLOSE_DATA_TAG;
end;

function VariantToXML(const Value: variant): string;
var
  VarTags: string;
begin
  VarTags := OPEN_TYPE_TAG + StrToXML(IntToStr(VarType(Value))) + CLOSE_TYPE_TAG;
  result := VarTags + getVariantDataTag(Value)
end;

function VarTypeAsString(const vType: Integer): string;
begin
  case vType of
    varNull: Result := 'varNull';
    varEmpty: Result := 'varEmpty';
    varSmallint: Result := 'varSmallint';
    varInteger: Result := 'varInteger';
    varByte: Result := 'varByte';
    varSingle: Result := 'varSingle';
    varDouble: Result := 'varDouble';
    varCurrency: Result := 'varCurrency';
    varDate: Result := 'varDate';
    varBoolean: Result := 'varBoolean';
    varStrArg: Result := 'varStrArg';
    varString: Result := 'varString';
    varOleStr: Result := 'varOleStr';
    varError: Result := 'varError';
    varDispatch: Result := 'varDispatch';
    varUnknown: Result := 'varUnknown';
    varVariant: Result := 'varVariant';
    varAny: Result := 'varAny';
    varTypeMask: Result := 'varTypeMask';

{$IFDEF Delphi6OrHigher}
    varLongWord: Result := 'varLongWord';
    varInt64: Result := 'varInt64';
    varWord: Result := 'varWord';
    varShortInt: Result := 'varShortInt';
{$ENDIF}

  else
    if (vType and varArray) = VarArray then
      Result := 'varArray'
    else
      Result := 'varType is Unknown: ' + IntToStr(vType);
  end;
end;

procedure XMLToVariant(const p_sXML: string; var propValue: variant);
var
  varTags, varRawData: string;
  vType: integer;
  idx: integer;
  arrayDecoder: TVarArrayDecoder;
begin
  varTags := XMLtoStr(p_sXML);
  idx := 1;
  vType := StrToInt(FastParseTag(p_sXML, OPEN_TYPE_TAG, CLOSE_TYPE_TAG, idx));
  idx := 1;
  varRawData := FastParseTag(p_sXML, OPEN_DATA_TAG, CLOSE_DATA_TAG, idx);
  case vType of
    varNull: propValue := null; // if the value was null we have to restore the null value
                //here (the type is autmatically set(in XML you find "null" but this is only a string value
            // to improve the readablility of the XML)
    varEmpty, varSmallint, varInteger,
      varByte, varSingle, varDouble,
      varCurrency, varDate, varBoolean,
      varStrArg, varString, varOleStr,
{$IFDEF Delphi6OrHigher}
      varLongWord, varInt64, varWord, varShortInt,
{$ENDIF}
      varError: propValue := varAsType(varRawData, vType);
    varDispatch, varUnknown:
      begin
        if (VarType(propValue) = varDispatch) or (VarType(propValue) = varUnknown) then
        begin
          XMLToInterface(varRawData, propValue);
        end
        else
        begin
          propValue := VarAsType(propValue, vType); // if there is no current interface
        end; // set at least the type
      end;
(*    varVariant  :;
    varAny      :;
    varTypeMask :;
*)
  else
    if (vType and varArray) = VarArray then
    begin
      arrayDecoder := TVarArrayDecoder.create(p_sXML, PropValue);
      try
        propValue := arrayDecoder.VariantArray;
      finally
        arrayDecoder.free;
      end;
    end
    else
    begin
      { TODO : Need a unknown/unsupported VariantType exception and raise it here }
    end;
  end;
end;

{
******************************* TVarArrayEncoder *******************************
}
constructor TVarArrayEncoder.create(const VariantArray: Variant);
begin
  inherited create;
  FArray := VariantArray;
end;

function TVarArrayEncoder.getDataTag: string;
begin
  result := OPEN_ELEMENT_DATA_TAG + getElementTags4Dimensions + CLOSE_ELEMENT_DATA_TAG;
end;

function TVarArrayEncoder.getDimensionBoundTag(Dimension: Integer): string;
begin
  result := OPEN_DIM_BOUND_TAG + IntToStr(Dimension) + '>'
    + IntToStr(getLowBound(Dimension)) + ':'
    + IntToStr(getHighBound(Dimension))
    + CLOSE_DIM_BOUND_TAG + IntToStr(Dimension) + '>'
end;

function TVarArrayEncoder.getDimensionCount: Integer;
begin
  Result := VarArrayDimCount(FArray);
end;

function TVarArrayEncoder.getDimensionCountTag: string;
begin
  result := OPEN_DIMENSION_TAG + IntToStr(getDimensionCount) + CLOSE_DIMENSION_TAG;
end;

function TVarArrayEncoder.getElementTags4Dimensions: string;
var
  pArray: PVariant;
  pElement: Pointer;
  ElementSize, i: Integer;
  Tags: string;
begin
  tags := '';
  pArray := VarArrayLock(FArray);
  try
    ElementSize := TVarData(FArray).Varray.ElementSize;
    for i := 0 to self.getOverallElementsCount - 1 do
    begin
      pElement := Pointer(Integer(PArray) + i * ElementSize);
      tags := tags + '<' + ARRAY_ELEMENT_NAME + IntToStr(i) + '>';