nativexml.pas

delphi通讯程序,需要用delphi做通讯的朋友有个参考的例子

{$ENDIF}

// Delphi 4 stubs
{$IFNDEF D5UP}
type
  widestring = string;
function AnsiPos(const Substr, S: string): Integer;
function AnsiQuotedStr(const S: string; Quote: Char): string;
function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string;
procedure FreeAndNil(var Obj);
{$ENDIF}

// cross-platform pointer type
type
  {$IFDEF CLR}
  TPointer = TObject;
  {$ELSE}
  TPointer = Pointer;
  {$ENDIF}

// Delphi 5 stubs
{$IFNDEF D6UP}
type
  TSeekOrigin = Word;
const
  soBeginning = soFromBeginning;
  soCurrent = soFromCurrent;
  soEnd = soFromEnd;
{$ENDIF}

type

  // Note on TNativeXml.Format:
  // - xfReadable (default) to be able to read the xml file with a standard editor.
  // - xfCompact to save the xml fully compliant and at smallest size
  TXmlFormatType = (
    xfReadable,   // Save in readable format with CR-LF and indents
    xfCompact     // Save without any control chars except LF after declarations
  );

  // TXmlElementType enumerates the different kinds of elements that can be found
  // in the XML document.
  TXmlElementType = (
    xeNormal,      // Normal element <name {attr}>[value][sub-elements]</name>
    xeComment,     // Comment <!--{comment}-->
    xeCData,       // literal data <![CDATA[{data}]]>
    xeDeclaration, // XML declaration <?xml{declaration}?>
    xeStylesheet,  // Stylesheet <?xml-stylesheet{stylesheet}?>
    xeDoctype,     // DOCTYPE DTD declaration <!DOCTYPE{spec}>
    xeElement,     // <!ELEMENT >
    xeAttList,     // <!ATTLIST >
    xeEntity,      // <!ENTITY >
    xeNotation,    // <!NOTATION >
    xeExclam,      // Any <!data>
    xeQuestion,    // Any <?data?>
    xeCharData,    // Character data in a node
    xeUnknown      // Any <data>
  );

  // Choose what kind of binary encoding will be used when calling
  // TXmlNode BufferRead and BufferWrite.
  TBinaryEncodingType = (
    xbeBinHex,  { With this encoding, each byte is stored as a hexadecimal
                  number, e.g. 0 = 00 and 255 = FF.                        }
    xbeBase64   { With this encoding, each group of 3 bytes are stored as 4
                  characters, requiring 64 different characters.}
  );

  // Definition of different methods of string encoding.
  TStringEncodingType = (
    se8Bit,      // General 8 bit encoding, encoding must be determined from encoding declaration
    seUCS4BE,    // UCS-4 Big Endian
    seUCS4LE,    // UCS-4 Little Endian
    seUCS4_2143, // UCS-4 unusual octet order (2143)
    seUCS4_3412, // UCS-4 unusual octet order (3412)
    se16BitBE,   // General 16 bit Big Endian, encoding must be determined from encoding declaration
    se16BitLE,   // General 16 bit Little Endian, encoding must be determined from encoding declaration
    seUTF8,      // UTF-8
    seUTF16BE,   // UTF-16 Big Endian
    seUTF16LE,   // UTF-16 Little Endian
    seEBCDIC     // EBCDIC flavour
  );

  TXmlCompareOption = (
    xcNodeName,
    xcNodeType,
    xcNodeValue,
    xcAttribCount,
    xcAttribNames,
    xcAttribValues,
    xcChildCount,
    xcChildNames,
    xcChildValues,
    xcRecursive
  );

  TXmlCompareOptions = set of TXmlCompareOption;

const

  xcAll: TXmlCompareOptions = [xcNodeName, xcNodeType, xcNodeValue, xcAttribCount,
    xcAttribNames, xcAttribValues, xcChildCount, xcChildNames, xcChildValues,
    xcRecursive];

var

  // XML Defaults

  cDefaultEncodingString:      string              = 'windows-1252';
  cDefaultExternalEncoding:    TStringEncodingType = se8bit;
  cDefaultVersionString:       string              = '1.0';
  cDefaultXmlFormat:           TXmlFormatType      = xfCompact;
  cDefaultWriteOnDefault:      boolean             = True;
  cDefaultBinaryEncoding:      TBinaryEncodingType = xbeBase64;
  cDefaultUtf8Encoded:         boolean             = False;
  cDefaultIndentString:        string              = '  ';
  cDefaultDropCommentsOnParse: boolean             = False;
  cDefaultUseFullNodes:        boolean             = False;
  cDefaultSortAttributes:      boolean             = False;

type

  TXmlNode = class;
  TNativeXml = class;
  TsdCodecStream = class;

  // An event that is based on the TXmlNode object Node.
  TXmlNodeEvent = procedure(Sender: TObject; Node: TXmlNode) of object;

  // An event that is used to indicate load or save progress.
  TXmlProgressEvent = procedure(Sender: TObject; Size: integer) of object;

  // This event is used in the TNativeXml.OnNodeCompare event, and should
  // return -1 if Node1 < Node2, 0 if Node1 = Node2 and 1 if Node1 > Node2.
  TXmlNodeCompareEvent = function(Sender: TObject; Node1, Node2: TXmlNode; Info: TPointer): integer of object;

  // Pass a function of this kind to TXmlNode.SortChildNodes. The function should
  // return -1 if Node1 < Node2, 0 if Node1 = Node2 and 1 if Node1 > Node2.
  TXMLNodeCompareFunction = function(Node1, Node2: TXmlNode; Info: TPointer): integer;

  // The TXmlNode represents an element in the XML file. Each TNativeXml holds
  // one Root element. Under ths root element, sub-elements can be nested (there
  // is no limit on how deep). Property ElementType defines what kind of element
  // this node is.
  TXmlNode = class(TPersistent)
  private
    FAttributes: TStringList;       // List with attributes
    FDocument: TNativeXml;         // Pointer to parent XmlDocument
    FElementType: TXmlElementType; // The type of element
    FName: string;                 // The element name
    FNodes: TList;                 // These are the child elements
    FParent: TXmlNode;             // Pointer to parent element
    FTag: integer;                 // A value the developer can use
    FValue: string;                // The *escaped* value
    function GetValueAsString: string;
    procedure SetAttributeName(Index: integer; const Value: string);
    procedure SetAttributeValue(Index: integer; const Value: string);
    procedure SetValueAsString(const AValue: string);
    function GetIndent: string;
    function GetLineFeed: string;
    function GetTreeDepth: integer;
    function GetAttributeCount: integer;
    function GetAttributePair(Index: integer): string;
    function GetAttributeName(Index: integer): string;
    function GetAttributeValue(Index: integer): string;
    function GetWriteOnDefault: boolean;
    function GetBinaryEncoding: TBinaryEncodingType;
    function GetCascadedName: string;
    function QualifyAsDirectNode: boolean;
    procedure SetName(const Value: string);
    function GetFullPath: string;
    procedure SetBinaryEncoding(const Value: TBinaryEncodingType);
    function GetBinaryString: string;
    procedure SetBinaryString(const Value: string);
    function UseFullNodes: boolean;
    function GetValueAsWidestring: widestring;
    procedure SetValueAsWidestring(const Value: widestring);
    function GetAttributeByName(const AName: string): string;
    procedure SetAttributeByName(const AName, Value: string);
    function GetValueAsInteger: integer;
    procedure SetValueAsInteger(const Value: integer);
    function GetValueAsFloat: double;
    procedure SetValueAsFloat(const Value: double);
    function GetValueAsDateTime: TDateTime;
    procedure SetValueAsDateTime(const Value: TDateTime);
    function GetValueAsBool: boolean;
    procedure SetValueAsBool(const Value: boolean);
    {$IFDEF D4UP}
    function GetValueAsInt64: int64;
    procedure SetValueAsInt64(const Value: int64);
    {$ENDIF}
    procedure CheckCreateAttributesList;
    function GetAttributeValueAsWidestring(Index: integer): widestring;
    procedure SetAttributeValueAsWidestring(Index: integer;
      const Value: widestring);
    function GetAttributeValueAsInteger(Index: integer): integer;
    procedure SetAttributeValueAsInteger(Index: integer;
      const Value: integer);
  protected
    function CompareNodeName(const NodeName: string): integer;
    function GetNodes(Index: integer): TXmlNode; virtual;
    function GetNodeCount: integer; virtual;
    procedure ParseTag(const AValue: string; TagStart, TagClose: integer);
    procedure ReadFromStream(S: TStream); virtual;
    procedure ReadFromString(const AValue: string); virtual;
    procedure ResolveEntityReferences;
    function UnescapeString(const AValue: string): string; virtual;
    function Utf8Encoded: boolean;
    function WriteInnerTag: string; virtual;
    procedure WriteToStream(S: TStream); virtual;
  public
    // Create a new TXmlNode object. ADocument must be the TNativeXml that is
    // going to hold this new node.
    constructor Create(ADocument: TNativeXml); virtual;
    // \Create a new TXmlNode with name AName. ADocument must be the TNativeXml
    // that is going to hold this new node.
    constructor CreateName(ADocument: TNativeXml; const AName: string); virtual;
    // \Create a new TXmlNode with name AName and string value AValue. ADocument
    // must be the TNativeXml that is going to hold this new node.
    constructor CreateNameValue(ADocument: TNativeXml; const AName, AValue: string); virtual;
    // \Create a new TXmlNode with XML element type AType. ADocument must be the
    // TNativeXml that is going to hold this new node.
    constructor CreateType(ADocument: TNativeXml; AType: TXmlElementType); virtual;
    // Use Assign to assign another TXmlNode to this node. This means that all
    // properties and subnodes from the Source TXmlNode are copied to the current
    // node. You can also Assign a TNativeXml document to the node, in that case
    // the RootNodeList property of the TNativeXml object will be copied.
    procedure Assign(Source: TPersistent); override;
    // Call Delete to delete this node completely from the parent node list. This
    // call only succeeds if the node has a parent. It has no effect when called for
    // the root node.
    procedure Delete; virtual;
    // \Delete all nodes that are empty (this means, which have no subnodes, no
    // attributes, and no value assigned). This procedure works recursively.
    procedure DeleteEmptyNodes;
    // Destroy a TXmlNode object. This will free the child node list automatically.
    // Never call this method directly. All TXmlNodes in the document will be
    // recursively freed when TNativeXml.Free is called.
    destructor Destroy; override;
    {$IFDEF D4UP}
    // Use this method to add an integer attribute to the node.
    procedure AttributeAdd(const AName: string; AValue: integer); overload;
    {$ENDIF}
    // Use this method to add a string attribute with value AValue to the node.