clhttprequest.pas

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

procedure TclHttpRequest.WriteItems(Writer: TWriter);
var
  i: Integer;
begin
  Writer.WriteListBegin();
  for i := 0 to Count - 1 do
  begin
    Writer.WriteString(Items[i].ClassName);
    Items[i].WriteData(Writer);
  end;
  Writer.WriteListEnd();
end;

procedure TclHttpRequest.Move(CurIndex, NewIndex: Integer);
begin
  BeginUpdate();
  try
    FList.Move(CurIndex, NewIndex);
  finally
    EndUpdate();
  end;
end;

procedure TclHttpRequest.RemoveItem(AItem: TclHttpRequestItem);
begin
  BeginUpdate();
  try
    FList.Remove(AItem);
    if (not (csLoading in ComponentState)) and (not FIsParse) then
    begin
      Header.ContentType := GetContentType();
    end;
  finally
    EndUpdate();
  end;
end;

procedure TclHttpRequest.ClearItems;
begin
  BeginUpdate();
  try
    while (Count > 0) do
    begin
      Items[Count - 1].Free();
    end;
  finally
    EndUpdate();
  end;
end;

procedure TclHttpRequest.SetHeader(const Value: TclHttpRequestHeader);
begin
  FHeader.Assign(Value);
end;

function TclHttpRequest.GenerateBoundary(): string;
var
  y, mm, d, h, m, s, ms: Word;
begin
  DecodeTime(Now(), h, m, s, ms);
  DecodeDate(Date(), y, mm, d);
  Result := IntToHex(mm, 2) + IntToHex(d, 2) + IntToHex(h, 2)
    + IntToHex(m, 2) + IntToHex(s, 2) + IntToHex(ms, 2);
  Result := '---------------------------' + system.Copy(Result, 1, 12);
end;          

function TclHttpRequest.GetRequestAsStream: TStream;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsHttpRequestDemoDisplayed) then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsHttpRequestDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}
  FIsParse := True;
  try
    InitBoundary();
  finally
    FIsParse := False;
  end;

  Result := TclMultiStream.Create();
  try
    GetTotalRequestData(TclMultiStream(Result));
  except
    Result.Free();
    raise;
  end;
end;

procedure TclHttpRequest.GetTotalRequestData(AStream: TclMultiStream);
var
  i: Integer;
  s: string;
begin
  for i := 0 to Count - 1 do
  begin
    s := '';
    if IsMultiPart() then
    begin
      s := '--' + Header.Boundary + #13#10;
      if (i > 0) then
      begin
        s := #13#10 + s;
      end;
    end else
    if (i > 0) and IsForm() then
    begin
      s := '&';
    end;
    if (s <> '') then
    begin
      AStream.AddStream(TStringStream.Create(s));
    end;
    AStream.AddStream(Items[i].GetData());
  end;
  if isMultipart() then
  begin
    s := #13#10 + '--' + Header.Boundary + '--'#13#10;
    AStream.AddStream(TStringStream.Create(s));
  end;
end;

function TclHttpRequest.GetTotalSize: Integer;
var
  i: Integer;
  bound: string;
begin
  bound := GenerateBoundary();
  Result := 0;
  for i := 0 to Count - 1 do
  begin
    Result := Result + Items[i].GetSize();
  end;
  if IsMultiPart() then
  begin
    Result := Result
      + Length(#13#10 + '--' + bound + #13#10) * Count
      + Length('--' + bound + '--'#13#10);
  end else
  if IsForm() then
  begin
    Result := Result + Length('&') * (Count - 1);
  end;
end;

function TclHttpRequest.GetFormField(const AFieldName: string): TclFormFieldRequestItem;
var
  i: Integer;
begin
  for i := 0 to Count - 1 do
  begin
    if (Items[i] is TclFormFieldRequestItem) then
    begin
      Result := (Items[i] as TclFormFieldRequestItem);
      if (CompareText(Result.FieldName, AFieldName) = 0 )then Exit;
    end;
  end;
  Result := nil;
end;

procedure TclHttpRequest.DoGetDataStream(AItem: TclHttpRequestItem; var AData: TStream);
begin
  if Assigned(OnGetDataStream) then
  begin
    OnGetDataStream(Self, AItem, AData);
  end;
end;

procedure TclHttpRequest.DoGetDataSourceStream(AItem: TclHttpRequestItem; var AData: TStream);
begin
  if Assigned(OnGetDataSourceStream) then
  begin
    OnGetDataSourceStream(Self, AItem, AData);
  end;
end;

procedure TclHttpRequest.Changed;
begin
  if not FIsParse then
  begin
    Header.Boundary := '';
  end;
  FHeaderSource.Clear();
  FRequestSource.Clear();
  if Assigned(OnChanged) then
  begin
    OnChanged(Self);
  end;
end;

procedure TclHttpRequest.BeginUpdate;
begin
  Inc(FUpdateCount);
end;

procedure TclHttpRequest.EndUpdate;
begin
  if (FUpdateCount > 0) then
  begin
    Dec(FUpdateCount);
    if (FUpdateCount = 0) then
    begin
      Changed();
    end;
  end;
end;

function TclHttpRequest.BuildFormPostRequest(AParser: TclHtmlParser;
  AFormNumber: Integer): string;
var
  i: Integer;
  Form: TclHtmlForm;
  TagName, ControlType, ControlName, OldName: string;
  isMultiPartReq: Boolean;
begin
  Clear();
  Result := '';
  if AParser.Forms.Count = 0 then Exit;
  Form := AParser.Forms[AFormNumber];
  Result := Form.Action;
  OldName := '';
  isMultiPartReq := SameText('multipart/form-data', Form.EncType);
  for i := 0 to Form.Controls.Count - 1 do
  begin
    TagName := LowerCase(Form.Controls[i].Name);
    ControlName := Form.Controls[i].AttributeValue('name');
    if (TagName = 'input') then
    begin
      ControlType := LowerCase(Form.Controls[i].AttributeValue('type'));
      if (ControlType = 'checkbox')
        or (ControlType = 'hidden')
        or (ControlType = 'password')
        or (ControlType = 'text')
        or (ControlType = '') then
      begin
        AddFormField(ControlName, Form.Controls[i].AttributeValue('value'));
      end else
      if (ControlType = 'radio') then
      begin
        if (OldName <> ControlName) then
        begin
          OldName := ControlName;
          AddFormField(ControlName, '');
        end;
      end else
      if (ControlType = 'file') then
      begin
        if isMultiPartReq then
        begin
          AddSubmitFile(Form.Controls[i].AttributeValue('value'), ControlName);
        end else
        begin
          AddFormField(ControlName, Form.Controls[i].AttributeValue('value'));
        end;
      end;
    end else
    if (TagName = 'select')
      or (TagName = 'textarea') then
    begin
      AddFormField(ControlName, '');
    end;
  end;
  if SameText(Form.Method, 'GET') then
  begin
    Header.ContentType := '';
  end;
end;

function TclHttpRequest.BuildFormPostRequest(AParser: TclHtmlParser): string;
var
  FormNumber: Integer;
begin
  FormNumber := 0;
  DoGetFormNumber(AParser, FormNumber);
  Result := BuildFormPostRequest(AParser, FormNumber);
end;

function TclHttpRequest.BuildFormPostRequest(const AUrl: string): string;
var
  Html: TStrings;
  buf: array[0..INTERNET_MAX_URL_LENGTH - 1] of Char;
  len: DWORD;
  s: string;
begin
  Html := TStringList.Create();
  try
    DownloadUrl(AUrl, 5000, Html);
    len := SizeOf(buf);
    s := BuildFormPostRequest(Html);
    InternetCombineUrl(PChar(AUrl), PChar(s), buf, len, ICU_BROWSER_MODE);
    Result := buf;
  finally
    Html.Free();
  end;
end;

function TclHttpRequest.BuildFormPostRequest(AHtml: TStrings): string;
var
  Parser: TclHtmlParser;
begin
  Parser := TclHtmlParser.Create(nil);
  try
    Parser.Parse(AHtml);
    Result := BuildFormPostRequest(Parser);
  finally
    Parser.Free();
  end;
end;

procedure TclHttpRequest.DoGetFormNumber(AParser: TclHtmlParser; var AFormNumber: Integer);
begin
  if Assigned(OnGetFormNumber) then
  begin
    OnGetFormNumber(Self, AParser, AFormNumber);
  end;
end;

function TclHttpRequest.GetRequestSource: TStrings;
var
  Stream: TStream;
begin
  if (FRequestSource.Count = 0) then
  begin
    Stream := GetRequestAsStream();
    try
      FRequestSource.LoadFromStream(Stream);
    finally
      Stream.Free();
    end;
  end;
  Result := FRequestSource;
end;

procedure TclHttpRequest.InitBoundary;
begin
  if IsMultiPart() then
  begin
    if (Header.Boundary = '') then
    begin
      Header.Boundary := GenerateBoundary();
    end;
  end else
  begin
    Header.Boundary := '';
  end;
end;

procedure TclHttpRequest.InitHeader;
begin
  InitBoundary();

  Header.ContentLength := IntToStr(TotalSize);
  if (Header.ContentLength = '0') then
  begin
    Header.ContentLength := '';
  end;
end;

function TclHttpRequest.GetHeaderSource: TStrings;
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsHttpRequestDemoDisplayed) then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsHttpRequestDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}

  if (FHeaderSource.Count = 0) then
  begin
    FIsParse := True;
    try
      InitHeader();
    finally
      FIsParse := False;
    end;

    Header.AssignHeader(FHeaderSource);
  end;
  Result := FHeaderSource;
end;

procedure TclHttpRequest.SetHeaderSource(const Value: TStrings);
begin
{$IFDEF DEMO}
{$IFNDEF STANDALONEDEMO}
  if FindWindow('TAppBuilder', nil) = 0 then
  begin
    MessageBox(0, 'This demo version can be run under Delphi/C++Builder IDE only. ' +
      'Please visit www.clevercomponents.com to purchase your ' +
      'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    ExitProcess(1);
  end else
{$ENDIF}
  begin
{$IFNDEF IDEDEMO}
    if (not IsHttpRequestDemoDisplayed) then
    begin
      MessageBox(0, 'Please visit www.clevercomponents.com to purchase your ' +
        'copy of the library.', 'Information', MB_ICONEXCLAMATION  or MB_TASKMODAL or MB_TOPMOST);
    end;
    IsHttpRequestDemoDisplayed := True;
{$ENDIF}
  end;
{$ENDIF}
  FIsParse := True;
  try
    Header.ParseHeader(Value);
  finally
    FIsParse := False;
  end;
end;

procedure TclHttpRequest.ParseFormField(const AFieldInfo: string);
var
  ind: Integer;
  name, val: string;
begin
  ind := Pos('=', AFieldInfo);
  if (ind > 0) then
  begin
    name := Copy(AFieldInfo, 1, ind - 1);
    val := Copy(AFieldInfo, ind + 1, Length(AFieldInfo));
  end else
  begin
    name := AFieldInfo;
    val := '';
  end;
  AddFormField(Trim(Name), Trim(val)).AfterAddData();
end;

procedure TclHttpRequest.ParseFormFieldRequest(const ASource: string);
var
  i: Integer;
  s: string;
begin
  s := '';
  for i := 1 to Length(ASource) do
  begin
    if (ASource[i] = '&') then
    begin
      ParseFormField(s);
      s := '';
    end else
    begin
      s := s + ASource[i];
    end;
  end;
  if (s <> '') then
  begin
    ParseFormField(s);
  end;
end;

function TclHttpRequest.ReadLine(AStream: TStream; AMaxBytes: Integer): string;
const
  cDelimiter = #13#10;

var
  delimCount: Integer;
  Symbol: Char;
begin
  Result := '';
  delimCount := 0;
  Assert(AMaxBytes > 0);

  while (AMaxBytes > 0) and (AStream.Read(Symbol, 1) > 0) do
  begin
    if (Symbol = cDelimiter[delimCount + 1]) then
    begin
      Inc(delimCount);
    end else
    begin
      delimCount := 0;
    end;

    if (delimCount >= Length(cDelimiter)) then
    begin
      Break;
    end;

    Result := Result + Symbol;
    Dec(AMaxBytes);
  end;
end;

function TclHttpRequest.CreateItem(AHeader, AFieldList: TStrings): TclHttpRequestItem;
var
  fileName, contDisposition: string;
begin
  contDisposition := GetHeaderFieldValue(AHeader, AFieldList, 'Content-Disposition');
  if (LowerCase(GetHeaderFieldValueItem(contDisposition, '')) = 'form-data') then
  begin
    fileName := GetHeaderFieldValueItem(contDisposition, 'filename=');
    if (fileName <> '') then
    begin
      Result := AddSubmitFile(fileName);
    end else
    begin
      Result := AddFormField(GetHeaderFieldValueItem(contDisposition, 'name='), '');
    end;
  end else
  begin
    Result := AddTextData('');
  end;
end;

procedure TclHttpRequest.ParseMultiPartRequest(AStream: TStream);
var
  buf: PChar;
  i, len, dataSize, bufSize,
  boundCnt, eofHeadCnt, startPos: Integer;
  bound, eofHead, head, temp: string;
  item: TclHttpRequestItem;
begin
  bufSize := BatchSize;
  if (bufSize < Length(Header.Boundary)) then
  begin
    bufSize := Length(Header.Boundary);
  end;
  if (bufSize > AStream.Size - AStream.Position) then
  begin
    bufSize := AStream.Size - AStream.Position;
  end;

  GetMem(buf, bufSize);
  try
    bound := #13#10'--' + Header.Boundary;
    eofHead := #13#10#13#10;

    head := '';
    temp := '';
    item := nil;
    boundCnt := 2;
    eofHeadCnt := 0;
    len := bufSize;
    while (len > 0) do
    begin
      len := AStream.Read(buf^, bufSize);

      startPos := 0;
      for i := 0 to len - 1 do
      begin
        if ((buf + i)^ = bound[boundCnt + 1]) then
        begin
          Inc(boundCnt);
        end else
        begin
          boundCnt := 0;
          if ((buf + i)^ = bound[boundCnt + 1]) then
          begin
            Inc(boundCnt);
          end;