clsoap.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

      ContentTransferEncoding := Src.ContentTransferEncoding;
      ExtraFields := Src.ExtraFields;
    end;
    inherited Assign(Source);
  finally
    EndUpdate();
  end;
end;

procedure TclSoapMessageItem.ListChangeEvent(Sender: TObject);
begin
  Update();
end;

constructor TclSoapMessageItem.Create(AOwner: TclHttpRequest);
begin
  inherited Create(AOwner);
  FKnownFields := TStringList.Create();

  FExtraFields := TStringList.Create();
  TStringList(FExtraFields).OnChange := ListChangeEvent;

  RegisterFields();
  
  ContentType := 'text/xml';
end;

destructor TclSoapMessageItem.Destroy;
begin
  FExtraFields.Free();
  FKnownFields.Free();
  inherited Destroy();
end;

function TclSoapMessageItem.GetHeader: TStream;
var
  s: string;
  list: TStrings;
begin
  list := TStringList.Create();
  try
    s := ContentType;
    if (s <> '') then
    begin
      s := AddHttpFieldItem(s, 'charset', CharSet);
    end;
    AddHeaderField(list, 'Content-Type', s);

    AddHeaderField(list, 'Content-ID', ContentID);
    AddHeaderField(list, 'Content-Location', ContentLocation);
    AddHeaderField(list, 'Content-Transfer-Encoding', ContentTransferEncoding);
    list.AddStrings(ExtraFields);
    list.Add('');

    Result := TStringStream.Create(list.Text);
  finally
    list.Free();
  end;
end;

function TclSoapMessageItem.GetData: TStream;
begin
  if (Owner <> nil)and TclSoapMessage(Owner).IsMultiPart() then
  begin
    Result := GetHeader();
  end else
  begin
    Result := TclNullStream.Create();
  end;
end;

procedure TclSoapMessageItem.SetContentID(const Value: string);
begin
  if (FContentID <> Value) then
  begin
    FContentID := Value;
    Update();
  end;
end;

procedure TclSoapMessageItem.SetContentLocation(const Value: string);
begin
  if (FContentLocation <> Value) then
  begin
    FContentLocation := Value;
    Update();
  end;
end;

procedure TclSoapMessageItem.SetContentTransferEncoding(
  const Value: string);
begin
  if (FContentTransferEncoding <> Value) then
  begin
    FContentTransferEncoding := Value;
    Update();
  end;
end;

procedure TclSoapMessageItem.SetContentType(const Value: string);
begin
  if (FContentType <> Value) then
  begin
    FContentType := Value;
    Update();
  end;
end;

procedure TclSoapMessageItem.SetExtraFields(const Value: TStrings);
begin
  FExtraFields.Assign(Value);
end;

procedure TclSoapMessageItem.SetCharSet(const Value: string);
begin
  if (FCharSet <> Value) then
  begin
    FCharSet := Value;
    Update();
  end;
end;

procedure TclSoapMessageItem.ReadData(Reader: TReader);
begin
  BeginUpdate();
  try
    inherited ReadData(Reader);
    ContentType := Reader.ReadString();
    CharSet := Reader.ReadString();
    ContentID := Reader.ReadString();
    ContentLocation := Reader.ReadString();
    ContentTransferEncoding := Reader.ReadString();
    ExtraFields.Text := Reader.ReadString();
  finally
    EndUpdate();
  end;
end;

procedure TclSoapMessageItem.WriteData(Writer: TWriter);
begin
  inherited WriteData(Writer);
  Writer.WriteString(ContentType);
  Writer.WriteString(CharSet);
  Writer.WriteString(ContentID);
  Writer.WriteString(ContentLocation);
  Writer.WriteString(ContentTransferEncoding);
  Writer.WriteString(ExtraFields.Text);
end;

procedure TclSoapMessageItem.ParseHeader(AHeader, AFieldList: TStrings);
var
  s: string;
begin
  BeginUpdate();
  try
    inherited ParseHeader(AHeader, AFieldList);

    s := GetHeaderFieldValue(AHeader, AFieldList, 'Content-Type');
    ContentType := GetHeaderFieldValueItem(s, '');
    CharSet := GetHeaderFieldValueItem(s, 'charset=');

    ContentID := GetHeaderFieldValue(AHeader, AFieldList, 'Content-ID');
    ContentLocation := GetHeaderFieldValue(AHeader, AFieldList, 'Content-Location');
    ContentTransferEncoding := GetHeaderFieldValue(AHeader, AFieldList, 'Content-Transfer-Encoding');

    ParseExtraFields(AHeader, AFieldList);
  finally
    EndUpdate();
  end;
end;

procedure TclSoapMessageItem.ParseExtraFields(AHeader, AFieldList: TStrings);
var
  i: Integer;
  s: string;
begin
  ExtraFields.Clear();
  for i := 0 to AFieldList.Count - 1 do
  begin
    if (FindInStrings(FKnownFields, AFieldList[i]) < 0) then
    begin
      s := system.Copy(AHeader[Integer(AFieldList.Objects[i])], 1, Length(AFieldList[i]));
      ExtraFields.Add(s + ': ' + GetHeaderFieldValue(AHeader, AFieldList, i));
    end;
  end;
end;

procedure TclSoapMessageItem.RegisterField(const AField: string);
begin
  if (FindInStrings(FKnownFields, AField) < 0) then
  begin
    FKnownFields.Add(AField);
  end;
end;

procedure TclSoapMessageItem.RegisterFields;
begin
  RegisterField('Content-Type');
  RegisterField('Content-ID');
  RegisterField('Content-Location');
  RegisterField('Content-Transfer-Encoding');
end;

{ TclAttachmentItem }

procedure TclAttachmentItem.AddData(const AData: PChar; ADataSize: Integer);
var
  stream: TStream;
begin
  if (Owner = nil) then Exit;

  stream := TclSoapMessage(Owner).DataStream;
  if (stream = nil) then
  begin
    TclSoapMessage(Owner).DoGetDataStream(Self, stream);
  end;
  if (stream <> nil) then
  begin
    stream.Write(AData^, ADataSize);
  end;
  TclSoapMessage(Owner).DataStream := stream;
end;

procedure TclAttachmentItem.AfterAddData;
var
  soapMessage: TclSoapMessage;
begin
  if (Owner = nil) or (not (Owner is TclSoapMessage)) then Exit;
  soapMessage := TclSoapMessage(Owner);

  if (soapMessage.DataStream <> nil) and Assigned(soapMessage.OnDataAdded) then
  begin
    soapMessage.DataStream.Position := 0;
    soapMessage.DoDataAdded(Self, soapMessage.DataStream);
  end;
end;

function TclAttachmentItem.GetData: TStream;
var
  stream: TStream;
begin
  Result := TclMultiStream.Create();
  try
    TclMultiStream(Result).AddStream(inherited GetData());

    stream := nil;
    if (Owner <> nil) then
    begin
      TclSoapMessage(Owner).DoGetDataSourceStream(Self, stream);
    end;

    if (stream <> nil) then
    begin
      stream.Position := 0;
      TclMultiStream(Result).AddStream(stream);
    end;
  except
    Result.Free();
    raise;
  end;
end;

{ TclSoapMessageHeader }

procedure TclSoapMessageHeader.Assign(Source: TPersistent);
var
  Src: TclSoapMessageHeader;
begin
  BeginUpdate();
  try
    inherited Assign(Source);

    if (Source is TclSoapMessageHeader) then
    begin
      Src := (Source as TclSoapMessageHeader);
      Start := Src.Start;
      SubType := Src.SubType;
      SoapAction := Src.SoapAction;
    end;
  finally
    EndUpdate();
  end;
end;

procedure TclSoapMessageHeader.AssignContentType(AHeader: TStrings);
var
  s: string;
begin
  s := ContentType;
  if (s <> '') then
  begin
    s := AddHttpFieldItem(s, 'boundary', Boundary);
    s := AddHttpFieldItem(s, 'type', SubType);
    s := AddHttpFieldItem(s, 'start', Start);
    AddHeaderField(AHeader, 'Content-Type', s);
  end;
end;

procedure TclSoapMessageHeader.Clear;
begin
  BeginUpdate();
  try
    inherited Clear();
    Start := '';
    SubType := '';
    SoapAction := '';
  finally
    EndUpdate();
  end;
end;

procedure TclSoapMessageHeader.InternalAssignHeader(AHeader: TStrings);
begin
  inherited InternalAssignHeader(AHeader);
  AddHeaderField(AHeader, 'SOAPAction', SoapAction);
end;

procedure TclSoapMessageHeader.InternalParseHeader(AHeader, AFieldList: TStrings);
begin
  inherited InternalParseHeader(AHeader, AFieldList);
  SoapAction := GetHeaderFieldValue(AHeader, AFieldList, 'SOAPAction');
end;

procedure TclSoapMessageHeader.ParseContentType(AHeader, AFieldList: TStrings);
var
  s: string;
begin
  inherited ParseContentType(AHeader, AFieldList);
  s := GetHeaderFieldValue(AHeader, AFieldList, 'Content-Type');
  Start := GetHeaderFieldValueItem(s, 'start=');
  SubType := GetHeaderFieldValueItem(s, 'type=');
end;

procedure TclSoapMessageHeader.RegisterFields;
begin
  inherited RegisterFields();
  RegisterField('SOAPAction');
end;

procedure TclSoapMessageHeader.SetSoapAction(const Value: string);
begin
  if (FSoapAction <> Value) then
  begin
    FSoapAction := Value;
    Update();
  end;
end;

procedure TclSoapMessageHeader.SetStart(const Value: string);
begin
  if (FStart <> Value) then
  begin
    FStart := Value;
    Update();
  end;
end;

procedure TclSoapMessageHeader.SetSubType(const Value: string);
begin
  if (FSubType <> Value) then
  begin
    FSubType := Value;
    Update();
  end;
end;

{ TclXmlItem }

procedure TclXmlItem.AddData(const AData: PChar; ADataSize: Integer);
begin
  XmlData := XmlData + system.Copy(AData, 1, ADataSize);
end;

procedure TclXmlItem.AfterAddData;
var
  stream: TStream;
begin
  if (Owner = nil) then Exit;

  if Assigned(Owner.OnDataAdded) then
  begin
    stream := TStringStream.Create(XmlData);
    try
      TclSoapMessage(Owner).DoDataAdded(Self, stream);
    finally
      stream.Free();
    end;
  end;
end;

procedure TclXmlItem.Assign(Source: TPersistent);
begin
  BeginUpdate();
  try
    if (Source is TclXmlItem) then
    begin
      XmlData := (Source as TclXmlItem).XmlData;
    end;
    inherited Assign(Source);
  finally
    EndUpdate();
  end;
end;

function TclXmlItem.GetData: TStream;
begin
  Result := TclMultiStream.Create();
  try
    TclMultiStream(Result).AddStream(inherited GetData());
    TclMultiStream(Result).AddStream(TStringStream.Create(XmlData));
  except
    Result.Free();
    raise;
  end;
end;

procedure TclXmlItem.ReadData(Reader: TReader);
begin
  BeginUpdate();
  try
    inherited ReadData(Reader);
    XmlData := Reader.ReadString();
  finally
    EndUpdate();
  end;
end;

procedure TclXmlItem.SetXmlData(const Value: string);
begin
  if (FXmlData <> Value) then
  begin
    FXmlData := Value;
    Update();
  end;
end;

procedure TclXmlItem.WriteData(Writer: TWriter);
begin
  inherited WriteData(Writer);
  Writer.WriteString(XmlData);
end;

end.