ubasexmlclass.pas

批量 Xml 修改 Modify 批量 Xml 修改 批量 Xml 修改

{*******************************************************}
{                                                       }
{ 晨曦工程算量2006                                      }
{                                                       }
{ 版权所有 (C) 2006 晨曦软件                            }
{                                                       }
{ 单元说明:Xml文件读取器                                }
{                                                       }
{*******************************************************}

unit uBaseXmlClass;

// Debug version or not
{$DEFINE DEBUG}
{$IFDEF FPC}
// FPC should be Delphi compatible
{$MODE Delphi}
// Avoid a Warning
{$DEFINE I386}
// Make some methods inline is slightly faster
{$DEFINE INLINE}
{$IFDEF INLINE}
// Support inlining
{$INLINE on}
{$ENDIF}
{$ENDIF}
// Compiler Options
//   c: Assertations
//   d: Debug Info
{$IFDEF DEBUG}
{$C+,D+}
{$ELSE}
{$C-,D-}
{$ENDIF}
{$IFNDEF FPC}
// Short boolean evaluation
{$B-}
{$ENDIF}
//   i: I/O Checking
//   h: Huge Strings
//   q: Overflow Checking
//   r: Range Checking
//   s: Stack Checking
{$I+,H+,Q+,R+,S+}

{define IsUseOldCode}
{define IsNodeAttEmptyNoQuote}

interface

uses
  SysUtils, Classes;

type

  TStreamSaveEvent=procedure (Stream:TStream) of object;

  { @abstract(Source Position) }
  TPos = record
    Line,
      col: Integer;
  end;

  { @abstract(Base Exception, mostly internally used and the Base of the other
    Exceptions.) }
  ECMLException = class(Exception)
  private
    fSender: TObject;
  public
    {Create Exception with Sender}
    constructor CreateSender(ASender: TObject; const msg: string);
    {The Object the exception has raised}
    property Sender: TObject read fSender write fSender;
  end;

  { @abstract(Exception with source position informations) }
  ECMLPosException = class(ECMLException)
  private
    fPosition: TPos;
  public
    { Create an Exception with Source Position }
    constructor CreatePos(ASender: TObject; const msg: string; APos: TPos);
    { The Position where the Exception occurred }
    property Position: TPos read fPosition write fPosition;
  end;

  { @abstract(Occurs when cancelling parsing) }
  ECMLAbortException = class(ECMLPosException)
  end;

  { @abstract(Parser Exception, occurs when a Syntaxerror has been found) }
  ECMLParseException = class(ECMLPosException)
  end;

  { @abstract(Parse Node Event)
    Set @code(Cancel := true) to abort parsing. This will throw an
    @link(ESMLAbortException). }
  TNodeParsedEvent = procedure(Sender: TObject; var Cancel: Boolean) of object;

  TCMLNode = class;
  TCMLNodeList = class;
  TCMLNodeClass = class of TCMLNode;
  TCMLNodeListClass = class of TCMLNodeList;

  { @abstract(A Attribute of a @link(TSMLNode)) }
  TCMLAttri = class(TPersistent)
  private
    FName, fValue: string;
    FOwner: TCMLNode;
    procedure ParseAttri(const AToken: string);
    procedure SetText(Value: string);
    function GetText: string;
  public
    { Constructor }
    constructor CreateForScript(AOwner: TCMLNode); virtual;
    constructor Create(AOwner: TCMLNode); overload; virtual;
    { Create an Attribute with a Name and a String value. }
    constructor Create(AOwner: TCMLNode; const AName, AValue: string); overload; virtual;
    { Create an Attribute with a Name and an Integer value. }
    constructor Create(AOwner: TCMLNode; const AName: string; AValue: Integer); overload; virtual;
    { Create an Attribute with a Name and a Boolean value. }
    constructor Create(AOwner: TCMLNode; const AName: string; AValue: Boolean); overload; virtual;
    { Load an Attribute from a Stream }
    procedure LoadFromStream(Stream: TStream); virtual;
    { Save an Attribute to the Stream }
    procedure SaveToStream(Stream: TStream); virtual;
    { Assign from another Attribute }
    procedure Assign(Source: TPersistent); override;
    { The Name of the Attribute, e.g. @code(foo="...") }
    property Name: string read FName write FName;
    { The Value of the Attribute, e.g. @code(...="bar") }
    property Value: string read fValue write fValue;
    { The entire Text of the Attribute, e.g. @code(foo="bar") }
    property Text: string read GetText write SetText;
  end;

  { @abstract(Each @link(TSMLNode) has such a List which holds all Attributes) }
  TCMLAttriList = class(TList)
  private
    FOwner: TCMLNode;
    function GetAtt(AName: string): string;
    procedure SetAtt(AName: string; const Value: string);
    function GetAttAsBoolean(AMc: string): Boolean;
    function GetAttAsFloat(AMc: string): Double;
    function GetAttAsInt(AMc: string): Integer;
    procedure SetAttAsBoolean(AMc: string; const Value: Boolean);
    procedure SetAttAsFloat(AMc: string; const Value: Double);
    procedure SetAttAsInt(AMc: string; const Value: Integer);
  protected
    function Get(Index: Integer): TCMLAttri;
    procedure Put(Index: Integer; Item: TCMLAttri);
    function GetText: string;
    procedure SetText(Value: string);
  public
    constructor Create(AOwner: TCMLNode);
    destructor Destroy; override;
    { Find an Attribute ba Name and return the Object. If there is not Attribute
      with this Name it returns @code(nil) }
    function Find(const AName: string): TCMLAttri;
    { Add Text to the Attribute List. It automatically parses the Text and creates
      the required @link(TSMLAttri) Objects }
    procedure AddText(Value: string);
    { Remove and @code(Free) all Attributes }
    procedure Clear; override;
    { Delete an Attribute by Index. }
    procedure Delete(Index: Integer); overload;
    { Delete an Attribute by Item. }
    procedure Delete(Item: TCMLAttri); overload;
    { Delete an Attribute by Name. }
    procedure Delete(AName: string); overload;
    { Same as @link(TSMLAttriList.Delete) but does not free it. }
    procedure Remove(Item: TCMLAttri);
    { Assign from another List }
    procedure Assign(Source: TList);
    { Returns or sets the @link(TSMLAttri) by Index }
    property Items[Index: Integer]: TCMLAttri read Get write Put; default;
    { Returns or sets the Text of all Attributes, e.g. @code(foo="bar" attr="val") }
    property Text: string read GetText write SetText;
  public
    function HasAttribute(const AName: string): Boolean;
    property AttAsBoolean[AMc: string]: Boolean read GetAttAsBoolean write SetAttAsBoolean;
    property AttAsFloat[AMc: string]: Double read GetAttAsFloat write SetAttAsFloat;
    property AttAsInt[AMc: string]: Integer read GetAttAsInt write SetAttAsInt;
    property Att[AName: string]: string read GetAtt write SetAtt;
  end;

  { @abstract(Each @link(TSMLNode) has such a List which holds all Subnodes) }
  TCMLNodeList = class(TList)
  private
    FOwner: TCMLNode;
  protected
    function Get(Index: Integer): TCMLNode;
    procedure Put(Index: Integer; Item: TCMLNode);
    class function GetChildClass: TCMLNodeClass; virtual;
  public
    constructor Create(AOwner: TCMLNode);
    { Destructor }
    destructor Destroy; override;
    { Find a @link(TSMLNode) by Name, return @code(nil) when it is not found }
    function Find(const AName: string; const CanCreate: Boolean): TCMLNode;
    function CreateNewChild(const AName: string): TCMLNode;
    { Remove and @code(Free) all Nodes }
    procedure Clear; override;
    { Delete a Node by Index. }
    procedure Delete(Index: Integer); overload;
    { Delete a Node by Item. }
    procedure Delete(Item: TCMLNode); overload;
    { Delete a Node by Name. }
    procedure Delete(AName: string); overload;
    { Same as @link(TSMLNodeList.Delete) but does not free it. }
    procedure Remove(Item: TCMLNode);
    { Assign from another Node list }
    procedure Assign(Source: TList);
    { Returns or sets a @link(TSMLNode) by Index }
    property Items[Index: Integer]: TCMLNode read Get write Put; default;
  end;

  { @abstract(The Main class) }
  TCMLNode = class(TPersistent)
  private
    fChilds: TCMLNodeList;
    FOwner: TCMLNode;
    fPos: Cardinal;
    fOriginalText: string;
    FName: string;
    fValue: string;
    fDocType: string;
    fXMLType: string;
    FFileName: string;
    fAttris: TCMLAttriList;
    fOnNodeParsed: TNodeParsedEvent;

    procedure SetName(Value: string);
    procedure SetValue(Value: string);
    function GetValue: string;
    procedure SetText(Value: string);
    function GetText: string;
    function GetCount: Integer;
    function GetIndex: Integer;
    function GetPosition: TPos;
    procedure SetOwner(AOwner: TCMLNode);
    procedure ParseNode(var AToken: PChar);
    function GetAtt(AName: string): string;
    procedure SetAtt(AName: string; const Value: string);
    function GetAttAsBoolean(AMc: string): Boolean;
    function GetAttAsFloat(AMc: string): Double;
    function GetAttAsInt(AMc: string): Integer;
    procedure SetAttAsBoolean(AMc: string; const Value: Boolean);
    procedure SetAttAsFloat(AMc: string; const Value: Double);
    procedure SetAttAsInt(AMc: string; const Value: Integer);
    function GetName: string;
    function GetNodeCount: integer;
  protected
    class function GetChildListClass: TCMLNodeListClass; virtual;
    class function GetChildClass: TCMLNodeClass; virtual;
    {Internally called when it wants to create a new child node. Override it to
    create a @link(TSMLNode) descendant instead.}
    function CreateChild(AOwner: TCMLNode): TCMLNode; virtual;
    function GetDeep: Integer;
    function GetWDeep: Integer;
    function GetPrev:TCMLNode;
    function GetNext:TCMLNode;
  public
    constructor CreateForScript(AOwner: TCMLNode); virtual;
    { Constructor, @code(AOwner) is the parent Node use @code(nil) if this is the
      topmost Node }
    constructor Create(AOwner: TCMLNode); overload; virtual;
    { Create a Node with a Name and a String value. }
    constructor Create(AOwner: TCMLNode; const AName, AValue: string); overload; virtual;
    { Create a Node with a Name and an Integer value. }
    constructor Create(AOwner: TCMLNode; const AName: string; const AValue: Integer); overload;
      virtual;
    { Create a Node with a Name and a Double value. }
    constructor Create(AOwner: TCMLNode; const AName: string; const AValue: Double); overload;
      virtual;
    { Create a Node with a Name and a Boolean value. }
    constructor Create(AOwner: TCMLNode; const AName: string; const AValue: Boolean); overload;
      virtual;
    { Destructor }
    destructor Destroy; override;
    { Load a Node from a Stream and parse it }
    function LoadFromStream(Stream: TStream): Boolean; virtual;
    { Save a Node to a Stream }
    function SaveToStream(Stream: TStream): Boolean; virtual;
    { Load a Node from a File and parse it }
    function LoadFromFile(const FileName: string): Boolean; virtual;
    { Save a Node to a File }
    function SaveToFile(const FileName: string): Boolean; virtual;
    { Assign from another Node }
    procedure Assign(Source: TPersistent); override;
    { Finds a Childnode by Name and returns it. It returns @code(nil) when there
      is no child Node with this Name }
    function FindChild(const AName: string; const CanCreate: Boolean): TCMLNode;
    { It returns @code(nil) when there
      is no child Node with this Name }
    function FindChildByAttName(const AAttName,AAttValue,ANodeName:string; const CanCreate: Boolean): TCMLNode;

    function DoCreateNewChild(const AName: string): TCMLNode;
    { Removes all Subnodes and Attributes, and sets the @code(Value := ''). }
    procedure Clear;
    { Deletes this Node and removes it from the Childs list of the Owner }
    procedure Delete;
    { Finds an Attribute by Name and returns it. It returns @code(nil) when there
      is no Attribute with this Name }
    function FindAttri(const AName: string): TCMLAttri;
    { The Parent Node, if it is the topmost Node @code(Owner = nil) }
    property Owner: TCMLNode read FOwner write SetOwner;
    { List of Attributes }
    property Attris: TCMLAttriList read fAttris;
    { List of Subnodes }
    property Childs: TCMLNodeList read fChilds;
    { Returns the count of all Nodes and Subnodes. Call it from the Root Node to
      get the absolute count of Nodes in a File. }
    property Count: Integer read GetCount;
    { The Name of the Node, @code(<name>...</name>) }
    property Name: string read GetName write SetName;
    { The Value of the Node, @code(<node>value</node>) }
    property Value: string read GetValue write SetValue;
    { The complete Text of the Node with all subnodes }
    property Text: string read GetText write SetText;
    { Original Position of the Tag }
    property Position: TPos read GetPosition;
    { @code(<!DOCTYPE ...>) not really useful but it must parse it, otherwise Syntax Error }
    property DocType: string read fDocType write fDocType;
    { @code(<?xml ...?>), could contain @code("version="1.0" standalone="yes") or similar. This is not really
      useful but it must parse it, otherwise Syntax Error.
      You can use the @link(TSMLAttriList) to parse the Attributes, if you need it. }
    property XMLType: string read fXMLType write fXMLType;
    {The filename of the SML file, optional.}
    property FileName: string read FFileName write FFileName;
    { Returns the Index of this Node in the Nodelist of the Parent. }
    property Index: Integer read GetIndex;
    { Occurres when a Node has been successfully parsed }
    property OnNodeParsed: TNodeParsedEvent read fOnNodeParsed write fOnNodeParsed;
  public
    function NodeNewAtIndex(Index: integer; const AName: string): TCMLNode; virtual;
    procedure NodeInsert(Index: integer; ANode: TCMLNode); virtual;
    function NodeRemove(ANode: TCMLNode): integer;
    function NodeIndexOf(ANode: TCMLNode): integer;
    procedure NodeDelete(Index: integer); virtual;
    function NodeExtract(ANode: TCMLNode): Pointer; virtual;
  public
    function XMove(ATab: Integer): Boolean;
    procedure AssignedByNode(ANode:TCMLNode);
  public
    function HasAttribute(const AName: string): Boolean;
    property NodeCount: integer read GetNodeCount;
    {*存取属性}
    property AttAsBoolean[AMc: string]: Boolean read GetAttAsBoolean write SetAttAsBoolean;
    property AttAsFloat[AMc: string]: Double read GetAttAsFloat write SetAttAsFloat;
    property AttAsInt[AMc: string]: Integer read GetAttAsInt write SetAttAsInt;
    property Att[AName: string]: string read GetAtt write SetAtt;
  end;

  TPackedType=(ptNone,ptZLib,ptZip,ptZLib2);

  TIDTag = packed record // 188 字节  256
     TAGID: array[0..3] of char; // 4 字节: 必须是TAG
     Title: array[0..251] of char; // 30 字节: 其它要存的
  end;



  TCmlDoc = class(TPersistent)
  private
    FRoot: TCMLNode;
    FIDTAG:TIDTag;
    FPackedType: TPackedType;
    FIsSavePacked: boolean;
    function GetRoot: TCMLNode;
  protected
    class function GetChildClass: TCMLNodeClass; virtual;
    procedure WriteIdTag(Stream:TStream);
  public
    constructor Create(AName: string = ''); virtual;
    destructor Destroy; override;
    function LoadFromFile(const FileName: string): Boolean; virtual;
    function SaveToFile(const FileName: string): Boolean; virtual;
    property Root: TCMLNode read GetRoot;
  public
    property IsSavePacked: boolean read FIsSavePacked write FIsSavePacked;
    property PackedType: TPackedType read FPackedType write FPackedType;
  end;

  { Encode String, i.e. convert non ASCII Characters to Entities. It uses always
    the @code(&#DDD;) notation. }
function EncodeString(const AToken: string): string;
{ Convert all entities in a string to non ASCII Characters. May be in decimal
  notation (@code(&#DDD;)) or in hexadecimal notation (@code(&#xHH;)) }
function DecodeString(const AString: string): string;
{ Check for a Valid Node Name }
function IsValidName(const AName: string): Boolean;
{ Convert a String to boolean. It returns @code(true) when
  @code(Value) = @code(true) or @code(t) or @code(1) or @code(yes) or @code(y)
  and @code(false) in all other cases. }
function StrToBool(const Value: string): Boolean;
{ Convert Boolean to String }
function BoolToStr(const Value: Boolean): string;
{ Convert any binary Buffer to a String. }
function BinToStr(const Buf; Len: Integer): string;
{ Convert a String to a binary Buffer. }
function StrToBin(const Str: string; var Buf; var Len: Integer): Integer;

const
  { Indent size. Indent each level with INDENT_CHAR * INDENT_INC when saving. }
  INDENT_INC = 2;
  { Ident Char, useful are Space and Tab. Inserts INDENT_INC of INDENT_CHAR per
    level when saving. }
  INDENT_CHAR: Char = ' ';
  { Preferred quote character used when saving, either " or ' }
  QUOTE_CHAR: Char = '"';
  { New Line Character }
  {$IFDEF WIN32}
  NEWLINE = #13#10;
  {$ELSE}
  NEWLINE = #10;
  {$ENDIF}
  { Boolean strings, used in @link(BoolToStr) }
  BOOLSTR: array[Boolean] of string = ('false', 'true');
  { Delimiter to separate Nodes. }
  NODEDELIMITER = '\';
  {Revision number of this file}
  SMLNODE_RCSREVISION = '$Revision: 1.29 $';

  cEscapeCount = 5;

  cEscapes: array[0..cEscapeCount - 1] of string =
  ('&', '<', '>', '''', '"');

  cReplaces: array[0..cEscapeCount - 1] of string =
  ('&amp;', '&lt;', '&gt;', '&apos;', '&quot;');

  cPackZlib='nLIB';
  cPackZip='nZIP';
  cPackRar='nRAR';

  cIdTagLen=SizeOf(TIDTAG);

Function UnZipFile(AFileName: String;outStream: TStream):Boolean;overload;
Function UnZipFile(inStream, outStream: TStream):Boolean;overload;
function TestFileType(const FileName:String):TPackedType;overload;
function TestFileType(AFileHandle:Integer):TPackedType;overload;

implementation
uses
  Windows,ZLIBEx;
  
{ There are some Labels and goto's. This isn't considered as good coding style,
  but it's fast. }

type
  TBytes = array[0..MaxInt - 1] of Byte;

var
  Indent: Integer = 0;
 {$IFDEF IsUseOldCode}
  EncodingTable: array[Char] of PChar;
  {$ENDIF}
  gStartPos: PChar = nil;

function GetTmp(APath,APre: string): string;
var
  szFileName: array[0..256] of Char;
begin
  GetTempFileName(PChar(APath), PChar(APre), 0, szFileName);
  Result := string(szFileName);
end;

Function UnZipFile(AFileName: String;outStream: TStream):Boolean;
Var
  SourceStream: TFileStream;
Begin
  Result := false;
  Try
    SourceStream := TFileStream.Create(AFileName, 0);
    Try
      Result:=UnZipFile(SourceStream,outStream);
    Finally
      SourceStream.Free;
    End;
  Except
  End;
End;

Function UnZipFile2(inStream, outStream: TStream):Boolean;overload;
Var
  DeCompressStream: TZDecompressionStream;
  iCount: Integer;
  Buffer: pchar;
Begin
  Result := True;
  Try
    inStream.ReadBuffer(iCount, SizeOf(iCount));
    GetMem(Buffer, iCount);
    Try
      DeCompressStream := TZDecompressionStream.Create(inStream);
      Try
        DeCompressStream.ReadBuffer(Buffer^, iCount);
        outStream.WriteBuffer(Buffer^, iCount);
        outStream.Position := 0;   //复位流指针
      Finally
        DeCompressStream.Free;
      End;
    Finally
      Freemem(Buffer, iCount);
    End;
  Except
    Result := false;
  End;
End;

Function UnZipFile(inStream, outStream: TStream):Boolean;overload;
begin
  Try
    Result :=UnZipFile2(inStream,outStream);
  Except
    Result := false;
  End;
End;

Function SaveToZipfile(inStream: TStream; desfile:String;AEvent:TStreamSaveEvent): Boolean;
Var
  DesFileStream: TFileStream;
  iCount: Integer;
Begin
  Result:=True;
  Try
    DesFileStream := TFileStream.Create(desfile, fmcreate);
    try
      iCount := inStream.Size;
      DesFileStream.Write(iCount, sizeof(iCount));
      inStream.Position:=0;
      ZCompressStream(inStream,DesFileStream,zcFastest);

      if Assigned(AEvent) then
        AEvent(DesFileStream);
    finally
      DesFileStream.Free;
    end;
  Except
    result := false;
  End;
End;

function ZipAFile(AFileName:string;AEvent:TStreamSaveEvent=nil):Boolean;
var
  sTmpFile:String;
  Stream:TFileStream;
  isZiped:Boolean;
begin
  Result:=False;
  Stream:=TFileStream.Create(AFileName, fmOpenRead);
  try
    sTmpFile:=GetTmp(ExtractFilePath(AFileName),'~Cx');
    isZiped:=SavetoZipfile(Stream,sTmpFile,AEvent);
  finally
    Stream.Free;
  end;
  if isZiped then
  begin
    if DeleteFile(PChar(AFileName)) then
      Result:=MoveFile(PChar(sTmpFile),PChar(AFileName));
  end;
end;


function ExtractZLibFileTo(AinFileName,AOutFileName:string):Boolean;
var
  Stream:TStream;
begin
  Stream:=TFileStream.Create(AOutFileName,fmCreate);
  try