xmlblocks.pas

Delphi XML & XPATH源代码

  begin
    with IDOMElement(Element.AppendChild(Document.CreateElement('property'))) do
    begin
      Index := Pos('=', NameAndValue);
      Value := Trim(Copy(NameAndValue, Index + 1, Length(NameAndValue)));
      SetAttribute('name', Trim(Copy(NameAndValue, 1, Index - 1)));
      if Value <> '' then
        SetAttribute('value', Value);
    end;
  end;

  { Add nodes for a component property with binary data }
  procedure AddBinaryProperty(NameAndValue: string);
  begin
    repeat
      Inc(Index);
      NameAndValue := NameAndValue + Trim(Text[Index]);
    until Pos('}', Text[Index]) > 0;
    AddProperty(NameAndValue);
  end;

  { Add nodes for a component property with a list of string values }
  procedure AddListProperty(NameAndValue: string);
  begin
    repeat
      Inc(Index);
      NameAndValue := NameAndValue + Trim(Text[Index]) + '|';
    until Text[Index][Length(Text[Index])] = ')';
    AddProperty(Copy(NameAndValue, 1, Length(NameAndValue) - 1));
  end;

  { Add nodes for a component property which is a collection }
  procedure AddCollectionProperty(NameAndValue: string);
  var
    Index: Integer;
  begin
    Element :=
      IDOMElement(Element.AppendChild(Document.CreateElement('property')));
    Index   := Pos('=', NameAndValue);
    Element.SetAttribute('name', Trim(Copy(NameAndValue, 1, Index - 1)));
  end;

  { Add nodes for a component property with a long string }
  procedure AddMultilineProperty(NameAndValue: string);
  begin
    NameAndValue := NameAndValue + ' |';
    repeat
      Inc(Index);
      NameAndValue := NameAndValue + Trim(Text[Index]) + '|';
    until Text[Index][Length(Text[Index])] <> '+';
    AddProperty(Copy(NameAndValue, 1, Length(NameAndValue) - 1));
  end;

begin
  if not Assigned(Component) then
    raise EXBBException.Create('Missing component');
  Document := NewDocument(IfThen(TagName <> '', TagName, 'component'));
  Element  := Document.DocumentElement;
  Text     := TStringList.Create;
  try
    { Serialise component to a list of strings }
    Text.Text := ComponentToString(Component);
    Index := 0;
    while Index < Text.Count do
    begin
      { Then process these according to type }
      Line := Trim(Text[Index]);
      if Copy(Line, 1, 6) = 'object' then
        StartObject(Copy(Line, 8, Length(Line)))
      else if Copy(Line, 1, 4) = 'item' then
        StartItem
      else if Line = 'end'  then
        EndObjectOrItem
      else if Line = 'end>'  then
        EndCollection
      else if Pos('= {', Line) = Length(Line) - 2 then
        AddBinaryProperty(Line)
      else if Pos('= (', Line) = Length(Line) - 2 then
        AddListProperty(Line)
      else if Pos('= <', Line) = Length(Line) - 2 then
        AddCollectionProperty(Line)
      else if Pos('=', Line) = Length(Line) then
        AddMultilineProperty(Line)
      else
        AddProperty(Line);
      Inc(Index);
    end;
  finally
    Text.Free;
  end;
  DocumentReady(Document);
end;

{ TXBBWriter ------------------------------------------------------------------}

{ Initialise and set the destination filename/URL }
constructor TXBBWriter.Create(AOwner: TComponent; const FileName: TFileName);
begin
  inherited Create(AOwner);
  Self.Filename := Filename;
end;

{ Initialise and set the destination stream }
constructor TXBBWriter.Create(AOwner: TComponent; const Stream: TStream);
begin
  inherited Create(AOwner);
  Self.Stream := Stream;
end;

{ Write the document out to the specified destination }
function TXBBWriter.ProcessDocument(const Document: IDOMDocument): IDOMDocument;
begin
  if (Filename = '') and not Assigned(Stream) then
    raise EXBBException.Create('No filename or stream specified');
  with Document as IDOMPersist do
    if Assigned(Stream) then
      SaveToStream(Stream)
    else
      Save(Filename);
  Result := Document;
end;

{ TXBBMerge -------------------------------------------------------------------}

{ Initialise and optionally set properties }
constructor TXBBMerge.Create(AOwner: TComponent;
  const NumDocuments: Integer = 2; const TagName: string = '');
begin
  inherited Create(AOwner);
  Self.NumDocuments := NumDocuments;
  Self.TagName      := TagName;
end;

{ Add the given document into the merged one, and pass on when finished }
procedure TXBBMerge.DocumentReady(Document: IDOMDocument);
begin
  if not Assigned(FMergedDocument) then
    FMergedDocument := NewDocument(IfThen(TagName <> '', TagName, 'merge'));
  FMergedDocument.DocumentElement.AppendChild(Document.DocumentElement);
  Dec(FCountDown);
  if FCountDown = 0 then
  begin
    { Document is complete }
    NotifyConsumer(FMergedDocument);
    FCountDown := NumDocuments;
  end;
end;

procedure TXBBMerge.SetNumDocuments(Value: Integer);
begin
  FNumDocuments   := Value;
  FCountDown      := Value;
  FMergedDocument := nil;
end;

{ TXBBConsumerCollectionItem --------------------------------------------------}

{ Return value for display in property editor }
function TXBBConsumerCollectionItem.GetDisplayName: string;
begin
  Result := IfThen(Name = '', '<Unknown>', Name);
end;

procedure TXBBConsumerCollectionItem.SetConsumer(Value: IXMLConsumer);
begin
  FConsumer := Value;
  Changed(False);
end;

procedure TXBBConsumerCollectionItem.SetName(Value: string);
begin
  FName := Value;
  Changed(False);
end;

{ TXBBConsumerCollection ------------------------------------------------------}

{ Initialise and set owner }
constructor TXBBConsumerCollection.Create(Owner: TPersistent);
begin
  inherited Create(TXBBConsumerCollectionItem);
  FOwner := Owner;
end;

function TXBBConsumerCollection.Add: TXBBConsumerCollectionItem;
begin
  Result := TXBBConsumerCollectionItem(inherited Add);
end;

function TXBBConsumerCollection.FindItemID(ID: Integer):
  TXBBConsumerCollectionItem;
begin
  Result := TXBBConsumerCollectionItem(inherited FindItemID(ID));
end;

function TXBBConsumerCollection.GetItem(Index: Integer):
  TXBBConsumerCollectionItem;
begin
  Result := TXBBConsumerCollectionItem(inherited GetItem(Index));
end;

function TXBBConsumerCollection.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

function TXBBConsumerCollection.Insert(Index: Integer):
  TXBBConsumerCollectionItem;
begin
  Result := TXBBConsumerCollectionItem(inherited Insert(Index));
end;

procedure TXBBConsumerCollection.SetItem(Index: Integer;
  Value: TXBBConsumerCollectionItem);
begin
  inherited SetItem(Index, Value);
end;

{ TXBBFork --------------------------------------------------------------------}

constructor TXBBFork.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FConsumers := TXBBConsumerCollection.Create(Self);
end;

destructor TXBBFork.Destroy;
begin
  FConsumers.Free;
  inherited Destroy;
end;

{ Copy the document and pass it on to each consumer }
procedure TXBBFork.DocumentReady(Document: IDOMDocument);
var
  Index: Integer;
begin
  for Index := 0 to FConsumers.Count - 1 do
    if Assigned(FConsumers.Items[Index].Consumer) then
      FConsumers.Items[Index].Consumer.
        DocumentReady(Document.CloneNode(True) as IDOMDocument);
end;

{ TXBBTransform ---------------------------------------------------------------}

constructor TXBBTransform.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FXSLText := TStringList.Create;
end;

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

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

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

destructor TXBBTransform.Destroy;
begin
  FXSLText.Free;
  inherited Destroy;
end;

{ Apply the transformation specified earlier to the document }
function TXBBTransform.ProcessDocument(const Document: IDOMDocument):
  IDOMDocument;
var
  XSLDocument: IDOMDocument;
  OK: Boolean;
begin
  if (XSLSource = '') and not Assigned(XSLStream) and (XSLText.Text = '') then
    raise EXBBException.Create('No source specified for XSL document');
  XSLDocument := NewDocument('xslt');
  with XSLDocument as IDOMPersist do
    if XSLSource <> '' then
      OK := Load(XSLSource)
    else if Assigned(XSLStream) then
      OK := LoadFromStream(XSLStream)
    else
      OK := LoadXML(XSLText.Text);
  if not OK then
    raise EXBBException.Create((XSLDocument as IDOMParseError).reason);
  Result := NewDocument('out');
  (Document as IDOMNodeEx).TransformNode(XSLDocument, Result);
end;

{ TXBBTimestamp ---------------------------------------------------------------}

constructor TXBBTimestamp.Create(AOwner: TComponent;
  const Format: string = ''; const TagName: string = '');
begin
  inherited Create(AOwner);
  Self.Format  := Format;
  Self.TagName := TagName;
end;

{ Add a timestamp element (or subtree) to the document }
function TXBBTimestamp.ProcessDocument(const Document: IDOMDocument):
  IDOMDocument;
var
  Element: IDOMElement;
  DateTime: TDateTime;

  { Format consists of several fields to generate multiple date parts beneath
    the timestamp element. Separate sub-elements with vertical bars ( | ),
    and sub-element names from formats with equals ( = ). For example,
    a Format of 'year=yyyy|month=MM|day=dd' creates the following structure:
    <timestamp><year>2002</year><month>03</month><day>07</day></timestamp>.
    Prefix a name with '@' to make it an attribute instead. For example,
    a Format of '@year=yyyy|@month=MM|@day=dd' creates the following structure:
    <timestamp year="2002" month="03" day="07"/>. }
  procedure AddSubFormats(MainElement: IDOMElement);
  var
    Index: Integer;
    Name, SubFormat, WorkFormat: string;
  begin
    WorkFormat := Format;
    repeat
      Index := Pos('=', WorkFormat);
      if Index = 0 then
        Exit;
      Name := Copy(WorkFormat, 1, Index - 1);
      Delete(WorkFormat, 1, Index);
      Index := Pos('|', WorkFormat);
      if Index = 0 then
        Index := Length(WorkFormat) + 1;
      SubFormat := Copy(WorkFormat, 1, Index - 1);
      Delete(WorkFormat, 1, Index);
      if Name[1] = '@' then
        MainElement.SetAttribute(Copy(Name, 2, Length(Name)),
          FormatDateTime(SubFormat, DateTime))
      else
        MainElement.AppendChild(Document.CreateElement(Name)).
          AppendChild(Document.CreateTextNode(
          FormatDateTime(SubFormat, DateTime)));
    until WorkFormat = '';
  end;

begin
  DateTime := Now;
  Element  := Document.CreateElement(IfThen(TagName <> '', TagName, 'timestamp'));
  if Pos('=', Format) = 0 then
    Element.AppendChild(Document.CreateTextNode(FormatDateTime(Format, DateTime)))
  else
    AddSubFormats(Element);
  if InsertAtStart then
    Document.DocumentElement.InsertBefore(
      Element, Document.DocumentElement.FirstChild)
  else
    Document.DocumentElement.AppendChild(Element);
  Result := Document;
end;

procedure TXBBTimestamp.SetFormat(const Value: string);
begin
  FFormat := IfThen(Value <> '', Value, ShortDateFormat);
end;

{ TXBBNodePointer -------------------------------------------------------------}

constructor TXBBNodePointer.Create(Node: IDOMNode);
begin
  inherited Create;
  Self.Node := Node;
end;

{ TXBBTreeView ----------------------------------------------------------------}

constructor TXBBTreeView.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FShowNodes := [ntElement..ntNotation];
end;

{ Initialise and set tree view to update }
constructor TXBBTreeView.Create(AOwner: TComponent; const TreeView: TTreeView);
begin
  Create(AOwner);
  FTreeView := TreeView;
end;

{ Free up resources }
destructor TXBBTreeView.Destroy;
begin
  ClearTree;
  inherited Destroy;
end;

{ Free up objects in the tree }
procedure TXBBTreeView.ClearTree;
var
  Index: Integer;
begin
  if not Assigned(FTreeView) or (csDestroying in FTreeView.ComponentState) then
    Exit;
  for Index := 0 to FTreeView.Items.Count - 1 do
    if Assigned(FTreeView.Items[Index].Data) then
      TObject(FTreeView.Items[Index].Data).Free;
  FTreeView.Items.Clear;
end;

{ Tidy up if attached components are deleted }
procedure TXBBTreeView.Notification(AComponent: TComponent;