xmlblocks.pas

来自「Delphi XML & XPATH源代码」· PAS 代码 · 共 1,670 行 · 第 1/4 页

    the one type and so are shown in a two-dimensional format.
    Each row is a new child element of the document element,
    with each column being one of its children and value. }
  TXBBStringGrid = class(TXMLBuildingBlock)
  private
    FSingleNode: Boolean;
    FStringGrid: TStringGrid;
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation);
      override;
    function ProcessDocument(const Document: IDOMDocument): IDOMDocument;
      override;
  public
    constructor Create(AOwner: TComponent); overload; override;
    constructor Create(AOwner: TComponent; const StringGrid: TStringGrid);
      reintroduce; overload;
  published
    property Consumer;
    property SingleNode: Boolean read FSingleNode write FSingleNode
      default True;
    property StringGrid: TStringGrid read FStringGrid write FStringGrid;
  end;

  { Display a DOM within a Web browser. }
  TXBBWebBrowser = class(TXMLBuildingBlock)
  private
    FWebBrowser: TWebBrowser;
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation);
      override;
    function ProcessDocument(const Document: IDOMDocument): IDOMDocument;
      override;
  public
    constructor Create(AOwner: TComponent; const WebBrowser: TWebBrowser);
      reintroduce; overload;
  published
    property Consumer;
    property WebBrowser: TWebBrowser read FWebBrowser write FWebBrowser;
  end;

  { Create a new component from a DOM. }
  TXBBComponentCreate = class(TXMLBuildingBlock)
  private
    FComponent: TComponent;
  protected
    function ProcessDocument(const Document: IDOMDocument): IDOMDocument;
      override;
  public
    destructor Destroy; override;
    property Component: TComponent read FComponent;
  published
    property Consumer;
  end;

var
  { Default set of images for a tree view for XML node types.
    The image order follows the node types specified in the XMLDOM unit:
    from ELEMENT_NODE through to NOTATION_NODE. }
  DefaultNodeImages: TImageList;

{ Escape meta-characters in XML text. }
function EscapeText(Value: string): string;

implementation

{$R *.res}

{ Escape meta-characters in XML text. }
function EscapeText(Value: string): string;
begin
  Result := Value;
  Result := StringReplace(Result, '&', '&', [rfReplaceAll]);
  Result := StringReplace(Result, '<', '&lt;', [rfReplaceAll]);
  Result := StringReplace(Result, '>', '&gt;', [rfReplaceAll]);
  Result := StringReplace(Result, '''', '&apos;', [rfReplaceAll]);
  Result := StringReplace(Result, '"', '&quot;', [rfReplaceAll]);
end;

{ TXMLBuildingBlock -----------------------------------------------------------}

{ Do nothing - implemented as needed in subclasses }
procedure TXMLBuildingBlock.CreateDocument;
begin
end;

{ Process the document according to this class, then pass it on to any consumer }
procedure TXMLBuildingBlock.DocumentReady(Document: IDOMDocument);
begin
  Document := ProcessDocument(Document);
  NotifyConsumer(Document);
end;

{ Trigger the tag create event }
procedure TXMLBuildingBlock.DoOnTagCreate(Element: IDOMElement);
begin
  if Assigned(OnTagCreate) then
    OnTagCreate(Self, Element);
end;

function TXMLBuildingBlock.GetConsumer: IXMLConsumer;
begin
  Result := FConsumer;
end;

{ Create a new document and document element }
function TXMLBuildingBlock.NewDocument(const TagName: string): IDOMDocument;
var
  DocElement: IDOMElement;
begin
  Result     := GetDOM().CreateDocument('', TagName, nil);
  DocElement := IDOMElement(Result.AppendChild(Result.CreateElement(TagName)));
  if TagName = Self.TagName then
    DoOnTagCreate(DocElement);
end;

{ Tidy up if attached components are deleted }
procedure TXMLBuildingBlock.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
  begin
    { Need to check based on interfaces. }
    if Assigned(Consumer) and AComponent.IsImplementorOf(Consumer) then
      Consumer := nil;
  end;
end;

{ Pass the completed document onto any register consumer }
procedure TXMLBuildingBlock.NotifyConsumer(Document: IDOMDocument);
begin
  if Assigned(FConsumer) then
    FConsumer.DocumentReady(Document);
end;

{ Do nothing - overridden in subclasses }
function TXMLBuildingBlock.ProcessDocument(const Document: IDOMDocument):
  IDOMDocument;
begin
  Result := Document;
end;

{ Handle the assigned interface so that we get notifications about it }
procedure TXMLBuildingBlock.SetConsumer(const Value: IXMLConsumer);
begin
  ReferenceInterface(FConsumer, opRemove);
  FConsumer := Value;
  ReferenceInterface(FConsumer, opInsert);
end;

{ TXBBParser ------------------------------------------------------------------}

constructor TXBBParser.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FXMLText := TStringList.Create;
end;

{ Initialise and set the source as a file/URL }
constructor TXBBParser.Create(AOwner: TComponent; const XMLSource: TFileName);
begin
  Create(AOwner);
  Self.XMLSource := XMLSource;
end;

{ Initialise and set the source as a stream }
constructor TXBBParser.Create(AOwner: TComponent; const XMLStream: TStream);
begin
  Create(AOwner);
  Self.XMLStream := XMLStream;
end;

{ Initialise and set the source as a list of strings }
constructor TXBBParser.Create(AOwner: TComponent; const XMLText: TStrings);
begin
  Create(AOwner);
  Self.XMLText := XMLText;
end;

destructor TXBBParser.Destroy;
begin
  FXMLText.Free;
  inherited Destroy;
end;

{ Read the document in from the nominated source }
procedure TXBBParser.CreateDocument;
var
  Document: IDOMDocument;
begin
  if (XMLSource = '') and not Assigned(XMLStream) and (XMLText.Text = '') then
    raise EXBBException.Create('No source specified for XML document');
  Document := NewDocument('dummy');
  with Document as IDOMPersist do
    if XMLSource <> '' then
      Load(XMLSource)
    else if Assigned(XMLStream) then
      LoadFromStream(XMLStream)
    else
      LoadXML(XMLText.Text);
  DocumentReady(Document);
end;

{ TXBBSQL ---------------------------------------------------------------------}

constructor TXBBSQL.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFieldFormat := xfText;
  FSQL         := TStringList.Create;
end;

{ Initialise and set the tag name to be used }
constructor TXBBSQL.Create(AOwner: TComponent; const TagName: string);
begin
  Create(AOwner);
  Self.TagName := TagName;
end;

{ Initialise and set the database and query to be used }
constructor TXBBSQL.Create(AOwner: TComponent; const DatabaseName: string;
  const SQL: TStrings; const TagName: string = '');
begin
  Create(AOwner, TagName);
  Self.DatabaseName := DatabaseName;
  Self.SQL          := SQL;
end;

{ Release resources }
destructor TXBBSQL.Destroy;
begin
  FSQL.Free;
  inherited Destroy;
end;

{ Run the query against the database and convert the results into XML }
procedure TXBBSQL.CreateDocument;
var
  Document: IDOMDocument;
  RecordElement, FieldElement: IDOMElement;
  Query: TQuery;
  Index: Integer;
  RecTagName, FieldName, FieldValue: string;
begin
  if (DatabaseName = '') or (SQL.Text = '') then
    raise EXBBException.Create('Missing database name or SQL');
  RecTagName := IfThen(RecordTagName <> '', RecordTagName, 'record');
  Document   := NewDocument(IfThen(TagName <> '', TagName, DatabaseName));
  Query      := TQuery.Create(nil);
  with Query do
    try
      DatabaseName := Self.DatabaseName;
      SQL          := Self.SQL;
      Open;
      for Index := 0 to FieldCount - 1 do
        if Fields[Index] is TMemoField then
          Fields[Index].OnGetText := GetText;
      while not Eof do
      begin
        { Create an element for each record }
        RecordElement := IDOMElement(Document.DocumentElement.AppendChild(
          Document.CreateElement(RecTagName)));
        if Assigned(OnRecordTagCreate) then
          OnRecordTagCreate(Self, RecordElement, Query);
        for Index := 0 to FieldCount - 1 do
        begin
          FieldName  := Fields[Index].DisplayName;
          FieldValue := EscapeText(Fields[Index].DisplayText);
          case FieldFormat of
            xfText:
              { And then a sub-element for each field }
              begin
                FieldElement := IDOMElement(RecordElement.AppendChild(
                  Document.CreateElement(FieldName)));
                FieldElement.AppendChild(Document.CreateTextNode(FieldValue));
              end;
            xfElement:
              { Add field values as attributes on separate elements }
              begin
                FieldElement := IDOMElement(RecordElement.AppendChild(
                  Document.CreateElement(FieldName)));
                FieldElement.setAttribute('value', FieldValue);
              end;
            xfAttributeOnly:
              { Add field values as attributes on the record element }
              RecordElement.setAttribute(FieldName, FieldValue);
          end;
        end;
        Next;
      end;
      Close;
      DocumentReady(Document);
    finally
      Free;
    end;
end;

{ Retrieve the contents of a memo field }
procedure TXBBSQL.GetText(Sender: TField; var Text: String;
  DisplayText: Boolean);
begin
  Text := TMemoField(Sender).AsString
end;

{ TXBBTextFile ----------------------------------------------------------------}

{ Initialise and optionally set the filename and tag name }
constructor TXBBTextFile.Create(AOwner: TComponent;
  const FileName: TFileName = ''; const TagName: string = '');
begin
  inherited Create(AOwner);
  Self.FileName := FileName;
  Self.TagName  := TagName;
end;

{ Read a text file and wrap it in an element }
procedure TXBBTextFile.CreateDocument;
var
  Document: IDOMDocument;
  Text: TStringList;
begin
  if FileName = '' then
    raise EXBBException.Create('Missing filename');
  Document := NewDocument(IfThen(TagName <> '', TagName, 'file'));
  Text     := TStringList.Create;
  try
    Text.LoadFromFile(FileName);
    Document.DocumentElement.SetAttribute('filename', FileName);
    if AsCDATA then
      Document.DocumentElement.AppendChild(Document.CreateCDATASection(Text.Text))
    else
      Document.DocumentElement.AppendChild(
        Document.CreateTextNode(EscapeText(Text.Text)));
  finally
    Text.Free;
  end;
  DocumentReady(Document);
end;

{ TXBBComponent ---------------------------------------------------------------}

{ Initialise and optionally set the tag name and component to wrap }
constructor TXBBComponent.Create(AOwner: TComponent; const TagName: string = '';
  const Component: TComponent = nil);
begin
  inherited Create(AOwner);
  Self.TagName   := TagName;
  Self.Component := Component;
end;

{ Serialise a component into an XML document }
procedure TXBBComponent.CreateDocument;
var
  Document: IDOMDocument;
  Element: IDOMElement;
  Text: TStringList;
  Index: Integer;
  Line: string;

  { Serialise a component into a string (like the DFM) }
  function ComponentToString(Component: TComponent): string;
  var
    MemStream: TMemoryStream;
    StrStream: TStringStream;
  begin
    MemStream := TMemoryStream.Create;
    try
      StrStream := TStringStream.Create('');
      try
        MemStream.WriteComponent(Component);
        MemStream.Seek(0, soFromBeginning);
        ObjectBinaryToText(MemStream, StrStream);
        StrStream.Seek(0, soFromBeginning);
        Result := StrStream.DataString;
      finally
        StrStream.Free;
      end;
    finally
      MemStream.Free
    end;
  end;

  { Create an object element }
  procedure StartObject(NameAndType: string);
  var
    Index: Integer;
  begin
    Element :=
      IDOMElement(Element.AppendChild(Document.CreateElement('object')));
    Index   := Pos(':', NameAndType);
    Element.SetAttribute('name', Trim(Copy(NameAndType, 1, Index - 1)));
    Element.SetAttribute('type',
      Trim(Copy(NameAndType, Index + 1, Length(NameAndType))));
  end;

  { Create a collection item element }
  procedure StartItem;
  begin
    Element := IDOMElement(Element.AppendChild(Document.CreateElement('item')));
  end;

  { Finish an object or item element and move back up the DOM tree }
  procedure EndObjectOrItem;
  begin
    Element := IDOMElement(Element.ParentNode);
  end;

  { Finish a collection property element and move back up the DOM tree }
  procedure EndCollection;
  begin
    Element := IDOMElement(Element.ParentNode.ParentNode);
  end;

  { Add nodes for a normal component property }
  procedure AddProperty(NameAndValue: string);
  var
    Index: Integer;
    Value: string;